diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,118 @@ # Changelog for haskell-language-server +## 2.8.0.0 + +- Bindists for GHC 9.6.5 +- New hls-notes plugin (#4126, @jvanbruegge) +- Floskell, hlint and stylish-haskell plugins enabled for GHC 9.8 +- Improvements for hls-graph increasing robustness (#4087, @soulomoon) +- Improvements to multi-component support (#4096, #4109, #4179, @wz1000, @fendor) + +### Pull Requests + +- Bump haskell-actions/setup from 2.7.0 to 2.7.1 + ([#4189](https://github.com/haskell/haskell-language-server/pull/4189)) by @dependabot[bot] +- Bump haskell-actions/setup from 2.7.0 to 2.7.1 in /.github/actions/setup-build + ([#4188](https://github.com/haskell/haskell-language-server/pull/4188)) by @dependabot[bot] +- Fix ghcdie-tests CI + ([#4184](https://github.com/haskell/haskell-language-server/pull/4184)) by @soulomoon +- Fix ghc and hlint warnings, fix formatting + ([#4181](https://github.com/haskell/haskell-language-server/pull/4181)) by @jhrcek +- Allow users to specify whether to use `cabal`'s multi-repl feature + ([#4179](https://github.com/haskell/haskell-language-server/pull/4179)) by @fendor +- Improve parsing of import suggestions extending multiple multiline imports (fixes #4175) + ([#4177](https://github.com/haskell/haskell-language-server/pull/4177)) by @jhrcek +- move ghcide-tests to haskell-language-server.cabal and make it depend on hls-test-utils + ([#4176](https://github.com/haskell/haskell-language-server/pull/4176)) by @soulomoon +- enable ThreadId for when testing + ([#4174](https://github.com/haskell/haskell-language-server/pull/4174)) by @soulomoon +- Drop Legacy Logger from Codebase + ([#4171](https://github.com/haskell/haskell-language-server/pull/4171)) by @fendor +- get rid of the `unsafeInterleaveIO` at start up + ([#4167](https://github.com/haskell/haskell-language-server/pull/4167)) by @soulomoon +- Remove EKG + ([#4163](https://github.com/haskell/haskell-language-server/pull/4163)) by @michaelpj +- Mark plugins as not buildable if the flag is disabled + ([#4160](https://github.com/haskell/haskell-language-server/pull/4160)) by @michaelpj +- Fix references to old CPP names in tests, update tests + ([#4159](https://github.com/haskell/haskell-language-server/pull/4159)) by @jhrcek +- Bump haskell-actions/setup from 2.6.3 to 2.7.0 + ([#4158](https://github.com/haskell/haskell-language-server/pull/4158)) by @dependabot[bot] +- Bump haskell-actions/setup from 2.6.3 to 2.7.0 in /.github/actions/setup-build + ([#4157](https://github.com/haskell/haskell-language-server/pull/4157)) by @dependabot[bot] +- Remove dead code in ghcide and hls-graph for priority + ([#4151](https://github.com/haskell/haskell-language-server/pull/4151)) by @soulomoon +- Bump haskell-actions/setup from 2.6.2 to 2.6.3 in /.github/actions/setup-build + ([#4150](https://github.com/haskell/haskell-language-server/pull/4150)) by @dependabot[bot] +- Bump haskell-actions/setup from 2.6.2 to 2.6.3 + ([#4149](https://github.com/haskell/haskell-language-server/pull/4149)) by @dependabot[bot] +- Run ExceptionTests in temporary directory + ([#4146](https://github.com/haskell/haskell-language-server/pull/4146)) by @fendor +- hls-eval-plugin: Replicate #4139 + ([#4140](https://github.com/haskell/haskell-language-server/pull/4140)) by @mattapet +- Update comment in refactor tests + ([#4138](https://github.com/haskell/haskell-language-server/pull/4138)) by @jhrcek +- Update contact info in docs + ([#4137](https://github.com/haskell/haskell-language-server/pull/4137)) by @jhrcek +- hls-notes-plugin: Do not error if no note is under the cursor + ([#4136](https://github.com/haskell/haskell-language-server/pull/4136)) by @jvanbruegge +- improve logging in semantic tokens rule + ([#4135](https://github.com/haskell/haskell-language-server/pull/4135)) by @soulomoon +- Bump softprops/action-gh-release from 1 to 2 + ([#4133](https://github.com/haskell/haskell-language-server/pull/4133)) by @dependabot[bot] +- Bump cachix/install-nix-action from 25 to 26 + ([#4132](https://github.com/haskell/haskell-language-server/pull/4132)) by @dependabot[bot] +- Use Set.member instead of Foldable.elem + ([#4128](https://github.com/haskell/haskell-language-server/pull/4128)) by @jhrcek +- hls-notes-plugin: Initial implementation + ([#4126](https://github.com/haskell/haskell-language-server/pull/4126)) by @jvanbruegge +- Enable floskell and hlint plugins for ghc 9.8 + ([#4125](https://github.com/haskell/haskell-language-server/pull/4125)) by @jhrcek +- Integrate stylish-haskell into hls executable with ghc 9.8 + ([#4124](https://github.com/haskell/haskell-language-server/pull/4124)) by @jhrcek +- Reduce usage of partial functions + ([#4123](https://github.com/haskell/haskell-language-server/pull/4123)) by @jhrcek +- Benchmark: Enable 9.6, 9.8 + ([#4118](https://github.com/haskell/haskell-language-server/pull/4118)) by @soulomoon +- Bump haskell-actions/setup from 2.6.1 to 2.6.2 in /.github/actions/setup-build + ([#4116](https://github.com/haskell/haskell-language-server/pull/4116)) by @dependabot[bot] +- Bump haskell-actions/setup from 2.6.1 to 2.6.2 + ([#4115](https://github.com/haskell/haskell-language-server/pull/4115)) by @dependabot[bot] +- eval: more robust way to extract comments from ParsedModule + ([#4113](https://github.com/haskell/haskell-language-server/pull/4113)) by @jhrcek +- Improve isolation of build artefacts of test runs + ([#4112](https://github.com/haskell/haskell-language-server/pull/4112)) by @fendor +- Improve handling of nonsense rename attempts + ([#4111](https://github.com/haskell/haskell-language-server/pull/4111)) by @jhrcek +- Exit with non-zero exitcode if wrapper fails to launch + ([#4110](https://github.com/haskell/haskell-language-server/pull/4110)) by @fendor +- Replace checkHomeUnitsClosed with a faster implementation + ([#4109](https://github.com/haskell/haskell-language-server/pull/4109)) by @wz1000 +- Don't distribute gifs or plugin readmes + ([#4107](https://github.com/haskell/haskell-language-server/pull/4107)) by @fendor +- Remove locale workaround for Module name that conatins non-ascii characters + ([#4106](https://github.com/haskell/haskell-language-server/pull/4106)) by @fendor +- Track extra-source-files of plugins more accurately + ([#4105](https://github.com/haskell/haskell-language-server/pull/4105)) by @fendor +- remove non-ascii name + ([#4103](https://github.com/haskell/haskell-language-server/pull/4103)) by @soulomoon +- Add cabal-gild as a cabal file formatter plugin + ([#4101](https://github.com/haskell/haskell-language-server/pull/4101)) by @fendor +- Remove more workarounds for GHCs < 9.2 (#4092) + ([#4098](https://github.com/haskell/haskell-language-server/pull/4098)) by @jhrcek +- session-loader: Don't loop forever when we don't find a file in any multi component + ([#4096](https://github.com/haskell/haskell-language-server/pull/4096)) by @wz1000 +- Prepare release 2.7.0.0 + ([#4095](https://github.com/haskell/haskell-language-server/pull/4095)) by @fendor +- Remove more workarounds for GHCs < 9.0 + ([#4092](https://github.com/haskell/haskell-language-server/pull/4092)) by @jhrcek +- Fix hls-graph: phantom dependencies invoke in branching deps (resolve #3423) + ([#4087](https://github.com/haskell/haskell-language-server/pull/4087)) by @soulomoon +- Rename only if the current module compiles (#3799) + ([#3848](https://github.com/haskell/haskell-language-server/pull/3848)) by @sgillespie +- Reintroduce ghc-lib flag for hlint plugin + ([#3757](https://github.com/haskell/haskell-language-server/pull/3757)) by @RaoulHC + ## 2.7.0.0 - Bindists for GHC 9.8.2 diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -202,8 +202,6 @@ liftIO $ writeFile projectLocal $ unlines ["package haskell-language-server" ," ghc-options: -eventlog -rtsopts" - ,"package ghcide" - ," flags: +ekg" ] return projectLocalExists) (\projectLocalExists -> do diff --git a/exe/Wrapper.hs b/exe/Wrapper.hs --- a/exe/Wrapper.hs +++ b/exe/Wrapper.hs @@ -41,11 +41,8 @@ import qualified Data.Text.IO as T import Development.IDE.LSP.LanguageServer (runLanguageServer) import qualified Development.IDE.Main as Main -import GHC.Stack.Types (emptyCallStack) -import Ide.Logger (Doc, Logger (Logger), - Pretty (pretty), - Recorder (logger_), - WithPriority (WithPriority), +import Ide.Logger (Doc, Pretty (pretty), + Recorder, WithPriority, cmapWithPrio, makeDefaultStderrRecorder) import Ide.Plugin.Config (Config) @@ -99,9 +96,11 @@ Left err -> do T.hPutStrLn stderr (prettyError err NoShorten) case args of - Ghcide _ -> launchErrorLSP recorder (prettyError err Shorten) - _ -> pure () + Ghcide (GhcideArguments { argsCommand = Main.LSP }) -> + launchErrorLSP recorder (prettyError err Shorten) + _ -> exitFailure + launchHaskellLanguageServer :: Recorder (WithPriority (Doc ())) -> Arguments -> IO (Either WrapperSetupError ()) launchHaskellLanguageServer recorder parsedArgs = do case parsedArgs of @@ -270,9 +269,7 @@ -- to shut down the LSP. launchErrorLSP :: Recorder (WithPriority (Doc ())) -> T.Text -> IO () launchErrorLSP recorder errorMsg = do - let logger = Logger $ \p m -> logger_ recorder (WithPriority p emptyCallStack (pretty m)) - - let defaultArguments = Main.defaultArguments (cmapWithPrio pretty recorder) logger (IdePlugins []) + let defaultArguments = Main.defaultArguments (cmapWithPrio pretty recorder) (IdePlugins []) inH <- Main.argsHandleIn defaultArguments diff --git a/ghcide/test/exe/AsyncTests.hs b/ghcide/test/exe/AsyncTests.hs new file mode 100644 --- /dev/null +++ b/ghcide/test/exe/AsyncTests.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE DataKinds #-} + +module AsyncTests (tests) where + +import Control.Monad +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (toJSON) +import Data.Proxy +import qualified Data.Text as T +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +-- import Test.QuickCheck.Instances () +import Development.IDE.Plugin.Test (TestRequest (BlockSeconds), + blockCommandId) +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + +-- | Test if ghcide asynchronously handles Commands and user Requests +tests :: TestTree +tests = testGroup "async" + [ + testSession "command" $ do + -- Execute a command that will block forever + let req = ExecuteCommandParams Nothing blockCommandId Nothing + void $ sendRequest SMethod_WorkspaceExecuteCommand req + -- Load a file and check for code actions. Will only work if the command is run asynchronously + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# OPTIONS -Wmissing-signatures #-}" + , "foo = id" + ] + void waitForDiagnostics + codeLenses <- getAndResolveCodeLenses doc + liftIO $ [ _title | CodeLens{_command = Just Command{_title}} <- codeLenses] @=? + [ "foo :: a -> a" ] + , testSession "request" $ do + -- Execute a custom request that will block for 1000 seconds + void $ sendRequest (SMethod_CustomMethod (Proxy @"test")) $ toJSON $ BlockSeconds 1000 + -- Load a file and check for code actions. Will only work if the request is run asynchronously + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# OPTIONS -Wmissing-signatures #-}" + , "foo = id" + ] + void waitForDiagnostics + codeLenses <- getAndResolveCodeLenses doc + liftIO $ [ _title | CodeLens{_command = Just Command{_title}} <- codeLenses] @=? + [ "foo :: a -> a" ] + ] diff --git a/ghcide/test/exe/BootTests.hs b/ghcide/test/exe/BootTests.hs new file mode 100644 --- /dev/null +++ b/ghcide/test/exe/BootTests.hs @@ -0,0 +1,55 @@ +module BootTests (tests) where + +import Control.Applicative.Combinators +import Control.Monad +import Control.Monad.IO.Class (liftIO) +import Development.IDE.GHC.Util +import Development.IDE.Test (expectNoMoreDiagnostics, + isReferenceReady) +import Development.IDE.Types.Location +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +import System.FilePath +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + + +tests :: TestTree +tests = testGroup "boot" + [ testCase "boot-def-test" $ runWithExtraFiles "boot" $ \dir -> do + let cPath = dir "C.hs" + cSource <- liftIO $ readFileUtf8 cPath + -- Dirty the cache + liftIO $ runInDir dir $ do + cDoc <- createDoc cPath "haskell" cSource + -- We send a hover request then wait for either the hover response or + -- `ghcide/reference/ready` notification. + -- Once we receive one of the above, we wait for the other that we + -- haven't received yet. + -- If we don't wait for the `ready` notification it is possible + -- that the `getDefinitions` request/response in the outer ghcide + -- session will find no definitions. + let hoverParams = HoverParams cDoc (Position 4 3) Nothing + hoverRequestId <- sendRequest SMethod_TextDocumentHover hoverParams + let parseReadyMessage = isReferenceReady cPath + let parseHoverResponse = responseForId SMethod_TextDocumentHover hoverRequestId + hoverResponseOrReadyMessage <- skipManyTill anyMessage ((Left <$> parseHoverResponse) <|> (Right <$> parseReadyMessage)) + _ <- skipManyTill anyMessage $ + case hoverResponseOrReadyMessage of + Left _ -> void parseReadyMessage + Right _ -> void parseHoverResponse + closeDoc cDoc + cdoc <- createDoc cPath "haskell" cSource + locs <- getDefinitions cdoc (Position 7 4) + let floc = mkR 9 0 9 1 + checkDefs locs (pure [floc]) + , testCase "graph with boot modules" $ runWithExtraFiles "boot2" $ \dir -> do + _ <- openDoc (dir "A.hs") "haskell" + expectNoMoreDiagnostics 2 + ] diff --git a/ghcide/test/exe/CPPTests.hs b/ghcide/test/exe/CPPTests.hs new file mode 100644 --- /dev/null +++ b/ghcide/test/exe/CPPTests.hs @@ -0,0 +1,56 @@ +module CPPTests (tests) where + +import Control.Exception (catch) +import qualified Data.Text as T +import Development.IDE.Test (Cursor, expectDiagnostics, + expectNoMoreDiagnostics) +import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), mkRange) +import Language.LSP.Test +-- import Test.QuickCheck.Instances () +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + +tests :: TestTree +tests = + testGroup "cpp" + [ ignoreInWindowsBecause "Throw a lsp session time out in windows for ghc-8.8 and is broken for other versions" $ testCase "cpp-error" $ do + let content = + T.unlines + [ "{-# LANGUAGE CPP #-}", + "module Testing where", + "#ifdef FOO", + "foo = 42" + ] + -- The error locations differ depending on which C-preprocessor is used. + -- Some give the column number and others don't (hence maxBound == -1 unsigned). Assert either + -- of them. + (run $ expectError content (2, maxBound)) + `catch` ( \e -> do + let _ = e :: HUnitFailure + run $ expectError content (2, 1) + ) + , testSessionWait "cpp-ghcide" $ do + _ <- createDoc "A.hs" "haskell" $ T.unlines + ["{-# LANGUAGE CPP #-}" + ,"main =" + ,"#ifdef __GHCIDE__" + ," worked" + ,"#else" + ," failed" + ,"#endif" + ] + expectDiagnostics [("A.hs", [(DiagnosticSeverity_Error, (3, 2), "Variable not in scope: worked")])] + ] + where + expectError :: T.Text -> Cursor -> Session () + expectError content cursor = do + _ <- createDoc "Testing.hs" "haskell" content + expectDiagnostics + [ ( "Testing.hs", + [(DiagnosticSeverity_Error, cursor, "error: unterminated")] + ) + ] + expectNoMoreDiagnostics 0.5 diff --git a/ghcide/test/exe/ClientSettingsTests.hs b/ghcide/test/exe/ClientSettingsTests.hs new file mode 100644 --- /dev/null +++ b/ghcide/test/exe/ClientSettingsTests.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE GADTs #-} +module ClientSettingsTests (tests) where + +import Control.Applicative.Combinators +import Control.Monad +import Data.Aeson (toJSON) +import Data.Default +import qualified Data.Text as T +import Ide.Types +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +import Test.Tasty +import TestUtils + +tests :: TestTree +tests = testGroup "client settings handling" + [ testSession "ghcide restarts shake session on config changes" $ do + setIgnoringLogNotifications False + void $ createDoc "A.hs" "haskell" "module A where" + waitForProgressDone + setConfigSection "haskell" $ toJSON (def :: Config) + skipManyTill anyMessage restartingBuildSession + + ] + where + restartingBuildSession :: Session () + restartingBuildSession = do + FromServerMess SMethod_WindowLogMessage TNotificationMessage{_params = LogMessageParams{..}} <- loggingNotification + guard $ "Restarting build session" `T.isInfixOf` _message diff --git a/ghcide/test/exe/CodeLensTests.hs b/ghcide/test/exe/CodeLensTests.hs new file mode 100644 --- /dev/null +++ b/ghcide/test/exe/CodeLensTests.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE GADTs #-} + +module CodeLensTests (tests) where + +import Control.Applicative.Combinators +import Control.Lens ((^.)) +import Control.Monad (void) +import Control.Monad.IO.Class (liftIO) +import qualified Data.Aeson as A +import Data.Maybe +import qualified Data.Text as T +import Data.Tuple.Extra +import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + +tests :: TestTree +tests = testGroup "code lenses" + [ addSigLensesTests + ] + + +addSigLensesTests :: TestTree +addSigLensesTests = + let pragmas = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}" + moduleH exported = + T.unlines + [ "{-# LANGUAGE PatternSynonyms,TypeApplications,DataKinds,RankNTypes,ScopedTypeVariables,TypeOperators,GADTs,BangPatterns #-}" + , "module Sigs(" <> exported <> ") where" + , "import qualified Data.Complex as C" + , "import Data.Data (Proxy (..), type (:~:) (..), mkCharType)" + , "data T1 a where" + , " MkT1 :: (Show b) => a -> b -> T1 a" + ] + before enableGHCWarnings exported (def, _) others = + T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported, def] <> others + after' enableGHCWarnings exported (def, sig) others = + T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported] <> maybe [] pure sig <> [def] <> others + createConfig mode = A.object ["plugin" A..= A.object ["ghcide-type-lenses" A..= A.object ["config" A..= A.object ["mode" A..= A.String mode]]]] + sigSession testName enableGHCWarnings waitForDiags mode exported def others = testSession testName $ do + let originalCode = before enableGHCWarnings exported def others + let expectedCode = after' enableGHCWarnings exported def others + setConfigSection "haskell" (createConfig mode) + doc <- createDoc "Sigs.hs" "haskell" originalCode + -- Because the diagnostics mode is really relying only on diagnostics now + -- to generate the code lens we need to make sure we wait till the file + -- is parsed before asking for codelenses, otherwise we will get nothing. + if waitForDiags + then void waitForDiagnostics + else waitForProgressDone + codeLenses <- getAndResolveCodeLenses doc + if not $ null $ snd def + then do + liftIO $ length codeLenses == 1 @? "Expected 1 code lens, but got: " <> show codeLenses + executeCommand $ fromJust $ head codeLenses ^. L.command + modifiedCode <- skipManyTill anyMessage (getDocumentEdit doc) + liftIO $ expectedCode @=? modifiedCode + else liftIO $ null codeLenses @? "Expected no code lens, but got: " <> show codeLenses + cases = + [ ("abc = True", "abc :: Bool") + , ("foo a b = a + b", "foo :: Num a => a -> a -> a") + , ("bar a b = show $ a + b", "bar :: (Show a, Num a) => a -> a -> String") + , ("(!!!) a b = a > b", "(!!!) :: Ord a => a -> a -> Bool") + , ("a >>>> b = a + b", "(>>>>) :: Num a => a -> a -> a") + , ("a `haha` b = a b", "haha :: (t1 -> t2) -> t1 -> t2") + , ("pattern Some a = Just a", "pattern Some :: a -> Maybe a") + , ("pattern Some a <- Just a", "pattern Some :: a -> Maybe a") + , ("pattern Some a <- Just a\n where Some a = Just a", "pattern Some :: a -> Maybe a") + , ("pattern Some a <- Just !a\n where Some !a = Just a", "pattern Some :: a -> Maybe a") + , ("pattern Point{x, y} = (x, y)", "pattern Point :: a -> b -> (a, b)") + , ("pattern Point{x, y} <- (x, y)", "pattern Point :: a -> b -> (a, b)") + , ("pattern Point{x, y} <- (x, y)\n where Point x y = (x, y)", "pattern Point :: a -> b -> (a, b)") + , ("pattern MkT1' b = MkT1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a") + , ("pattern MkT1' b <- MkT1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a") + , ("pattern MkT1' b <- MkT1 42 b\n where MkT1' b = MkT1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a") + , ("qualifiedSigTest= C.realPart", "qualifiedSigTest :: C.Complex a -> a") + , ("head = 233", "head :: Integer") + , ("rank2Test (k :: forall a . a -> a) = (k 233 :: Int, k \"QAQ\")", "rank2Test :: (forall a. a -> a) -> (Int, String)") + , ("symbolKindTest = Proxy @\"qwq\"", "symbolKindTest :: Proxy \"qwq\"") + , ("promotedKindTest = Proxy @Nothing", if ghcVersion >= GHC96 then "promotedKindTest :: Proxy Nothing" else "promotedKindTest :: Proxy 'Nothing") + , ("typeOperatorTest = Refl", "typeOperatorTest :: forall {k} {a :: k}. a :~: a") + , ("notInScopeTest = mkCharType", "notInScopeTest :: String -> Data.Data.DataType") + , ("aVeryLongSignature a b c d e f g h i j k l m n = a && b && c && d && e && f && g && h && i && j && k && l && m && n", "aVeryLongSignature :: Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool") + ] + in testGroup + "add signature" + [ testGroup "signatures are correct" [sigSession (T.unpack $ T.replace "\n" "\\n" def) False False "always" "" (def, Just sig) [] | (def, sig) <- cases] + , sigSession "exported mode works" False False "exported" "xyz" ("xyz = True", Just "xyz :: Bool") (fst <$> take 3 cases) + , testGroup + "diagnostics mode works" + [ sigSession "with GHC warnings" True True "diagnostics" "" (second Just $ head cases) [] + , sigSession "without GHC warnings" False False "diagnostics" "" (second (const Nothing) $ head cases) [] + ] + , testSession "keep stale lens" $ do + let content = T.unlines + [ "module Stale where" + , "f = _" + ] + doc <- createDoc "Stale.hs" "haskell" content + oldLens <- getCodeLenses doc + liftIO $ length oldLens @?= 1 + let edit = TextEdit (mkRange 0 4 0 5) "" -- Remove the `_` + _ <- applyEdit doc edit + newLens <- getCodeLenses doc + liftIO $ newLens @?= oldLens + ] diff --git a/ghcide/test/exe/CompletionTests.hs b/ghcide/test/exe/CompletionTests.hs new file mode 100644 --- /dev/null +++ b/ghcide/test/exe/CompletionTests.hs @@ -0,0 +1,574 @@ + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} + +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.Test (waitForTypecheck) +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.Tasty +import Test.Tasty.HUnit +import TestUtils + + +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 + ] + +completionTest :: HasCallStack => String -> [T.Text] -> Position -> [(T.Text, CompletionItemKind, T.Text, Bool, Bool, Maybe [TextEdit])] -> TestTree +completionTest name src pos expected = testSessionWait name $ do + docId <- createDoc "A.hs" "haskell" (T.unlines src) + _ <- 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) + ], + testSessionWait "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 = knownBrokenFor (BrokenSpecific Windows [GHC92, GHC94, GHC96, GHC98]) "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)], + + testSession "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"], + + testSessionWait "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 = + [ testSession' "fromList" $ \dir -> do + liftIO $ writeFile (dir "hie.yaml") + "cradle: {direct: {arguments: [-hide-all-packages, -package, base, A]}}" + 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 []) + + , testSessionWait "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" + ] + , testSessionWait "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 + + , testSessionWait "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 = + [ testSession' "from hiedb" $ \dir-> do + liftIO $ writeFile (dir "hie.yaml") + "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}" + _ <- 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"], + testSession' "auto complete project imports" $ \dir-> do + liftIO $ writeFile (dir "hie.yaml") + "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"ALocalModule\", \"B\"]}}" + _ <- 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", + testSession' "auto complete functions from qualified imports without alias" $ \dir-> do + liftIO $ writeFile (dir "hie.yaml") + "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}" + _ <- 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", + testSession' "auto complete functions from qualified imports with alias" $ \dir-> do + liftIO $ writeFile (dir "hie.yaml") + "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}" + _ <- 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 = + [ testSession "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] + , testSession "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"] + , testSession "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"] + , testSession "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"] + , testSession "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"] + , testSession "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 $ testSession "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 $ testSession "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] + , testSession "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 = knownBrokenFor (BrokenSpecific MacOS [GHC92, GHC94, GHC96]) "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/ghcide/test/exe/Config.hs b/ghcide/test/exe/Config.hs new file mode 100644 --- /dev/null +++ b/ghcide/test/exe/Config.hs @@ -0,0 +1,16 @@ +module Config where +import Ide.Types (defaultPluginDescriptor) +import System.FilePath (()) +import Test.Hls (PluginTestDescriptor, + mkPluginTestDescriptor) +import qualified Test.Hls.FileSystem as FS + +testDataDir :: FilePath +testDataDir = "ghcide" "test" "data" + +mkIdeTestFs :: [FS.FileTree] -> FS.VirtualFileTree +mkIdeTestFs = FS.mkVirtualFileTree testDataDir + +-- * A dummy plugin for testing ghcIde +dummyPlugin :: PluginTestDescriptor () +dummyPlugin = mkPluginTestDescriptor (\_ pid ->defaultPluginDescriptor pid "dummyTestPlugin") "core" diff --git a/ghcide/test/exe/CradleTests.hs b/ghcide/test/exe/CradleTests.hs new file mode 100644 --- /dev/null +++ b/ghcide/test/exe/CradleTests.hs @@ -0,0 +1,238 @@ + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} + +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.GHC.Util +import Development.IDE.Test (expectDiagnostics, + expectDiagnosticsWithTags, + expectNoMoreDiagnostics, + isReferenceReady, + waitForAction) +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.Lens ((^.)) +import Development.IDE.Plugin.Test (WaitForIdeRuleResult (..)) +import GHC.TypeLits (symbolVal) +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + + +tests :: TestTree +tests = testGroup "cradle" + [testGroup "dependencies" [sessionDepsArePickedUp] + ,testGroup "ignore-fatal" [ignoreFatalWarning] + ,testGroup "loading" [loadCradleOnlyonce, retryFailedCradle] + ,testGroup "multi" (multiTests "multi") + ,ignoreFor (BrokenForGHC [GHC92]) "multiple units not supported on 9.2" + $ testGroup "multi-unit" (multiTests "multi-unit") + ,testGroup "sub-directory" [simpleSubDirectoryTest] + ,ignoreFor (BrokenForGHC [GHC92]) "multiple units not supported on 9.2" + $ testGroup "multi-unit-rexport" [multiRexportTest] + ] + +loadCradleOnlyonce :: TestTree +loadCradleOnlyonce = testGroup "load cradle only once" + [ testSession' "implicit" implicit + , testSession' "direct" direct + ] + where + direct dir = do + liftIO $ writeFileUTF8 (dir "hie.yaml") + "cradle: {direct: {arguments: []}}" + test dir + implicit dir = test dir + test _dir = 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 = testSession' "retry failed" $ \dir -> do + -- The false cradle always fails + let hieContents = "cradle: {bios: {shell: \"false\"}}" + hiePath = dir "hie.yaml" + liftIO $ writeFile hiePath hieContents + let aPath = dir "A.hs" + doc <- createDoc aPath "haskell" "main = return ()" + WaitForIdeRuleResult {..} <- 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 $ dir "hie.yaml") FileChangeType_Changed ] + + WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc + liftIO $ "No joy after fixing the cradle" `assertBool` ideResultSuccess + + +cradleLoadedMessage :: Session FromServerMessage +cradleLoadedMessage = satisfy $ \case + FromServerMess (SMethod_CustomMethod p) (NotMess _) -> symbolVal p == cradleLoadedMethod + _ -> False + +cradleLoadedMethod :: String +cradleLoadedMethod = "ghcide/cradle/loaded" + +ignoreFatalWarning :: TestTree +ignoreFatalWarning = testCase "ignore-fatal-warning" $ runWithExtraFiles "ignore-fatal" $ \dir -> do + let srcPath = dir "IgnoreFatal.hs" + src <- liftIO $ readFileUtf8 srcPath + _ <- createDoc srcPath "haskell" src + expectNoMoreDiagnostics 5 + +simpleSubDirectoryTest :: TestTree +simpleSubDirectoryTest = + testCase "simple-subdirectory" $ runWithExtraFiles "cabal-exe" $ \dir -> do + let mainPath = dir "a/src/Main.hs" + mainSource <- liftIO $ readFileUtf8 mainPath + _mdoc <- createDoc mainPath "haskell" mainSource + expectDiagnosticsWithTags + [("a/src/Main.hs", [(DiagnosticSeverity_Warning,(2,0), "Top-level binding", Nothing)]) -- So that we know P has been loaded + ] + expectNoMoreDiagnostics 0.5 + +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 = testCase (multiTestName variant "test") $ withLongTimeout $ runWithExtraFiles variant $ \dir -> do + let aPath = dir "a/A.hs" + bPath = dir "b/B.hs" + adoc <- openDoc aPath "haskell" + bdoc <- openDoc bPath "haskell" + WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" adoc + liftIO $ assertBool "A should typecheck" ideResultSuccess + WaitForIdeRuleResult {..} <- 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]) + expectNoMoreDiagnostics 0.5 + +-- Like simpleMultiTest but open the files in the other order +simpleMultiTest2 :: FilePath -> TestTree +simpleMultiTest2 variant = testCase (multiTestName variant "test2") $ runWithExtraFiles variant $ \dir -> do + let aPath = dir "a/A.hs" + bPath = dir "b/B.hs" + bdoc <- openDoc bPath "haskell" + WaitForIdeRuleResult {} <- waitForAction "TypeCheck" bdoc + TextDocumentIdentifier auri <- openDoc aPath "haskell" + skipManyTill anyMessage $ isReferenceReady aPath + locs <- getDefinitions bdoc (Position 2 7) + let fooL = mkL auri 2 0 2 3 + checkDefs locs (pure [fooL]) + expectNoMoreDiagnostics 0.5 + +-- Now with 3 components +simpleMultiTest3 :: FilePath -> TestTree +simpleMultiTest3 variant = + testCase (multiTestName variant "test3") $ runWithExtraFiles variant $ \dir -> do + let aPath = dir "a/A.hs" + bPath = dir "b/B.hs" + cPath = dir "c/C.hs" + bdoc <- openDoc bPath "haskell" + WaitForIdeRuleResult {} <- waitForAction "TypeCheck" bdoc + TextDocumentIdentifier auri <- openDoc aPath "haskell" + skipManyTill anyMessage $ isReferenceReady aPath + cdoc <- openDoc cPath "haskell" + WaitForIdeRuleResult {} <- waitForAction "TypeCheck" cdoc + locs <- getDefinitions cdoc (Position 2 7) + let fooL = mkL auri 2 0 2 3 + checkDefs locs (pure [fooL]) + expectNoMoreDiagnostics 0.5 + +-- Like simpleMultiTest but open the files in component 'a' in a separate session +simpleMultiDefTest :: FilePath -> TestTree +simpleMultiDefTest variant = testCase (multiTestName variant "def-test") $ runWithExtraFiles variant $ \dir -> do + let aPath = dir "a/A.hs" + bPath = dir "b/B.hs" + adoc <- liftIO $ runInDir dir $ do + aSource <- liftIO $ readFileUtf8 aPath + adoc <- createDoc aPath "haskell" aSource + skipManyTill anyMessage $ isReferenceReady aPath + closeDoc adoc + pure adoc + bSource <- liftIO $ readFileUtf8 bPath + bdoc <- createDoc bPath "haskell" bSource + locs <- getDefinitions bdoc (Position 2 7) + let fooL = mkL (adoc ^. L.uri) 2 0 2 3 + checkDefs locs (pure [fooL]) + expectNoMoreDiagnostics 0.5 + +multiRexportTest :: TestTree +multiRexportTest = + testCase "multi-unit-reexport-test" $ runWithExtraFiles "multi-unit-reexport" $ \dir -> do + let cPath = dir "c/C.hs" + cdoc <- openDoc cPath "haskell" + WaitForIdeRuleResult {} <- waitForAction "TypeCheck" cdoc + locs <- getDefinitions cdoc (Position 3 7) + let aPath = dir "a/A.hs" + let fooL = mkL (filePathToUri aPath) 2 0 2 3 + checkDefs locs (pure [fooL]) + expectNoMoreDiagnostics 0.5 + +sessionDepsArePickedUp :: TestTree +sessionDepsArePickedUp = testSession' + "session-deps-are-picked-up" + $ \dir -> do + liftIO $ + writeFileUTF8 + (dir "hie.yaml") + "cradle: {direct: {arguments: []}}" + -- Open without OverloadedStrings and expect an error. + doc <- createDoc "Foo.hs" "haskell" fooContent + expectDiagnostics [("Foo.hs", [(DiagnosticSeverity_Error, (3, 6), "Couldn't match type")])] + + -- Update hie.yaml to enable OverloadedStrings. + liftIO $ + writeFileUTF8 + (dir "hie.yaml") + "cradle: {direct: {arguments: [-XOverloadedStrings]}}" + sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams + [FileEvent (filePathToUri $ dir "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] + -- Now no errors. + expectDiagnostics [("Foo.hs", [])] + where + fooContent = + T.unlines + [ "module Foo where", + "import Data.Text", + "foo :: Text", + "foo = \"hello\"" + ] diff --git a/ghcide/test/exe/DependentFileTest.hs b/ghcide/test/exe/DependentFileTest.hs new file mode 100644 --- /dev/null +++ b/ghcide/test/exe/DependentFileTest.hs @@ -0,0 +1,58 @@ + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} + +module DependentFileTest (tests) where + +import Control.Monad.IO.Class (liftIO) +import Data.Row +import qualified Data.Text as T +import Development.IDE.Test (expectDiagnostics) +import Development.IDE.Types.Location +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +import System.FilePath +import Test.Tasty +import TestUtils + +tests :: TestTree +tests = testGroup "addDependentFile" + [testGroup "file-changed" [testSession' "test" test] + ] + where + test dir = do + -- If the file contains B then no type error + -- otherwise type error + let depFilePath = dir "dep-file.txt" + liftIO $ writeFile depFilePath "A" + let fooContent = T.unlines + [ "{-# LANGUAGE TemplateHaskell #-}" + , "module Foo where" + , "import Language.Haskell.TH.Syntax" + , "foo :: Int" + , "foo = 1 + $(do" + , " qAddDependentFile \"dep-file.txt\"" + , " f <- qRunIO (readFile \"dep-file.txt\")" + , " if f == \"B\" then [| 1 |] else lift f)" + ] + let bazContent = T.unlines ["module Baz where", "import Foo ()"] + _ <- createDoc "Foo.hs" "haskell" fooContent + doc <- createDoc "Baz.hs" "haskell" bazContent + expectDiagnostics + [("Foo.hs", [(DiagnosticSeverity_Error, (4,11), "Couldn't match type")])] + -- Now modify the dependent file + liftIO $ writeFile depFilePath "B" + sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams + [FileEvent (filePathToUri "dep-file.txt") FileChangeType_Changed ] + + -- Modifying Baz will now trigger Foo to be rebuilt as well + let change = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 2 0) (Position 2 6) + .+ #rangeLength .== Nothing + .+ #text .== "f = ()" + changeDoc doc [change] + expectDiagnostics [("Foo.hs", [])] diff --git a/ghcide/test/exe/DiagnosticTests.hs b/ghcide/test/exe/DiagnosticTests.hs new file mode 100644 --- /dev/null +++ b/ghcide/test/exe/DiagnosticTests.hs @@ -0,0 +1,577 @@ + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} + +module DiagnosticTests (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 Data.Row +import qualified Data.Text as T +import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) +import Development.IDE.GHC.Util +import Development.IDE.Test (diagnostic, + expectCurrentDiagnostics, + expectDiagnostics, + expectDiagnosticsWithTags, + expectNoMoreDiagnostics, + flushMessages, waitForAction) +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.Directory +import System.FilePath +import System.IO.Extra hiding (withTempDir) + +import Control.Lens ((^.)) +import Control.Monad.Extra (whenJust) +import Development.IDE.Plugin.Test (WaitForIdeRuleResult (..)) +import System.Time.Extra +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + +tests :: TestTree +tests = testGroup "diagnostics" + [ testSessionWait "fix syntax error" $ do + let content = T.unlines [ "module Testing wher" ] + doc <- createDoc "Testing.hs" "haskell" content + expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "parse error")])] + let change = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 0 15) (Position 0 19) + .+ #rangeLength .== Nothing + .+ #text .== "where" + changeDoc doc [change] + expectDiagnostics [("Testing.hs", [])] + , testSessionWait "introduce syntax error" $ do + let content = T.unlines [ "module Testing where" ] + doc <- createDoc "Testing.hs" "haskell" content + void $ skipManyTill anyMessage (message SMethod_WindowWorkDoneProgressCreate) + waitForProgressBegin + let change = TextDocumentContentChangeEvent$ InL $ #range .== Range (Position 0 15) (Position 0 18) + .+ #rangeLength .== Nothing + .+ #text .== "wher" + changeDoc doc [change] + expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "parse error")])] + , testSessionWait "update syntax error" $ do + let content = T.unlines [ "module Testing(missing) where" ] + doc <- createDoc "Testing.hs" "haskell" content + expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "Not in scope: 'missing'")])] + let change = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 0 15) (Position 0 16) + .+ #rangeLength .== Nothing + .+ #text .== "l" + changeDoc doc [change] + expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "Not in scope: 'lissing'")])] + , testSessionWait "variable not in scope" $ do + let content = T.unlines + [ "module Testing where" + , "foo :: Int -> Int -> Int" + , "foo a _b = a + ab" + , "bar :: Int -> Int -> Int" + , "bar _a b = cd + b" + ] + _ <- createDoc "Testing.hs" "haskell" content + expectDiagnostics + [ ( "Testing.hs" + , [ (DiagnosticSeverity_Error, (2, 15), "Variable not in scope: ab") + , (DiagnosticSeverity_Error, (4, 11), "Variable not in scope: cd") + ] + ) + ] + , testSessionWait "type error" $ do + let content = T.unlines + [ "module Testing where" + , "foo :: Int -> String -> Int" + , "foo a b = a + b" + ] + _ <- createDoc "Testing.hs" "haskell" content + expectDiagnostics + [ ( "Testing.hs" + , [(DiagnosticSeverity_Error, (2, 14), "Couldn't match type '[Char]' with 'Int'")] + ) + ] + , testSessionWait "typed hole" $ do + let content = T.unlines + [ "module Testing where" + , "foo :: Int -> String" + , "foo a = _ a" + ] + _ <- createDoc "Testing.hs" "haskell" content + expectDiagnostics + [ ( "Testing.hs" + , [(DiagnosticSeverity_Error, (2, 8), "Found hole: _ :: Int -> String")] + ) + ] + + , testGroup "deferral" $ + let sourceA a = T.unlines + [ "module A where" + , "a :: Int" + , "a = " <> a] + sourceB = T.unlines + [ "module B where" + , "import A ()" + , "b :: Float" + , "b = True"] + bMessage = "Couldn't match expected type 'Float' with actual type 'Bool'" + expectedDs aMessage = + [ ("A.hs", [(DiagnosticSeverity_Error, (2,4), aMessage)]) + , ("B.hs", [(DiagnosticSeverity_Error, (3,4), bMessage)])] + deferralTest title binding msg = testSessionWait title $ do + _ <- createDoc "A.hs" "haskell" $ sourceA binding + _ <- createDoc "B.hs" "haskell" sourceB + expectDiagnostics $ expectedDs msg + in + [ deferralTest "type error" "True" "Couldn't match expected type" + , deferralTest "typed hole" "_" "Found hole" + , deferralTest "out of scope var" "unbound" "Variable not in scope" + ] + + , testSessionWait "remove required module" $ do + let contentA = T.unlines [ "module ModuleA where" ] + docA <- createDoc "ModuleA.hs" "haskell" contentA + let contentB = T.unlines + [ "module ModuleB where" + , "import ModuleA" + ] + _ <- createDoc "ModuleB.hs" "haskell" contentB + let change = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 0 0) (Position 0 20) + .+ #rangeLength .== Nothing + .+ #text .== "" + changeDoc docA [change] + expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Error, (1, 0), "Could not find module")])] + , testSessionWait "add missing module" $ do + let contentB = T.unlines + [ "module ModuleB where" + , "import ModuleA ()" + ] + _ <- createDoc "ModuleB.hs" "haskell" contentB + expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Error, (1, 7), "Could not find module")])] + let contentA = T.unlines [ "module ModuleA where" ] + _ <- createDoc "ModuleA.hs" "haskell" contentA + expectDiagnostics [("ModuleB.hs", [])] + , testCase "add missing module (non workspace)" $ + -- By default lsp-test sends FileWatched notifications for all files, which we don't want + -- as non workspace modules will not be watched by the LSP server. + -- To work around this, we tell lsp-test that our client doesn't have the + -- FileWatched capability, which is enough to disable the notifications + withTempDir $ \tmpDir -> runInDir'' lspTestCapsNoFileWatches tmpDir "." "." [] $ do + let contentB = T.unlines + [ "module ModuleB where" + , "import ModuleA ()" + ] + _ <- createDoc (tmpDir "ModuleB.hs") "haskell" contentB + expectDiagnostics [(tmpDir "ModuleB.hs", [(DiagnosticSeverity_Error, (1, 7), "Could not find module")])] + let contentA = T.unlines [ "module ModuleA where" ] + _ <- createDoc (tmpDir "ModuleA.hs") "haskell" contentA + expectDiagnostics [(tmpDir "ModuleB.hs", [])] + , testSessionWait "cyclic module dependency" $ do + let contentA = T.unlines + [ "module ModuleA where" + , "import ModuleB" + ] + let contentB = T.unlines + [ "module ModuleB where" + , "import ModuleA" + ] + _ <- createDoc "ModuleA.hs" "haskell" contentA + _ <- createDoc "ModuleB.hs" "haskell" contentB + expectDiagnostics + [ ( "ModuleA.hs" + , [(DiagnosticSeverity_Error, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")] + ) + , ( "ModuleB.hs" + , [(DiagnosticSeverity_Error, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")] + ) + ] + , testSession' "deeply nested cyclic module dependency" $ \path -> do + let contentA = unlines + [ "module ModuleA where" , "import ModuleB" ] + let contentB = unlines + [ "module ModuleB where" , "import ModuleA" ] + let contentC = unlines + [ "module ModuleC where" , "import ModuleB" ] + let contentD = T.unlines + [ "module ModuleD where" , "import ModuleC" ] + cradle = + "cradle: {direct: {arguments: [ModuleA, ModuleB, ModuleC, ModuleD]}}" + liftIO $ writeFile (path "ModuleA.hs") contentA + liftIO $ writeFile (path "ModuleB.hs") contentB + liftIO $ writeFile (path "ModuleC.hs") contentC + liftIO $ writeFile (path "hie.yaml") cradle + _ <- createDoc "ModuleD.hs" "haskell" contentD + expectDiagnostics + [ ( "ModuleB.hs" + , [(DiagnosticSeverity_Error, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")] + ) + ] + , testSessionWait "cyclic module dependency with hs-boot" $ do + let contentA = T.unlines + [ "module ModuleA where" + , "import {-# SOURCE #-} ModuleB" + ] + let contentB = T.unlines + [ "{-# OPTIONS -Wmissing-signatures#-}" + , "module ModuleB where" + , "import ModuleA" + -- introduce an artificial diagnostic + , "foo = ()" + ] + let contentBboot = T.unlines + [ "module ModuleB where" + ] + _ <- createDoc "ModuleA.hs" "haskell" contentA + _ <- createDoc "ModuleB.hs" "haskell" contentB + _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot + expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Warning, (3,0), "Top-level binding")])] + , testSession' "bidirectional module dependency with hs-boot" $ \path -> do + let cradle = unlines + [ "cradle:" + , " direct: {arguments: [ModuleA, ModuleB]}" + ] + let contentA = T.unlines + [ "module ModuleA where" + , "import {-# SOURCE #-} ModuleB" + ] + let contentB = T.unlines + [ "{-# OPTIONS -Wmissing-signatures#-}" + , "module ModuleB where" + , "import {-# SOURCE #-} ModuleA" + -- introduce an artificial diagnostic + , "foo = ()" + ] + let contentBboot = T.unlines + [ "module ModuleB where" + ] + let contentAboot = T.unlines + [ "module ModuleA where" + ] + liftIO $ writeFile (path "hie.yaml") cradle + _ <- createDoc "ModuleA.hs" "haskell" contentA + _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot + _ <- createDoc "ModuleB.hs" "haskell" contentB + _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot + expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Warning, (3,0), "Top-level binding")])] + , testSessionWait "correct reference used with hs-boot" $ do + let contentB = T.unlines + [ "module ModuleB where" + , "import {-# SOURCE #-} ModuleA()" + ] + let contentA = T.unlines + [ "module ModuleA where" + , "import ModuleB()" + , "x = 5" + ] + let contentAboot = T.unlines + [ "module ModuleA where" + ] + let contentC = T.unlines + [ "{-# OPTIONS -Wmissing-signatures #-}" + , "module ModuleC where" + , "import ModuleA" + -- this reference will fail if it gets incorrectly + -- resolved to the hs-boot file + , "y = x" + ] + _ <- createDoc "ModuleB.hs" "haskell" contentB + _ <- createDoc "ModuleA.hs" "haskell" contentA + _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot + _ <- createDoc "ModuleC.hs" "haskell" contentC + expectDiagnostics [("ModuleC.hs", [(DiagnosticSeverity_Warning, (3,0), "Top-level binding")])] + , testSessionWait "redundant import" $ do + let contentA = T.unlines ["module ModuleA where"] + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wunused-imports #-}" + , "module ModuleB where" + , "import ModuleA" + ] + _ <- createDoc "ModuleA.hs" "haskell" contentA + _ <- createDoc "ModuleB.hs" "haskell" contentB + expectDiagnosticsWithTags + [ ( "ModuleB.hs" + , [(DiagnosticSeverity_Warning, (2, 0), "The import of 'ModuleA' is redundant", Just DiagnosticTag_Unnecessary)] + ) + ] + , testSessionWait "redundant import even without warning" $ do + let contentA = T.unlines ["module ModuleA where"] + let contentB = T.unlines + [ "{-# OPTIONS_GHC -Wno-unused-imports -Wmissing-signatures #-}" + , "module ModuleB where" + , "import ModuleA" + -- introduce an artificial warning for testing purposes + , "foo = ()" + ] + _ <- createDoc "ModuleA.hs" "haskell" contentA + _ <- createDoc "ModuleB.hs" "haskell" contentB + expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Warning, (3,0), "Top-level binding")])] + , testSessionWait "package imports" $ do + let thisDataListContent = T.unlines + [ "module Data.List where" + , "x :: Integer" + , "x = 123" + ] + let mainContent = T.unlines + [ "{-# LANGUAGE PackageImports #-}" + , "module Main where" + , "import qualified \"this\" Data.List as ThisList" + , "import qualified \"base\" Data.List as BaseList" + , "useThis = ThisList.x" + , "useBase = BaseList.map" + , "wrong1 = ThisList.map" + , "wrong2 = BaseList.x" + , "main = pure ()" + ] + _ <- createDoc "Data/List.hs" "haskell" thisDataListContent + _ <- createDoc "Main.hs" "haskell" mainContent + expectDiagnostics + [ ( "Main.hs" + , [(DiagnosticSeverity_Error, (6, 9), + if ghcVersion >= GHC96 then + "Variable not in scope: ThisList.map" + else if ghcVersion >= GHC94 then + "Variable not in scope: map" -- See https://gitlab.haskell.org/ghc/ghc/-/issues/22130 + else + "Not in scope: \8216ThisList.map\8217") + ,(DiagnosticSeverity_Error, (7, 9), + if ghcVersion >= GHC96 then + "Variable not in scope: BaseList.x" + else if ghcVersion >= GHC94 then + "Variable not in scope: x" -- See https://gitlab.haskell.org/ghc/ghc/-/issues/22130 + else + "Not in scope: \8216BaseList.x\8217") + ] + ) + ] + , testSessionWait "unqualified warnings" $ do + let fooContent = T.unlines + [ "{-# OPTIONS_GHC -Wredundant-constraints #-}" + , "module Foo where" + , "foo :: Ord a => a -> Int" + , "foo _a = 1" + ] + _ <- createDoc "Foo.hs" "haskell" fooContent + expectDiagnostics + [ ( "Foo.hs" + -- The test is to make sure that warnings contain unqualified names + -- where appropriate. The warning should use an unqualified name 'Ord', not + -- something like 'GHC.Classes.Ord'. The choice of redundant-constraints to + -- test this is fairly arbitrary. + , [(DiagnosticSeverity_Warning, (2, if ghcVersion >= GHC94 then 7 else 0), "Redundant constraint: Ord a") + ] + ) + ] + , testSessionWait "lower-case drive" $ do + let aContent = T.unlines + [ "module A.A where" + , "import A.B ()" + ] + bContent = T.unlines + [ "{-# OPTIONS_GHC -Wall #-}" + , "module A.B where" + , "import Data.List" + ] + uriB <- getDocUri "A/B.hs" + Just pathB <- pure $ uriToFilePath uriB + uriB <- pure $ + let (drive, suffix) = splitDrive pathB + in filePathToUri (joinDrive (lower drive) suffix) + liftIO $ createDirectoryIfMissing True (takeDirectory pathB) + liftIO $ writeFileUTF8 pathB $ T.unpack bContent + uriA <- getDocUri "A/A.hs" + Just pathA <- pure $ uriToFilePath uriA + uriA <- pure $ + let (drive, suffix) = splitDrive pathA + in filePathToUri (joinDrive (lower drive) suffix) + let itemA = TextDocumentItem uriA "haskell" 0 aContent + let a = TextDocumentIdentifier uriA + sendNotification SMethod_TextDocumentDidOpen (DidOpenTextDocumentParams itemA) + TNotificationMessage{_params = PublishDiagnosticsParams fileUri _ diags} <- skipManyTill anyMessage diagnostic + -- Check that if we put a lower-case drive in for A.A + -- the diagnostics for A.B will also be lower-case. + liftIO $ fileUri @?= uriB + let msg :: T.Text = (head diags) ^. L.message + liftIO $ unless ("redundant" `T.isInfixOf` msg) $ + assertFailure ("Expected redundant import but got " <> T.unpack msg) + closeDoc a + , testSessionWait "strip file path" $ do + let + name = "Testing" + content = T.unlines + [ "module " <> name <> " where" + , "value :: Maybe ()" + , "value = [()]" + ] + _ <- createDoc (T.unpack name <> ".hs") "haskell" content + notification <- skipManyTill anyMessage diagnostic + let + offenders = + L.params . + L.diagnostics . + Lens.folded . + L.message . + Lens.filtered (T.isInfixOf ("/" <> name <> ".hs:")) + failure msg = liftIO $ assertFailure $ "Expected file path to be stripped but got " <> T.unpack msg + Lens.mapMOf_ offenders failure notification + , testSession' "-Werror in cradle is ignored" $ \sessionDir -> do + liftIO $ writeFile (sessionDir "hie.yaml") + "cradle: {direct: {arguments: [\"-Wall\", \"-Werror\"]}}" + let fooContent = T.unlines + [ "module Foo where" + , "foo = ()" + ] + _ <- createDoc "Foo.hs" "haskell" fooContent + expectDiagnostics + [ ( "Foo.hs" + , [(DiagnosticSeverity_Warning, (1, 0), "Top-level binding with no type signature:") + ] + ) + ] + , testSessionWait "-Werror in pragma is ignored" $ do + let fooContent = T.unlines + [ "{-# OPTIONS_GHC -Wall -Werror #-}" + , "module Foo() where" + , "foo :: Int" + , "foo = 1" + ] + _ <- createDoc "Foo.hs" "haskell" fooContent + expectDiagnostics + [ ( "Foo.hs" + , [(DiagnosticSeverity_Warning, (3, 0), "Defined but not used:") + ] + ) + ] + , testCase "typecheck-all-parents-of-interest" $ runWithExtraFiles "recomp" $ \dir -> do + let bPath = dir "B.hs" + pPath = dir "P.hs" + aPath = dir "A.hs" + + bSource <- liftIO $ readFileUtf8 bPath -- y :: Int + pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int + aSource <- liftIO $ readFileUtf8 aPath -- x = y :: Int + + bdoc <- createDoc bPath "haskell" bSource + _pdoc <- createDoc pPath "haskell" pSource + expectDiagnostics + [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")])] -- So that we know P has been loaded + + -- Change y from Int to B which introduces a type error in A (imported from P) + changeDoc bdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ + T.unlines ["module B where", "y :: Bool", "y = undefined"]] + expectDiagnostics + [("A.hs", [(DiagnosticSeverity_Error, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")]) + ] + + -- Open A and edit to fix the type error + adoc <- createDoc aPath "haskell" aSource + changeDoc adoc [TextDocumentContentChangeEvent . InR . (.==) #text $ + T.unlines ["module A where", "import B", "x :: Bool", "x = y"]] + + expectDiagnostics + [ ( "P.hs", + [ (DiagnosticSeverity_Error, (4, 6), "Couldn't match expected type 'Int' with actual type 'Bool'"), + (DiagnosticSeverity_Warning, (4, 0), "Top-level binding") + ] + ), + ("A.hs", []) + ] + expectNoMoreDiagnostics 1 + + , testSessionWait "deduplicate missing module diagnostics" $ do + let fooContent = T.unlines [ "module Foo() where" , "import MissingModule" ] + doc <- createDoc "Foo.hs" "haskell" fooContent + expectDiagnostics [("Foo.hs", [(DiagnosticSeverity_Error, (1,7), "Could not find module 'MissingModule'")])] + + changeDoc doc [TextDocumentContentChangeEvent . InR . (.==) #text $ "module Foo() where" ] + expectDiagnostics [] + + changeDoc doc [TextDocumentContentChangeEvent . InR . (.==) #text $ T.unlines + [ "module Foo() where" , "import MissingModule" ] ] + expectDiagnostics [("Foo.hs", [(DiagnosticSeverity_Error, (1,7), "Could not find module 'MissingModule'")])] + + , testGroup "Cancellation" + [ cancellationTestGroup "edit header" editHeader yesSession noParse noTc + , cancellationTestGroup "edit import" editImport noSession yesParse noTc + , cancellationTestGroup "edit body" editBody yesSession yesParse yesTc + ] + ] + where + editPair x y = let p = Position x y ; p' = Position x (y+2) in + (TextDocumentContentChangeEvent $ InL $ #range .== Range p p + .+ #rangeLength .== Nothing + .+ #text .== "fd" + ,TextDocumentContentChangeEvent $ InL $ #range .== Range p p' + .+ #rangeLength .== Nothing + .+ #text .== "") + editHeader = editPair 0 0 + editImport = editPair 2 10 + editBody = editPair 3 10 + + noParse = False + yesParse = True + + noSession = False + yesSession = True + + noTc = False + yesTc = True + +cancellationTestGroup :: TestName -> (TextDocumentContentChangeEvent, TextDocumentContentChangeEvent) -> Bool -> Bool -> Bool -> TestTree +cancellationTestGroup name edits sessionDepsOutcome parseOutcome tcOutcome = testGroup name + [ cancellationTemplate edits Nothing + , cancellationTemplate edits $ Just ("GetFileContents", True) + , cancellationTemplate edits $ Just ("GhcSession", True) + -- the outcome for GetModSummary is always True because parseModuleHeader never fails (!) + , cancellationTemplate edits $ Just ("GetModSummary", True) + , cancellationTemplate edits $ Just ("GetModSummaryWithoutTimestamps", True) + -- getLocatedImports never fails + , cancellationTemplate edits $ Just ("GetLocatedImports", True) + , cancellationTemplate edits $ Just ("GhcSessionDeps", sessionDepsOutcome) + , cancellationTemplate edits $ Just ("GetParsedModule", parseOutcome) + , cancellationTemplate edits $ Just ("TypeCheck", tcOutcome) + , cancellationTemplate edits $ Just ("GetHieAst", tcOutcome) + ] + +cancellationTemplate :: (TextDocumentContentChangeEvent, TextDocumentContentChangeEvent) -> Maybe (String, Bool) -> TestTree +cancellationTemplate (edit, undoEdit) mbKey = testCase (maybe "-" fst mbKey) $ runTestNoKick $ do + doc <- createDoc "Foo.hs" "haskell" $ T.unlines + [ "{-# OPTIONS_GHC -Wall #-}" + , "module Foo where" + , "import Data.List()" + , "f0 x = (x,x)" + ] + + -- for the example above we expect one warning + let missingSigDiags = [(DiagnosticSeverity_Warning, (3, 0), "Top-level binding") ] + typeCheck doc >> expectCurrentDiagnostics doc missingSigDiags + + -- Now we edit the document and wait for the given key (if any) + changeDoc doc [edit] + whenJust mbKey $ \(key, expectedResult) -> do + WaitForIdeRuleResult{ideResultSuccess} <- waitForAction key doc + liftIO $ ideResultSuccess @?= expectedResult + + -- The 2nd edit cancels the active session and unbreaks the file + -- wait for typecheck and check that the current diagnostics are accurate + changeDoc doc [undoEdit] + typeCheck doc >> expectCurrentDiagnostics doc missingSigDiags + + expectNoMoreDiagnostics 0.5 + where + -- similar to run except it disables kick + runTestNoKick s = withTempDir $ \dir -> runInDir' dir "." "." ["--test-no-kick"] s + + typeCheck doc = do + WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc + liftIO $ assertBool "The file should typecheck" ideResultSuccess + -- wait for the debouncer to publish diagnostics if the rule runs + liftIO $ sleep 0.2 + -- flush messages to ensure current diagnostics state is updated + flushMessages diff --git a/ghcide/test/exe/ExceptionTests.hs b/ghcide/test/exe/ExceptionTests.hs new file mode 100644 --- /dev/null +++ b/ghcide/test/exe/ExceptionTests.hs @@ -0,0 +1,156 @@ + +module ExceptionTests (tests) where + +import Control.Exception (ArithException (DivideByZero), + throwIO) +import Control.Lens +import Control.Monad.Error.Class (MonadError (throwError)) +import Control.Monad.IO.Class (liftIO) +import qualified Data.Aeson as A +import Data.Text as T +import Development.IDE.Core.Shake (IdeState (..)) +import qualified Development.IDE.LSP.Notifications as Notifications +import qualified Development.IDE.Main as IDE +import Development.IDE.Plugin.HLS (toResponseError) +import Development.IDE.Plugin.Test as Test +import Development.IDE.Types.Options +import GHC.Base (coerce) +import Ide.Logger (Recorder, WithPriority, + cmapWithPrio) +import Ide.Plugin.Error +import Ide.Plugin.HandleRequestTypes (RejectionReason (DisabledGlobally)) +import Ide.PluginUtils (idePluginsToPluginDesc, + pluginDescToIdePlugins) +import Ide.Types +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 LogType (Log (..)) +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + +tests :: Recorder (WithPriority Log) -> TestTree +tests recorder = do + testGroup "Exceptions and PluginError" [ + testGroup "Testing that IO Exceptions are caught in..." + [ testCase "PluginHandlers" $ do + let pluginId = "plugin-handler-exception" + plugins = pluginDescToIdePlugins $ + [ (defaultPluginDescriptor pluginId "") + { pluginHandlers = mconcat + [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do + _ <- liftIO $ throwIO DivideByZero + pure (InL []) + ] + }] + testIde recorder (testingLite recorder plugins) $ do + doc <- createDoc "A.hs" "haskell" "module A where" + waitForProgressDone + (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) + case lens of + Left (ResponseError {_code = InR ErrorCodes_InternalError, _message}) -> + liftIO $ assertBool "We caught an error, but it wasn't ours!" + (T.isInfixOf "divide by zero" _message && T.isInfixOf (coerce pluginId) _message) + _ -> liftIO $ assertFailure $ show lens + + , testCase "Commands" $ do + let pluginId = "command-exception" + commandId = CommandId "exception" + plugins = pluginDescToIdePlugins $ + [ (defaultPluginDescriptor pluginId "") + { pluginCommands = + [ PluginCommand commandId "Causes an exception" $ \_ _ (_::Int) -> do + _ <- liftIO $ throwIO DivideByZero + pure (InR Null) + ] + }] + testIde recorder (testingLite recorder plugins) $ do + _ <- createDoc "A.hs" "haskell" "module A where" + waitForProgressDone + let cmd = mkLspCommand (coerce pluginId) commandId "" (Just [A.toJSON (1::Int)]) + execParams = ExecuteCommandParams Nothing (cmd ^. L.command) (cmd ^. L.arguments) + (view L.result -> res) <- request SMethod_WorkspaceExecuteCommand execParams + case res of + Left (ResponseError {_code = InR ErrorCodes_InternalError, _message}) -> + liftIO $ assertBool "We caught an error, but it wasn't ours!" + (T.isInfixOf "divide by zero" _message && T.isInfixOf (coerce pluginId) _message) + _ -> liftIO $ assertFailure $ show res + + , testCase "Notification Handlers" $ do + let pluginId = "notification-exception" + plugins = pluginDescToIdePlugins $ + [ (defaultPluginDescriptor pluginId "") + { pluginNotificationHandlers = mconcat + [ mkPluginNotificationHandler SMethod_TextDocumentDidOpen $ \_ _ _ _ -> + liftIO $ throwIO DivideByZero + ] + , pluginHandlers = mconcat + [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do + pure (InL []) + ] + }] + testIde recorder (testingLite recorder plugins) $ do + doc <- createDoc "A.hs" "haskell" "module A where" + waitForProgressDone + (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) + case lens of + Right (InL []) -> + -- We don't get error responses from notification handlers, so + -- we can only make sure that the server is still responding + pure () + _ -> liftIO $ assertFailure $ "We should have had an empty list" <> show lens] + + , testGroup "Testing PluginError order..." + [ pluginOrderTestCase recorder "InternalError over InvalidParams" (PluginInternalError "error test") (PluginInvalidParams "error test") + , pluginOrderTestCase recorder "InvalidParams over InvalidUserState" (PluginInvalidParams "error test") (PluginInvalidUserState "error test") + , pluginOrderTestCase recorder "InvalidUserState over RequestRefused" (PluginInvalidUserState "error test") (PluginRequestRefused DisabledGlobally) + ] + ] + +testingLite :: Recorder (WithPriority Log) -> IdePlugins IdeState -> IDE.Arguments +testingLite recorder plugins = + let + arguments@IDE.Arguments{ argsIdeOptions } = + IDE.defaultArguments (cmapWithPrio LogIDEMain recorder) plugins + hlsPlugins = pluginDescToIdePlugins $ + idePluginsToPluginDesc plugins + ++ [Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core"] + ++ [Test.blockCommandDescriptor "block-command", Test.plugin] + ideOptions config sessionLoader = + let + defOptions = argsIdeOptions config sessionLoader + in + defOptions{ optTesting = IdeTesting True } + in + arguments + { IDE.argsHlsPlugins = hlsPlugins + , IDE.argsIdeOptions = ideOptions + } + +pluginOrderTestCase :: Recorder (WithPriority Log) -> TestName -> PluginError -> PluginError -> TestTree +pluginOrderTestCase recorder msg err1 err2 = + testCase msg $ do + let pluginId = "error-order-test" + plugins = pluginDescToIdePlugins $ + [ (defaultPluginDescriptor pluginId "") + { pluginHandlers = mconcat + [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do + throwError err1 + ,mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do + throwError err2 + ] + }] + testIde recorder (testingLite recorder plugins) $ do + doc <- createDoc "A.hs" "haskell" "module A where" + waitForProgressDone + (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) + case lens of + Left re | toResponseError (pluginId, err1) == re -> pure () + | otherwise -> liftIO $ assertFailure "We caught an error, but it wasn't ours!" + _ -> liftIO $ assertFailure $ show lens diff --git a/ghcide/test/exe/FindDefinitionAndHoverTests.hs b/ghcide/test/exe/FindDefinitionAndHoverTests.hs new file mode 100644 --- /dev/null +++ b/ghcide/test/exe/FindDefinitionAndHoverTests.hs @@ -0,0 +1,235 @@ + +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.GHC.Util +import Development.IDE.Test (expectDiagnostics, + standardizeQuotes) +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.FilePath +import System.Info.Extra (isWindows) + +import Control.Lens ((^.)) +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils +import Text.Regex.TDFA ((=~)) + +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 = testSessionWithExtraFiles "hover" title $ \dir -> do + + -- Dirty the cache to check that definitions work even in the presence of iface files + liftIO $ runInDir dir $ do + let fooPath = dir "Foo.hs" + fooSource <- liftIO $ readFileUtf8 fooPath + fooDoc <- createDoc fooPath "haskell" fooSource + _ <- getHover fooDoc $ Position 4 3 + closeDoc fooDoc + + doc <- openTestDataDoc (dir sfp) + waitForProgressDone + found <- get doc pos + check found targetRange + + + + checkHover :: Maybe Hover -> Session [Expect] -> Session () + checkHover hover expectations = traverse_ check =<< expectations where + + 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 runDef runHover look expect = testM runDef runHover look (return expect) + + 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 = + testSessionWithExtraFiles "hover" ("Does " ++ fp ++ " compile") $ \dir -> do + void (openTestDataDoc (dir fp)) + diag diff --git a/ghcide/test/exe/FuzzySearch.hs b/ghcide/test/exe/FuzzySearch.hs new file mode 100644 --- /dev/null +++ b/ghcide/test/exe/FuzzySearch.hs @@ -0,0 +1,129 @@ +module FuzzySearch (tests) where + +import Data.Char (toLower) +import Data.Maybe (catMaybes) +import qualified Data.Monoid.Textual as T +import Data.Text (Text, inits, pack) +import qualified Data.Text as Text +import Prelude hiding (filter) +import System.Directory (doesFileExist) +import System.IO.Unsafe (unsafePerformIO) +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.ExpectedFailure +import Test.Tasty.QuickCheck (testProperty) +import qualified Text.Fuzzy as Fuzzy +import Text.Fuzzy (Fuzzy (..)) +import Text.Fuzzy.Parallel + +tests :: TestTree +tests = + testGroup + "Fuzzy search" + [ needDictionary $ + testGroup + "match works as expected on the english dictionary" + [ testProperty "for legit words" propLegit, + testProperty "for prefixes" propPrefix, + testProperty "for typos" propTypo + ] + ] + +test :: Text -> Bool +test candidate = do + let previous = + catMaybes + [ (d,) . Fuzzy.score + <$> referenceImplementation candidate d "" "" id + | d <- dictionary + ] + new = catMaybes [(d,) <$> match candidate d | d <- dictionary] + previous == new + +propLegit :: Property +propLegit = forAll (elements dictionary) test + +propPrefix :: Property +propPrefix = forAll (elements dictionary >>= elements . inits) test + +propTypo :: Property +propTypo = forAll typoGen test + +typoGen :: Gen Text +typoGen = do + w <- elements dictionary + l <- elements [0 .. Text.length w -1] + let wl = Text.index w l + c <- elements [ c | c <- ['a' .. 'z'], c /= wl] + return $ replaceAt w l c + +replaceAt :: Text -> Int -> Char -> Text +replaceAt t i c = + let (l, r) = Text.splitAt i t + in l <> Text.singleton c <> r + +dictionaryPath :: FilePath +dictionaryPath = "/usr/share/dict/words" + +{-# NOINLINE dictionary #-} +dictionary :: [Text] +dictionary = unsafePerformIO $ do + existsDictionary <- doesFileExist dictionaryPath + if existsDictionary + then map pack . words <$> readFile dictionaryPath + else pure [] + +referenceImplementation :: + (T.TextualMonoid s) => + -- | Pattern in lowercase except for first character + s -> + -- | The value containing the text to search in. + t -> + -- | The text to add before each match. + s -> + -- | The text to add after each match. + s -> + -- | The function to extract the text from the container. + (t -> s) -> + -- | The original value, rendered string and score. + Maybe (Fuzzy t s) +referenceImplementation pattern t pre post extract = + if null pat then Just (Fuzzy t result totalScore) else Nothing + where + null :: (T.TextualMonoid s) => s -> Bool + null = not . T.any (const True) + + s = extract t + (totalScore, _currScore, result, pat, _) = + T.foldl' + undefined + ( \(tot, cur, res, pat, isFirst) c -> + case T.splitCharacterPrefix pat of + Nothing -> (tot, 0, res <> T.singleton c, pat, isFirst) + Just (x, xs) -> + -- the case of the first character has to match + -- otherwise use lower case since the pattern is assumed lower + let !c' = if isFirst then c else toLower c + in if x == c' + then + let cur' = cur * 2 + 1 + in ( tot + cur', + cur', + res <> pre <> T.singleton c <> post, + xs, + False + ) + else (tot, 0, res <> T.singleton c, pat, isFirst) + ) + ( 0, + 1, -- matching at the start gives a bonus (cur = 1) + mempty, + pattern, + True + ) + s + +needDictionary :: TestTree -> TestTree +needDictionary + | null dictionary = ignoreTestBecause ("not found: " <> dictionaryPath) + | otherwise = id diff --git a/ghcide/test/exe/GarbageCollectionTests.hs b/ghcide/test/exe/GarbageCollectionTests.hs new file mode 100644 --- /dev/null +++ b/ghcide/test/exe/GarbageCollectionTests.hs @@ -0,0 +1,94 @@ + +{-# LANGUAGE OverloadedLabels #-} + +module GarbageCollectionTests (tests) where + +import Control.Monad.IO.Class (liftIO) +import Data.Row +import qualified Data.Set as Set +import qualified Data.Text as T +import Development.IDE.Test (expectCurrentDiagnostics, + getStoredKeys, waitForGC, + waitForTypecheck) +import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), mkRange) +import Language.LSP.Test +import System.FilePath +-- import Test.QuickCheck.Instances () +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils +import Text.Printf (printf) + +tests :: TestTree +tests = testGroup "garbage collection" + [ testGroup "dirty keys" + [ testSession' "are collected" $ \dir -> do + liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" + doc <- generateGarbage "A" dir + closeDoc doc + garbage <- waitForGC + liftIO $ assertBool "no garbage was found" $ not $ null garbage + + , testSession' "are deleted from the state" $ \dir -> do + liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" + docA <- generateGarbage "A" dir + keys0 <- getStoredKeys + closeDoc docA + garbage <- waitForGC + liftIO $ assertBool "something is wrong with this test - no garbage found" $ not $ null garbage + keys1 <- getStoredKeys + liftIO $ assertBool "keys were not deleted from the state" (length keys1 < length keys0) + + , testSession' "are not regenerated unless needed" $ \dir -> do + liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A.hs, B.hs]}}" + docA <- generateGarbage "A" dir + _docB <- generateGarbage "B" dir + + -- garbage collect A keys + keysBeforeGC <- getStoredKeys + closeDoc docA + garbage <- waitForGC + liftIO $ assertBool "something is wrong with this test - no garbage found" $ not $ null garbage + keysAfterGC <- getStoredKeys + liftIO $ assertBool "something is wrong with this test - keys were not deleted from the state" + (length keysAfterGC < length keysBeforeGC) + + -- re-typecheck B and check that the keys for A have not materialized back + _docB <- generateGarbage "B" dir + keysB <- getStoredKeys + let regeneratedKeys = Set.filter (not . isExpected) $ + Set.intersection (Set.fromList garbage) (Set.fromList keysB) + liftIO $ regeneratedKeys @?= mempty + + , testSession' "regenerate successfully" $ \dir -> do + liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" + docA <- generateGarbage "A" dir + closeDoc docA + garbage <- waitForGC + liftIO $ assertBool "no garbage was found" $ not $ null garbage + let edit = T.unlines + [ "module A where" + , "a :: Bool" + , "a = ()" + ] + doc <- generateGarbage "A" dir + changeDoc doc [TextDocumentContentChangeEvent . InR . (.==) #text $ edit] + builds <- waitForTypecheck doc + liftIO $ assertBool "it still builds" builds + expectCurrentDiagnostics doc [(DiagnosticSeverity_Error, (2,4), "Couldn't match expected type")] + ] + ] + where + isExpected k = any (`T.isPrefixOf` k) ["GhcSessionIO"] + + generateGarbage :: String -> FilePath -> Session TextDocumentIdentifier + generateGarbage modName dir = do + let fp = modName <> ".hs" + body = printf "module %s where" modName + doc <- createDoc fp "haskell" (T.pack body) + liftIO $ writeFile (dir fp) body + builds <- waitForTypecheck doc + liftIO $ assertBool "something is wrong with this test" builds + return doc diff --git a/ghcide/test/exe/HaddockTests.hs b/ghcide/test/exe/HaddockTests.hs new file mode 100644 --- /dev/null +++ b/ghcide/test/exe/HaddockTests.hs @@ -0,0 +1,90 @@ + +module HaddockTests (tests) where + +import Development.IDE.Spans.Common +-- import Test.QuickCheck.Instances () +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests + = testGroup "haddock" + [ testCase "Num" $ checkHaddock + (unlines + [ "However, '(+)' and '(*)' are" + , "customarily expected to define a ring and have the following properties:" + , "" + , "[__Associativity of (+)__]: @(x + y) + z@ = @x + (y + z)@" + , "[__Commutativity of (+)__]: @x + y@ = @y + x@" + , "[__@fromInteger 0@ is the additive identity__]: @x + fromInteger 0@ = @x@" + ] + ) + (unlines + [ "" + , "" + , "However, `(+)` and `(*)` are" + , "customarily expected to define a ring and have the following properties: " + , "+ ****Associativity of (+)****: `(x + y) + z` = `x + (y + z)`" + , "+ ****Commutativity of (+)****: `x + y` = `y + x`" + , "+ ****`fromInteger 0` is the additive identity****: `x + fromInteger 0` = `x`" + ] + ) + , testCase "unsafePerformIO" $ checkHaddock + (unlines + [ "may require" + , "different precautions:" + , "" + , " * Use @{\\-\\# NOINLINE foo \\#-\\}@ as a pragma on any function @foo@" + , " that calls 'unsafePerformIO'. If the call is inlined," + , " the I\\/O may be performed more than once." + , "" + , " * Use the compiler flag @-fno-cse@ to prevent common sub-expression" + , " elimination being performed on the module." + , "" + ] + ) + (unlines + [ "" + , "" + , "may require" + , "different precautions: " + , "+ Use `{-# NOINLINE foo #-}` as a pragma on any function `foo` " + , " that calls `unsafePerformIO` . If the call is inlined," + , " the I/O may be performed more than once." + , "" + , "+ Use the compiler flag `-fno-cse` to prevent common sub-expression" + , " elimination being performed on the module." + , "" + ] + ) + , testCase "ordered list" $ checkHaddock + (unlines + [ "may require" + , "different precautions:" + , "" + , " 1. Use @{\\-\\# NOINLINE foo \\#-\\}@ as a pragma on any function @foo@" + , " that calls 'unsafePerformIO'. If the call is inlined," + , " the I\\/O may be performed more than once." + , "" + , " 2. Use the compiler flag @-fno-cse@ to prevent common sub-expression" + , " elimination being performed on the module." + , "" + ] + ) + (unlines + [ "" + , "" + , "may require" + , "different precautions: " + , "1. Use `{-# NOINLINE foo #-}` as a pragma on any function `foo` " + , " that calls `unsafePerformIO` . If the call is inlined," + , " the I/O may be performed more than once." + , "" + , "2. Use the compiler flag `-fno-cse` to prevent common sub-expression" + , " elimination being performed on the module." + , "" + ] + ) + ] + where + checkHaddock s txt = spanDocToMarkdownForTest s @?= txt diff --git a/ghcide/test/exe/HieDbRetry.hs b/ghcide/test/exe/HieDbRetry.hs new file mode 100644 --- /dev/null +++ b/ghcide/test/exe/HieDbRetry.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE MultiWayIf #-} +module HieDbRetry (tests) where + +import Control.Concurrent.Extra (Var, modifyVar, newVar, readVar, + withVar) +import Control.Exception (ErrorCall (ErrorCall), evaluate, + throwIO, tryJust) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Tuple.Extra (dupe) +import qualified Database.SQLite.Simple as SQLite +import Development.IDE.Session (retryOnException, retryOnSqliteBusy) +import qualified Development.IDE.Session as Session +import Ide.Logger (Recorder (Recorder, logger_), + WithPriority (WithPriority, payload), + cmapWithPrio) +import qualified System.Random as Random +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) + +data Log + = LogSession Session.Log + deriving Show + +makeLogger :: Var [Log] -> Recorder (WithPriority Log) +makeLogger msgsVar = + Recorder { + logger_ = \WithPriority{ payload = msg } -> liftIO $ modifyVar msgsVar (\msgs -> pure (msg : msgs, ())) + } + +rng :: Random.StdGen +rng = Random.mkStdGen 0 + +retryOnSqliteBusyForTest :: Recorder (WithPriority Log) -> Int -> IO a -> IO a +retryOnSqliteBusyForTest recorder maxRetryCount = retryOnException isErrorBusy (cmapWithPrio LogSession recorder) 1 1 maxRetryCount rng + +isErrorBusy :: SQLite.SQLError -> Maybe SQLite.SQLError +isErrorBusy e + | SQLite.SQLError { sqlError = SQLite.ErrorBusy } <- e = Just e + | otherwise = Nothing + +errorBusy :: SQLite.SQLError +errorBusy = SQLite.SQLError{ sqlError = SQLite.ErrorBusy, sqlErrorDetails = "", sqlErrorContext = "" } + +isErrorCall :: ErrorCall -> Maybe ErrorCall +isErrorCall e + | ErrorCall _ <- e = Just e + +tests :: TestTree +tests = testGroup "RetryHieDb" + [ testCase "retryOnException throws exception after max retries" $ do + logMsgsVar <- newVar [] + let logger = makeLogger logMsgsVar + let maxRetryCount = 1 + + result <- tryJust isErrorBusy (retryOnSqliteBusyForTest logger maxRetryCount (throwIO errorBusy)) + + case result of + Left exception -> do + exception @?= errorBusy + withVar logMsgsVar $ \logMsgs -> + length logMsgs @?= 2 + -- uncomment if want to compare log msgs + -- logMsgs @?= [] + Right _ -> assertFailure "Expected ErrorBusy exception" + + , testCase "retryOnException doesn't throw if given function doesn't throw" $ do + let expected = 1 :: Int + let maxRetryCount = 0 + + actual <- retryOnSqliteBusyForTest mempty maxRetryCount (pure expected) + + actual @?= expected + + , testCase "retryOnException retries the number of times it should" $ do + countVar <- newVar 0 + let maxRetryCount = 3 + let incrementThenThrow = modifyVar countVar (\count -> pure (dupe (count + 1))) >> throwIO errorBusy + + _ <- tryJust isErrorBusy (retryOnSqliteBusyForTest mempty maxRetryCount incrementThenThrow) + + withVar countVar $ \count -> + count @?= maxRetryCount + 1 + + , testCase "retryOnException doesn't retry if exception is not ErrorBusy" $ do + countVar <- newVar (0 :: Int) + let maxRetryCount = 1 + + let throwThenIncrement = do + count <- readVar countVar + if count == 0 then + evaluate (error "dummy exception") + else + modifyVar countVar (\count -> pure (dupe (count + 1))) + + + _ <- tryJust isErrorCall (retryOnSqliteBusyForTest mempty maxRetryCount throwThenIncrement) + + withVar countVar $ \count -> + count @?= 0 + + , testCase "retryOnSqliteBusy retries on ErrorBusy" $ do + countVar <- newVar (0 :: Int) + + let incrementThenThrowThenIncrement = do + count <- readVar countVar + if count == 0 then + modifyVar countVar (\count -> pure (dupe (count + 1))) >> throwIO errorBusy + else + modifyVar countVar (\count -> pure (dupe (count + 1))) + + _ <- retryOnSqliteBusy mempty rng incrementThenThrowThenIncrement + + withVar countVar $ \count -> + count @?= 2 + + , testCase "retryOnException exponentially backs off" $ do + logMsgsVar <- newVar ([] :: [Log]) + + let maxDelay = 100 + let baseDelay = 1 + let maxRetryCount = 6 + let logger = makeLogger logMsgsVar + + result <- tryJust isErrorBusy (retryOnException isErrorBusy (cmapWithPrio LogSession logger) maxDelay baseDelay maxRetryCount rng (throwIO errorBusy)) + + case result of + Left _ -> do + withVar logMsgsVar $ \logMsgs -> + -- uses log messages to check backoff... + if | (LogSession (Session.LogHieDbRetriesExhausted baseDelay maximumDelay maxRetryCount _) : _) <- logMsgs -> do + baseDelay @?= 64 + maximumDelay @?= 100 + maxRetryCount @?= 0 + | otherwise -> assertFailure "Expected more than 0 log messages" + Right _ -> assertFailure "Expected ErrorBusy exception" + ] diff --git a/ghcide/test/exe/HighlightTests.hs b/ghcide/test/exe/HighlightTests.hs new file mode 100644 --- /dev/null +++ b/ghcide/test/exe/HighlightTests.hs @@ -0,0 +1,79 @@ + +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.Tasty +import Test.Tasty.HUnit +import TestUtils + +tests :: TestTree +tests = testGroup "highlight" + [ testSessionWait "value" $ do + doc <- createDoc "A.hs" "haskell" source + _ <- 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" $ do + doc <- createDoc "A.hs" "haskell" source + _ <- 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" $ do + doc <- createDoc "A.hs" "haskell" source + _ <- 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" $ do + doc <- createDoc "A.hs" "haskell" recsource + _ <- 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" + ] diff --git a/ghcide/test/exe/IfaceTests.hs b/ghcide/test/exe/IfaceTests.hs new file mode 100644 --- /dev/null +++ b/ghcide/test/exe/IfaceTests.hs @@ -0,0 +1,163 @@ + +{-# LANGUAGE OverloadedLabels #-} + +module IfaceTests (tests) where + +import Control.Monad.IO.Class (liftIO) +import Data.Row +import qualified Data.Text as T +import Development.IDE.GHC.Util +import Development.IDE.Test (configureCheckProject, + expectDiagnostics, + expectNoMoreDiagnostics, + getInterfaceFilesDir) +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +import System.Directory +import System.FilePath +import System.IO.Extra hiding (withTempDir) +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + +tests :: TestTree +tests = testGroup "Interface loading tests" + [ -- https://github.com/haskell/ghcide/pull/645/ + ifaceErrorTest + , ifaceErrorTest2 + , ifaceErrorTest3 + , ifaceTHTest + ] + + +-- | test that TH reevaluates across interfaces +ifaceTHTest :: TestTree +ifaceTHTest = testCase "iface-th-test" $ runWithExtraFiles "TH" $ \dir -> do + let aPath = dir "THA.hs" + bPath = dir "THB.hs" + cPath = dir "THC.hs" + + aSource <- liftIO $ readFileUtf8 aPath -- [TH] a :: () + _bSource <- liftIO $ readFileUtf8 bPath -- a :: () + cSource <- liftIO $ readFileUtf8 cPath -- c = a :: () + + cdoc <- createDoc cPath "haskell" cSource + + -- Change [TH]a from () to Bool + liftIO $ writeFileUTF8 aPath (unlines $ init (lines $ T.unpack aSource) ++ ["th_a = [d| a = False|]"]) + + -- Check that the change propagates to C + changeDoc cdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ cSource] + expectDiagnostics + [("THC.hs", [(DiagnosticSeverity_Error, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")]) + ,("THB.hs", [(DiagnosticSeverity_Warning, (4,1), "Top-level binding")])] + closeDoc cdoc + +ifaceErrorTest :: TestTree +ifaceErrorTest = testCase "iface-error-test-1" $ runWithExtraFiles "recomp" $ \dir -> do + configureCheckProject True + let bPath = dir "B.hs" + pPath = dir "P.hs" + + bSource <- liftIO $ readFileUtf8 bPath -- y :: Int + pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int + + bdoc <- createDoc bPath "haskell" bSource + expectDiagnostics + [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")])] -- So what we know P has been loaded + + -- Change y from Int to B + changeDoc bdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ T.unlines ["module B where", "y :: Bool", "y = undefined"]] + -- save so that we can that the error propagates to A + sendNotification SMethod_TextDocumentDidSave (DidSaveTextDocumentParams bdoc Nothing) + + + -- Check that the error propagates to A + expectDiagnostics + [("A.hs", [(DiagnosticSeverity_Error, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])] + + -- Check that we wrote the interfaces for B when we saved + hidir <- getInterfaceFilesDir bdoc + hi_exists <- liftIO $ doesFileExist $ hidir "B.hi" + liftIO $ assertBool ("Couldn't find B.hi in " ++ hidir) hi_exists + + pdoc <- openDoc pPath "haskell" + expectDiagnostics + [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")]) + ] + changeDoc pdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ pSource <> "\nfoo = y :: Bool" ] + -- Now in P we have + -- bar = x :: Int + -- foo = y :: Bool + -- HOWEVER, in A... + -- x = y :: Int + -- This is clearly inconsistent, and the expected outcome a bit surprising: + -- - The diagnostic for A has already been received. Ghcide does not repeat diagnostics + -- - P is being typechecked with the last successful artifacts for A. + expectDiagnostics + [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")]) + ,("P.hs", [(DiagnosticSeverity_Warning,(6,0), "Top-level binding")]) + ] + expectNoMoreDiagnostics 2 + +ifaceErrorTest2 :: TestTree +ifaceErrorTest2 = testCase "iface-error-test-2" $ runWithExtraFiles "recomp" $ \dir -> do + let bPath = dir "B.hs" + pPath = dir "P.hs" + + bSource <- liftIO $ readFileUtf8 bPath -- y :: Int + pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int + + bdoc <- createDoc bPath "haskell" bSource + pdoc <- createDoc pPath "haskell" pSource + expectDiagnostics + [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")])] -- So that we know P has been loaded + + -- Change y from Int to B + changeDoc bdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ T.unlines ["module B where", "y :: Bool", "y = undefined"]] + + -- Add a new definition to P + changeDoc pdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ pSource <> "\nfoo = y :: Bool" ] + -- Now in P we have + -- bar = x :: Int + -- foo = y :: Bool + -- HOWEVER, in A... + -- x = y :: Int + expectDiagnostics + -- As in the other test, P is being typechecked with the last successful artifacts for A + -- (ot thanks to -fdeferred-type-errors) + [("A.hs", [(DiagnosticSeverity_Error, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")]) + ,("P.hs", [(DiagnosticSeverity_Warning, (4, 0), "Top-level binding")]) + ,("P.hs", [(DiagnosticSeverity_Warning, (6, 0), "Top-level binding")]) + ] + + expectNoMoreDiagnostics 2 + +ifaceErrorTest3 :: TestTree +ifaceErrorTest3 = testCase "iface-error-test-3" $ runWithExtraFiles "recomp" $ \dir -> do + let bPath = dir "B.hs" + pPath = dir "P.hs" + + bSource <- liftIO $ readFileUtf8 bPath -- y :: Int + pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int + + bdoc <- createDoc bPath "haskell" bSource + + -- Change y from Int to B + changeDoc bdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ T.unlines ["module B where", "y :: Bool", "y = undefined"]] + + -- P should not typecheck, as there are no last valid artifacts for A + _pdoc <- createDoc pPath "haskell" pSource + + -- In this example the interface file for A should not exist (modulo the cache folder) + -- Despite that P still type checks, as we can generate an interface file for A thanks to -fdeferred-type-errors + expectDiagnostics + [("A.hs", [(DiagnosticSeverity_Error, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")]) + ,("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")]) + ] + expectNoMoreDiagnostics 2 diff --git a/ghcide/test/exe/InitializeResponseTests.hs b/ghcide/test/exe/InitializeResponseTests.hs new file mode 100644 --- /dev/null +++ b/ghcide/test/exe/InitializeResponseTests.hs @@ -0,0 +1,91 @@ + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLabels #-} + +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 Config (dummyPlugin, mkIdeTestFs) +import Control.Lens ((^.)) +import Development.IDE.Plugin.Test (blockCommandId) +import Test.Hls + +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 = runSessionWithServerInTmpDir def dummyPlugin (mkIdeTestFs []) initializeResponse + + release :: TResponseMessage Method_Initialize -> IO () + release = mempty + diff --git a/ghcide/test/exe/LogType.hs b/ghcide/test/exe/LogType.hs new file mode 100644 --- /dev/null +++ b/ghcide/test/exe/LogType.hs @@ -0,0 +1,21 @@ +module LogType (Log(..)) where + +import qualified Development.IDE.LSP.Notifications as Notifications +import qualified Development.IDE.Main as IDE +import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide + +import Ide.Logger (Pretty (pretty)) +import Language.LSP.VFS (VfsLog) + +data Log + = LogGhcIde Ghcide.Log + | LogIDEMain IDE.Log + | LogVfs VfsLog + | LogNotifications Notifications.Log + +instance Pretty Log where + pretty = \case + LogGhcIde log -> pretty log + LogIDEMain log -> pretty log + LogVfs log -> pretty log + LogNotifications log -> pretty log diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs new file mode 100644 --- /dev/null +++ b/ghcide/test/exe/Main.hs @@ -0,0 +1,118 @@ +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +{- + NOTE On enforcing determinism + + The tests below use two mechanisms to enforce deterministic LSP sequences: + + 1. Progress reporting: waitForProgress(Begin|Done) + 2. Diagnostics: expectDiagnostics + + Either is fine, but diagnostics are generally more reliable. + + Mixing them both in the same test is NOT FINE as it will introduce race + conditions since multiple interleavings are possible. In other words, + the sequence of diagnostics and progress reports is not deterministic. + For example: + + < do something > + waitForProgressDone + expectDiagnostics [...] + + - When the diagnostics arrive after the progress done message, as they usually do, the test will pass + - When the diagnostics arrive before the progress done msg, when on a slow machine occasionally, the test will timeout + + Therefore, avoid mixing both progress reports and diagnostics in the same test + -} + + + +module Main (main) where +-- import Test.QuickCheck.Instances () +import Data.Function ((&)) +import qualified HieDbRetry +import Ide.Logger (LoggingColumn (DataColumn, PriorityColumn), + Pretty (pretty), + Priority (Debug), + WithPriority (WithPriority, priority), + cfilter, cmapWithPrio, + makeDefaultStderrRecorder) +import Test.Tasty +import Test.Tasty.Ingredients.Rerun + +import AsyncTests +import BootTests +import ClientSettingsTests +import CodeLensTests +import CompletionTests +import CPPTests +import CradleTests +import DependentFileTest +import DiagnosticTests +import ExceptionTests +import FindDefinitionAndHoverTests +import GarbageCollectionTests +import HaddockTests +import HighlightTests +import IfaceTests +import InitializeResponseTests +import LogType () +import NonLspCommandLine +import OpenCloseTest +import OutlineTests +import PluginSimpleTests +import PositionMappingTests +import PreprocessorTests +import ReferenceTests +import RootUriTests +import SafeTests +import SymlinkTests +import THTests +import UnitTests +import WatchedFileTests + +main :: IO () +main = do + docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) + + let docWithFilteredPriorityRecorder = + docWithPriorityRecorder + & cfilter (\WithPriority{ priority } -> priority >= Debug) + + let recorder = docWithFilteredPriorityRecorder + & cmapWithPrio pretty + + -- We mess with env vars so run single-threaded. + defaultMainWithRerun $ testGroup "ghcide" + [ OpenCloseTest.tests + , InitializeResponseTests.tests + , CompletionTests.tests + , CPPTests.tests + , DiagnosticTests.tests + , CodeLensTests.tests + , OutlineTests.tests + , HighlightTests.tests + , FindDefinitionAndHoverTests.tests + , PluginSimpleTests.tests + , PreprocessorTests.tests + , THTests.tests + , SymlinkTests.tests + , SafeTests.tests + , UnitTests.tests recorder + , HaddockTests.tests + , PositionMappingTests.tests + , WatchedFileTests.tests + , CradleTests.tests + , DependentFileTest.tests + , NonLspCommandLine.tests + , IfaceTests.tests + , BootTests.tests + , RootUriTests.tests + , AsyncTests.tests + , ClientSettingsTests.tests + , ReferenceTests.tests + , GarbageCollectionTests.tests + , HieDbRetry.tests + , ExceptionTests.tests recorder + ] diff --git a/ghcide/test/exe/NonLspCommandLine.hs b/ghcide/test/exe/NonLspCommandLine.hs new file mode 100644 --- /dev/null +++ b/ghcide/test/exe/NonLspCommandLine.hs @@ -0,0 +1,27 @@ + +module NonLspCommandLine (tests) where + +import Development.IDE.Test.Runfiles +import System.Environment.Blank (setEnv) +import System.Exit (ExitCode (ExitSuccess)) +import System.Process.Extra (CreateProcess (cwd), proc, + readCreateProcessWithExitCode) +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + + +-- A test to ensure that the command line ghcide workflow stays working +tests :: TestTree +tests = testGroup "ghcide command line" + [ testCase "works" $ withTempDir $ \dir -> do + ghcide <- locateGhcideExecutable + copyTestDataFiles dir "multi" + let cmd = (proc ghcide ["a/A.hs"]){cwd = Just dir} + + setEnv "HOME" "/homeless-shelter" False + + (ec, _, _) <- readCreateProcessWithExitCode cmd "" + + ec @?= ExitSuccess + ] diff --git a/ghcide/test/exe/OpenCloseTest.hs b/ghcide/test/exe/OpenCloseTest.hs new file mode 100644 --- /dev/null +++ b/ghcide/test/exe/OpenCloseTest.hs @@ -0,0 +1,18 @@ + +module OpenCloseTest (tests) where + +import Control.Applicative.Combinators +import Control.Monad +import Language.LSP.Protocol.Message +import Language.LSP.Test +-- import Test.QuickCheck.Instances () +import Test.Tasty +import TestUtils + +tests :: TestTree +tests = testSession "open close" $ do + doc <- createDoc "Testing.hs" "haskell" "" + void (skipManyTill anyMessage $ message SMethod_WindowWorkDoneProgressCreate) + waitForProgressBegin + closeDoc doc + waitForProgressDone diff --git a/ghcide/test/exe/OutlineTests.hs b/ghcide/test/exe/OutlineTests.hs new file mode 100644 --- /dev/null +++ b/ghcide/test/exe/OutlineTests.hs @@ -0,0 +1,189 @@ + +module OutlineTests (tests) where + +import Control.Monad.IO.Class (liftIO) +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 TestUtils + +tests :: TestTree +tests = testGroup + "outline" + [ testSessionWait "type class" $ do + let source = T.unlines ["module A where", "class A a where a :: a -> Bool"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [ 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)] + ] + ] + , testSessionWait "type class instance " $ do + let source = T.unlines ["class A a where", "instance A () where"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [ classSymbol "A a" (R 0 0 0 15) [] + , docSymbol "A ()" SymbolKind_Interface (R 1 0 1 19) + ] + , testSessionWait "type family" $ do + let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right [docSymbolD "A" "type family" SymbolKind_Function (R 1 0 1 13)] + , testSessionWait "type family instance " $ do + let source = T.unlines + [ "{-# language TypeFamilies #-}" + , "type family A a" + , "type instance A () = ()" + ] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [ docSymbolD "A a" "type family" SymbolKind_Function (R 1 0 1 15) + , docSymbol "A ()" SymbolKind_Interface (R 2 0 2 23) + ] + , testSessionWait "data family" $ do + let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right [docSymbolD "A" "data family" SymbolKind_Function (R 1 0 1 11)] + , testSessionWait "data family instance " $ do + let source = T.unlines + [ "{-# language TypeFamilies #-}" + , "data family A a" + , "data instance A () = A ()" + ] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [ docSymbolD "A a" "data family" SymbolKind_Function (R 1 0 1 11) + , docSymbol "A ()" SymbolKind_Interface (R 2 0 2 25) + ] + , testSessionWait "constant" $ do + let source = T.unlines ["a = ()"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [docSymbol "a" SymbolKind_Function (R 0 0 0 6)] + , testSessionWait "pattern" $ do + let source = T.unlines ["Just foo = Just 21"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [docSymbol "Just foo" SymbolKind_Function (R 0 0 0 18)] + , testSessionWait "pattern with type signature" $ do + let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [docSymbol "a :: ()" SymbolKind_Function (R 1 0 1 12)] + , testSessionWait "function" $ do + let source = T.unlines ["a _x = ()"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right [docSymbol "a" SymbolKind_Function (R 0 0 0 9)] + , testSessionWait "type synonym" $ do + let source = T.unlines ["type A = Bool"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [docSymbol' "A" SymbolKind_TypeParameter (R 0 0 0 13) (R 0 5 0 6)] + , testSessionWait "datatype" $ do + let source = T.unlines ["data A = C"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [ docSymbolWithChildren "A" + SymbolKind_Struct + (R 0 0 0 10) + [docSymbol "C" SymbolKind_Constructor (R 0 9 0 10)] + ] + , testSessionWait "record fields" $ do + let source = T.unlines ["data A = B {", " x :: Int", " , y :: Int}"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [ 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) + ] + ] + ] + , testSessionWait "import" $ do + let source = T.unlines ["import Data.Maybe ()"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [docSymbolWithChildren "imports" + SymbolKind_Module + (R 0 0 0 20) + [ docSymbol "import Data.Maybe" SymbolKind_Module (R 0 0 0 20) + ] + ] + , testSessionWait "multiple import" $ do + let source = T.unlines ["", "import Data.Maybe ()", "", "import Control.Exception ()", ""] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [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) + ] + ] + , testSessionWait "foreign import" $ do + let source = T.unlines + [ "{-# language ForeignFunctionInterface #-}" + , "foreign import ccall \"a\" a :: Int" + ] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right [docSymbolD "a" "import" SymbolKind_Object (R 1 0 1 33)] + , testSessionWait "foreign export" $ do + let source = T.unlines + [ "{-# language ForeignFunctionInterface #-}" + , "foreign export ccall odd :: Int -> Bool" + ] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right [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/ghcide/test/exe/PluginSimpleTests.hs b/ghcide/test/exe/PluginSimpleTests.hs new file mode 100644 --- /dev/null +++ b/ghcide/test/exe/PluginSimpleTests.hs @@ -0,0 +1,50 @@ + +module PluginSimpleTests (tests) where + +import Control.Monad.IO.Class (liftIO) +import Development.IDE.GHC.Compat (GhcVersion (..)) +import Development.IDE.Test (expectDiagnostics) +import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), mkRange) +import Language.LSP.Test +import System.FilePath +-- import Test.QuickCheck.Instances () +import Test.Tasty +import TestUtils + +tests :: TestTree +tests = + -- Build profile: -w ghc-9.4.2 -O1 + -- In order, the following will be built (use -v for more details): + -- - ghc-typelits-natnormalise-0.7.7 (lib) (requires build) + -- - ghc-typelits-knownnat-0.7.7 (lib) (requires build) + -- - plugin-1.0.0 (lib) (first run) + -- Starting ghc-typelits-natnormalise-0.7.7 (lib) + -- Building ghc-typelits-natnormalise-0.7.7 (lib) + + -- Failed to build ghc-typelits-natnormalise-0.7.7. + -- Build log ( + -- C:\cabal\logs\ghc-9.4.2\ghc-typelits-_-0.7.7-3f036a52a0d9bfc3389d1852a87da2e87c6de2e4.log + -- ): + -- Preprocessing library for ghc-typelits-natnormalise-0.7.7.. + -- Building library for ghc-typelits-natnormalise-0.7.7.. + -- [1 of 3] Compiling GHC.TypeLits.Normalise.SOP ( src\GHC\TypeLits\Normalise\SOP.hs, dist\build\GHC\TypeLits\Normalise\SOP.o ) + -- [2 of 3] Compiling GHC.TypeLits.Normalise.Unify ( src\GHC\TypeLits\Normalise\Unify.hs, dist\build\GHC\TypeLits\Normalise\Unify.o ) + -- [3 of 3] Compiling GHC.TypeLits.Normalise ( src-ghc-9.4\GHC\TypeLits\Normalise.hs, dist\build\GHC\TypeLits\Normalise.o ) + -- C:\tools\ghc-9.4.2\lib\../mingw/bin/llvm-ar.exe: error: dist\build\objs-5156\libHSghc-typelits-_-0.7.7-3f036a52a0d9bfc3389d1852a87da2e87c6de2e4.a: No such file or directory + + -- Error: cabal: Failed to build ghc-typelits-natnormalise-0.7.7 (which is + -- required by plugin-1.0.0). See the build log above for details. + ignoreFor (BrokenForGHC [GHC96, GHC98]) "fragile, frequently times out" $ + ignoreFor (BrokenSpecific Windows [GHC94]) "ghc-typelist-natnormalise fails to build on GHC 9.4.2 for windows only" $ + testSessionWithExtraFiles "plugin-knownnat" "simple plugin" $ \dir -> do + _ <- openDoc (dir "KnownNat.hs") "haskell" + liftIO $ writeFile (dir"hie.yaml") + "cradle: {cabal: [{path: '.', component: 'lib:plugin'}]}" + + expectDiagnostics + [ ( "KnownNat.hs", + [(DiagnosticSeverity_Error, (9, 15), "Variable not in scope: c")] + ) + ] diff --git a/ghcide/test/exe/PositionMappingTests.hs b/ghcide/test/exe/PositionMappingTests.hs new file mode 100644 --- /dev/null +++ b/ghcide/test/exe/PositionMappingTests.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE OverloadedLabels #-} + +module PositionMappingTests (tests) where + +import qualified Data.EnumMap.Strict as EM +import Data.Row +import qualified Data.Text as T +import Data.Text.Utf16.Rope.Mixed (Rope) +import qualified Data.Text.Utf16.Rope.Mixed as Rope +import Development.IDE.Core.PositionMapping (PositionResult (..), + fromCurrent, + positionResultToMaybe, + toCurrent, + toCurrentPosition) +import Development.IDE.Types.Location +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.VFS (applyChange) +import Test.QuickCheck +-- import Test.QuickCheck.Instances () +import Control.Arrow (second) +import Data.Functor.Identity (runIdentity) +import Data.Text (Text) +import Development.IDE.Core.Shake (updatePositionMappingHelper) +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +enumMapMappingTest :: TestTree +enumMapMappingTest = testCase "enumMapMappingTest" $ do + let mkChangeEvent :: Range -> Text -> TextDocumentContentChangeEvent + mkChangeEvent r t = TextDocumentContentChangeEvent $ InL $ #range .== r .+ #rangeLength .== Nothing .+ #text .== t + mkCE :: UInt -> UInt -> UInt -> UInt -> Text -> TextDocumentContentChangeEvent + mkCE l1 c1 l2 c2 = mkChangeEvent (Range (Position l1 c1) (Position l2 c2)) + events :: [(Int32, [TextDocumentContentChangeEvent])] + events = map (second return) [(0, mkCE 0 0 0 0 ""), (1, mkCE 0 1 0 1 " "), (2, mkCE 0 2 0 2 " "), (3, mkCE 0 3 0 3 " "), (4, mkCE 0 4 0 4 " "), (5, mkCE 0 5 0 5 " ")] + finalMap = Prelude.foldl (\m (i, e) -> updatePositionMappingHelper i e m) mempty events + let updatePose fromPos = do + mapping <- snd <$> EM.lookup 0 finalMap + toCurrentPosition mapping fromPos + updatePose (Position 0 4) @?= Just (Position 0 9) + updatePose (Position 0 5) @?= Just (Position 0 10) + + +tests :: TestTree +tests = + testGroup "position mapping" + [ + enumMapMappingTest + , testGroup "toCurrent" + [ testCase "before" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "ab" + (Position 0 0) @?= PositionExact (Position 0 0) + , testCase "after, same line, same length" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "ab" + (Position 0 3) @?= PositionExact (Position 0 3) + , testCase "after, same line, increased length" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "abc" + (Position 0 3) @?= PositionExact (Position 0 4) + , testCase "after, same line, decreased length" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "a" + (Position 0 3) @?= PositionExact (Position 0 2) + , testCase "after, next line, no newline" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "abc" + (Position 1 3) @?= PositionExact (Position 1 3) + , testCase "after, next line, newline" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "abc\ndef" + (Position 1 0) @?= PositionExact (Position 2 0) + , testCase "after, same line, newline" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "abc\nd" + (Position 0 4) @?= PositionExact (Position 1 2) + , testCase "after, same line, newline + newline at end" $ + toCurrent + (Range (Position 0 1) (Position 0 3)) + "abc\nd\n" + (Position 0 4) @?= PositionExact (Position 2 1) + , testCase "after, same line, newline + newline at end" $ + toCurrent + (Range (Position 0 1) (Position 0 1)) + "abc" + (Position 0 1) @?= PositionExact (Position 0 4) + ] + , testGroup "fromCurrent" + [ testCase "before" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "ab" + (Position 0 0) @?= PositionExact (Position 0 0) + , testCase "after, same line, same length" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "ab" + (Position 0 3) @?= PositionExact (Position 0 3) + , testCase "after, same line, increased length" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "abc" + (Position 0 4) @?= PositionExact (Position 0 3) + , testCase "after, same line, decreased length" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "a" + (Position 0 2) @?= PositionExact (Position 0 3) + , testCase "after, next line, no newline" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "abc" + (Position 1 3) @?= PositionExact (Position 1 3) + , testCase "after, next line, newline" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "abc\ndef" + (Position 2 0) @?= PositionExact (Position 1 0) + , testCase "after, same line, newline" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "abc\nd" + (Position 1 2) @?= PositionExact (Position 0 4) + , testCase "after, same line, newline + newline at end" $ + fromCurrent + (Range (Position 0 1) (Position 0 3)) + "abc\nd\n" + (Position 2 1) @?= PositionExact (Position 0 4) + , testCase "after, same line, newline + newline at end" $ + fromCurrent + (Range (Position 0 1) (Position 0 1)) + "abc" + (Position 0 4) @?= PositionExact (Position 0 1) + ] + , adjustOption (\(QuickCheckTests i) -> QuickCheckTests (max 1000 i)) $ testGroup "properties" + [ testProperty "fromCurrent r t <=< toCurrent r t" $ do + -- Note that it is important to use suchThatMap on all values at once + -- instead of only using it on the position. Otherwise you can get + -- into situations where there is no position that can be mapped back + -- for the edit which will result in QuickCheck looping forever. + let gen = do + rope <- genRope + range <- genRange rope + PrintableText replacement <- arbitrary + oldPos <- genPosition rope + pure (range, replacement, oldPos) + forAll + (suchThatMap gen + (\(range, replacement, oldPos) -> positionResultToMaybe $ (range, replacement, oldPos,) <$> toCurrent range replacement oldPos)) $ + \(range, replacement, oldPos, newPos) -> + fromCurrent range replacement newPos === PositionExact oldPos + , testProperty "toCurrent r t <=< fromCurrent r t" $ do + let gen = do + rope <- genRope + range <- genRange rope + PrintableText replacement <- arbitrary + let newRope = runIdentity $ applyChange mempty rope + (TextDocumentContentChangeEvent $ InL $ #range .== range + .+ #rangeLength .== Nothing + .+ #text .== replacement) + newPos <- genPosition newRope + pure (range, replacement, newPos) + forAll + (suchThatMap gen + (\(range, replacement, newPos) -> positionResultToMaybe $ (range, replacement, newPos,) <$> fromCurrent range replacement newPos)) $ + \(range, replacement, newPos, oldPos) -> + toCurrent range replacement oldPos === PositionExact newPos + ] + ] + +newtype PrintableText = PrintableText { getPrintableText :: T.Text } + deriving Show + +instance Arbitrary PrintableText where + arbitrary = PrintableText . T.pack . getPrintableString <$> arbitrary + +genRope :: Gen Rope +genRope = Rope.fromText . getPrintableText <$> arbitrary + +genPosition :: Rope -> Gen Position +genPosition r = do + let rows :: Int = fromIntegral $ Rope.lengthInLines r + row <- choose (0, max 0 $ rows - 1) `suchThat` inBounds @UInt + let columns = T.length (nthLine (fromIntegral row) r) + column <- choose (0, max 0 $ columns - 1) `suchThat` inBounds @UInt + pure $ Position (fromIntegral row) (fromIntegral column) + +genRange :: Rope -> Gen Range +genRange r = do + let rows :: Int = fromIntegral $ Rope.lengthInLines r + startPos@(Position startLine startColumn) <- genPosition r + let maxLineDiff = max 0 $ rows - 1 - fromIntegral startLine + endLine <- choose (fromIntegral startLine, fromIntegral startLine + maxLineDiff) `suchThat` inBounds @UInt + let columns = T.length (nthLine (fromIntegral endLine) r) + endColumn <- + if fromIntegral startLine == endLine + then choose (fromIntegral startColumn, columns) + else choose (0, max 0 $ columns - 1) + `suchThat` inBounds @UInt + pure $ Range startPos (Position (fromIntegral endLine) (fromIntegral endColumn)) + +inBounds :: forall b a . (Integral a, Integral b, Bounded b) => a -> Bool +inBounds a = let i = toInteger a in i <= toInteger (maxBound @b) && i >= toInteger (minBound @b) + +-- | Get the ith line of a rope, starting from 0. Trailing newline not included. +nthLine :: Int -> Rope -> T.Text +nthLine i r + | Rope.null r = "" + | otherwise = Rope.lines r !! i diff --git a/ghcide/test/exe/PreprocessorTests.hs b/ghcide/test/exe/PreprocessorTests.hs new file mode 100644 --- /dev/null +++ b/ghcide/test/exe/PreprocessorTests.hs @@ -0,0 +1,27 @@ + +module PreprocessorTests (tests) where + +import qualified Data.Text as T +import Development.IDE.Test (expectDiagnostics) +import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), mkRange) +import Language.LSP.Test +-- import Test.QuickCheck.Instances () +import Test.Tasty +import TestUtils + +tests :: TestTree +tests = testSessionWait "preprocessor" $ do + let content = + T.unlines + [ "{-# OPTIONS_GHC -F -pgmF=ghcide-test-preprocessor #-}" + , "module Testing where" + , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic + ] + _ <- createDoc "Testing.hs" "haskell" content + expectDiagnostics + [ ( "Testing.hs", + [(DiagnosticSeverity_Error, (2, 8), "Variable not in scope: z")] + ) + ] diff --git a/ghcide/test/exe/Progress.hs b/ghcide/test/exe/Progress.hs new file mode 100644 --- /dev/null +++ b/ghcide/test/exe/Progress.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE PackageImports #-} +module Progress (tests) where + +import Control.Concurrent.STM +import Data.Foldable (for_) +import qualified Data.HashMap.Strict as Map +import Development.IDE (NormalizedFilePath) +import Development.IDE.Core.ProgressReporting +import qualified "list-t" ListT +import qualified StmContainers.Map as STM +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = testGroup "Progress" + [ reportProgressTests + ] + +data InProgressModel = InProgressModel { + done, todo :: Int, + current :: Map.HashMap NormalizedFilePath Int +} + +reportProgressTests :: TestTree +reportProgressTests = testGroup "recordProgress" + [ test "addNew" addNew + , test "increase" increase + , test "decrease" decrease + , test "done" done + ] + where + p0 = pure $ InProgressModel 0 0 mempty + addNew = recordProgressModel "A" succ p0 + increase = recordProgressModel "A" succ addNew + decrease = recordProgressModel "A" succ increase + done = recordProgressModel "A" pred decrease + recordProgressModel key change state = + model state $ \st -> recordProgress st key change + model stateModelIO k = do + state <- fromModel =<< stateModelIO + _ <- k state + toModel state + test name p = testCase name $ do + InProgressModel{..} <- p + (done, todo) @?= (length (filter (==0) (Map.elems current)), Map.size current) + +fromModel :: InProgressModel -> IO InProgressState +fromModel InProgressModel{..} = do + doneVar <- newTVarIO done + todoVar <- newTVarIO todo + currentVar <- STM.newIO + atomically $ for_ (Map.toList current) $ \(k,v) -> STM.insert v k currentVar + return InProgressState{..} + +toModel :: InProgressState -> IO InProgressModel +toModel InProgressState{..} = atomically $ do + done <- readTVar doneVar + todo <- readTVar todoVar + current <- Map.fromList <$> ListT.toList (STM.listT currentVar) + return InProgressModel{..} diff --git a/ghcide/test/exe/ReferenceTests.hs b/ghcide/test/exe/ReferenceTests.hs new file mode 100644 --- /dev/null +++ b/ghcide/test/exe/ReferenceTests.hs @@ -0,0 +1,199 @@ + +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.Test (configureCheckProject, + referenceReady) +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 System.FilePath +-- import Test.QuickCheck.Instances () +import Control.Lens ((^.)) +import Data.Tuple.Extra +import Test.Tasty +import Test.Tasty.ExpectedFailure +import Test.Tasty.HUnit +import TestUtils + + +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] -> (FilePath -> Session ()) -> TestTree +referenceTestSession name thisDoc docs' f = testSessionWithExtraFiles "references" name $ \dir -> do + -- needed to build whole project indexing + configureCheckProject True + let docs = map (dir ) $ delete thisDoc $ nubOrd docs' + -- Initial Index + docid <- openDoc thisDoc "haskell" + let + loop :: [FilePath] -> Session () + loop [] = pure () + loop docs = do + doc <- skipManyTill anyMessage $ referenceReady (`elem` docs) + loop (delete doc docs) + loop docs + f dir + closeDoc docid + +-- | Given a location, lookup the symbol and all references to it. Make sure +-- they are the ones we expect. +referenceTest :: String -> SymbolLocation -> IncludeDeclaration -> [SymbolLocation] -> TestTree +referenceTest name loc includeDeclaration expected = + referenceTestSession name (fst3 loc) docs $ \dir -> do + actual <- getReferences' loc includeDeclaration + liftIO $ actual `expectSameLocations` map (first3 (dir )) expected + where + docs = map fst3 expected + +type SymbolLocation = (FilePath, UInt, UInt) + +expectSameLocations :: [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/ghcide/test/exe/RootUriTests.hs b/ghcide/test/exe/RootUriTests.hs new file mode 100644 --- /dev/null +++ b/ghcide/test/exe/RootUriTests.hs @@ -0,0 +1,26 @@ + +module RootUriTests (tests) where + +import Control.Monad.IO.Class (liftIO) +import Development.IDE.GHC.Util +import Development.IDE.Test (expectNoMoreDiagnostics) +import Language.LSP.Test +import System.FilePath +-- import Test.QuickCheck.Instances () +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + + +-- | checks if we use InitializeParams.rootUri for loading session +tests :: TestTree +tests = testCase "use rootUri" . runTest "dirA" "dirB" $ \dir -> do + let bPath = dir "dirB/Foo.hs" + liftIO $ copyTestDataFiles dir "rootUri" + bSource <- liftIO $ readFileUtf8 bPath + _ <- createDoc "Foo.hs" "haskell" bSource + expectNoMoreDiagnostics 0.5 + where + -- similar to run' except we can configure where to start ghcide and session + runTest :: FilePath -> FilePath -> (FilePath -> Session ()) -> IO () + runTest dir1 dir2 s = withTempDir $ \dir -> runInDir' dir dir1 dir2 [] (s dir) diff --git a/ghcide/test/exe/SafeTests.hs b/ghcide/test/exe/SafeTests.hs new file mode 100644 --- /dev/null +++ b/ghcide/test/exe/SafeTests.hs @@ -0,0 +1,38 @@ + +module SafeTests (tests) where + +import qualified Data.Text as T +import Development.IDE.Test (expectNoMoreDiagnostics) +import Language.LSP.Test + +import Test.Tasty +import TestUtils + +tests :: TestTree +tests = + testGroup + "SafeHaskell" + [ -- Test for https://github.com/haskell/ghcide/issues/424 + testSessionWait "load" $ do + let sourceA = + T.unlines + ["{-# LANGUAGE Trustworthy #-}" + ,"module A where" + ,"import System.IO.Unsafe" + ,"import System.IO ()" + ,"trustWorthyId :: a -> a" + ,"trustWorthyId i = unsafePerformIO $ do" + ," putStrLn \"I'm safe\"" + ," return i"] + sourceB = + T.unlines + ["{-# LANGUAGE Safe #-}" + ,"module B where" + ,"import A" + ,"safeId :: a -> a" + ,"safeId = trustWorthyId" + ] + + _ <- createDoc "A.hs" "haskell" sourceA + _ <- createDoc "B.hs" "haskell" sourceB + expectNoMoreDiagnostics 1 ] diff --git a/ghcide/test/exe/SymlinkTests.hs b/ghcide/test/exe/SymlinkTests.hs new file mode 100644 --- /dev/null +++ b/ghcide/test/exe/SymlinkTests.hs @@ -0,0 +1,27 @@ + +module SymlinkTests (tests) where + +import Control.Monad.IO.Class (liftIO) +import Development.IDE.Test (expectDiagnosticsWithTags) +import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), mkRange) +import Language.LSP.Test +import System.Directory +import System.FilePath + +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + +-- | Tests for projects that use symbolic links one way or another +tests :: TestTree +tests = + testGroup "Projects using Symlinks" + [ testCase "Module is symlinked" $ runWithExtraFiles "symlink" $ \dir -> do + liftIO $ createFileLink (dir "some_loc" "Sym.hs") (dir "other_loc" "Sym.hs") + let fooPath = dir "src" "Foo.hs" + _ <- openDoc fooPath "haskell" + expectDiagnosticsWithTags [("src" "Foo.hs", [(DiagnosticSeverity_Warning, (2, 0), "The import of 'Sym' is redundant", Just DiagnosticTag_Unnecessary)])] + pure () + ] diff --git a/ghcide/test/exe/THTests.hs b/ghcide/test/exe/THTests.hs new file mode 100644 --- /dev/null +++ b/ghcide/test/exe/THTests.hs @@ -0,0 +1,194 @@ + +{-# LANGUAGE OverloadedLabels #-} + +module THTests (tests) where + +import Control.Monad.IO.Class (liftIO) +import Data.Row +import qualified Data.Text as T +import Development.IDE.GHC.Util +import Development.IDE.Test (expectCurrentDiagnostics, + expectDiagnostics, + expectNoMoreDiagnostics) +import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), mkRange) +import Language.LSP.Test +import System.FilePath +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + +tests :: TestTree +tests = + testGroup + "TemplateHaskell" + [ -- Test for https://github.com/haskell/ghcide/pull/212 + testSessionWait "load" $ do + let sourceA = + T.unlines + [ "{-# LANGUAGE PackageImports #-}", + "{-# LANGUAGE TemplateHaskell #-}", + "module A where", + "import \"template-haskell\" Language.Haskell.TH", + "a :: Integer", + "a = $(litE $ IntegerL 3)" + ] + sourceB = + T.unlines + [ "{-# LANGUAGE PackageImports #-}", + "{-# LANGUAGE TemplateHaskell #-}", + "module B where", + "import A", + "import \"template-haskell\" Language.Haskell.TH", + "b :: Integer", + "b = $(litE $ IntegerL $ a) + n" + ] + _ <- createDoc "A.hs" "haskell" sourceA + _ <- createDoc "B.hs" "haskell" sourceB + expectDiagnostics [ ( "B.hs", [(DiagnosticSeverity_Error, (6, 29), "Variable not in scope: n")] ) ] + , testSessionWait "newtype-closure" $ do + let sourceA = + T.unlines + [ "{-# LANGUAGE DeriveDataTypeable #-}" + ,"{-# LANGUAGE TemplateHaskell #-}" + ,"module A (a) where" + ,"import Data.Data" + ,"import Language.Haskell.TH" + ,"newtype A = A () deriving (Data)" + ,"a :: ExpQ" + ,"a = [| 0 |]"] + let sourceB = + T.unlines + [ "{-# LANGUAGE TemplateHaskell #-}" + ,"module B where" + ,"import A" + ,"b :: Int" + ,"b = $( a )" ] + _ <- createDoc "A.hs" "haskell" sourceA + _ <- createDoc "B.hs" "haskell" sourceB + return () + , thReloadingTest False + , thLoadingTest + , thCoreTest + , ignoreInWindowsBecause "Broken in windows" $ thReloadingTest True + -- Regression test for https://github.com/haskell/haskell-language-server/issues/891 + , thLinkingTest False + , ignoreInWindowsBecause "Broken in windows" $ thLinkingTest True + , testSessionWait "findsTHIdentifiers" $ do + let sourceA = + T.unlines + [ "{-# LANGUAGE TemplateHaskell #-}" + , "module A (a) where" + , "import Language.Haskell.TH (ExpQ)" + , "a :: ExpQ" -- TH 2.17 requires an explicit type signature since splices are polymorphic + , "a = [| glorifiedID |]" + , "glorifiedID :: a -> a" + , "glorifiedID = id" ] + let sourceB = + T.unlines + [ "{-# OPTIONS_GHC -Wall #-}" + , "{-# LANGUAGE TemplateHaskell #-}" + , "module B where" + , "import A" + , "main = $a (putStrLn \"success!\")"] + _ <- createDoc "A.hs" "haskell" sourceA + _ <- createDoc "B.hs" "haskell" sourceB + expectDiagnostics [ ( "B.hs", [(DiagnosticSeverity_Warning, (4, 0), "Top-level binding with no type signature: main :: IO ()")] ) ] + , testCase "findsTHnewNameConstructor" $ runWithExtraFiles "THNewName" $ \dir -> do + + -- This test defines a TH value with the meaning "data A = A" in A.hs + -- Loads and export the template in B.hs + -- And checks wether the constructor A can be loaded in C.hs + -- This test does not fail when either A and B get manually loaded before C.hs + -- or when we remove the seemingly unnecessary TH pragma from C.hs + + let cPath = dir "C.hs" + _ <- openDoc cPath "haskell" + expectDiagnostics [ ( cPath, [(DiagnosticSeverity_Warning, (3, 0), "Top-level binding with no type signature: a :: A")] ) ] + ] + + +-- | Test that all modules have linkables +thLoadingTest :: TestTree +thLoadingTest = testCase "Loading linkables" $ runWithExtraFiles "THLoading" $ \dir -> do + let thb = dir "THB.hs" + _ <- openDoc thb "haskell" + expectNoMoreDiagnostics 1 + +thCoreTest :: TestTree +thCoreTest = testCase "Verifying TH core files" $ runWithExtraFiles "THCoreFile" $ \dir -> do + let thc = dir "THC.hs" + _ <- openDoc thc "haskell" + expectNoMoreDiagnostics 1 + +-- | test that TH is reevaluated on typecheck +thReloadingTest :: Bool -> TestTree +thReloadingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do + + let aPath = dir "THA.hs" + bPath = dir "THB.hs" + cPath = dir "THC.hs" + + aSource <- liftIO $ readFileUtf8 aPath -- th = [d|a = ()|] + bSource <- liftIO $ readFileUtf8 bPath -- $th + cSource <- liftIO $ readFileUtf8 cPath -- c = a :: () + + adoc <- createDoc aPath "haskell" aSource + bdoc <- createDoc bPath "haskell" bSource + cdoc <- createDoc cPath "haskell" cSource + + expectDiagnostics [("THB.hs", [(DiagnosticSeverity_Warning, (4,1), "Top-level binding")])] + + -- Change th from () to Bool + let aSource' = T.unlines $ init (T.lines aSource) ++ ["th_a = [d| a = False|]"] + changeDoc adoc [TextDocumentContentChangeEvent . InR . (.==) #text $ aSource'] + -- generate an artificial warning to avoid timing out if the TH change does not propagate + changeDoc cdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ cSource <> "\nfoo=()"] + + -- Check that the change propagates to C + expectDiagnostics + [("THC.hs", [(DiagnosticSeverity_Error, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")]) + ,("THC.hs", [(DiagnosticSeverity_Warning, (6,0), "Top-level binding")]) + ,("THB.hs", [(DiagnosticSeverity_Warning, (4,1), "Top-level bindin")]) + ] + + closeDoc adoc + closeDoc bdoc + closeDoc cdoc + where + name = "reloading-th-test" <> if unboxed then "-unboxed" else "" + dir | unboxed = "THUnboxed" + | otherwise = "TH" + +thLinkingTest :: Bool -> TestTree +thLinkingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do + + let aPath = dir "THA.hs" + bPath = dir "THB.hs" + + aSource <- liftIO $ readFileUtf8 aPath -- th_a = [d|a :: ()|] + bSource <- liftIO $ readFileUtf8 bPath -- $th_a + + adoc <- createDoc aPath "haskell" aSource + bdoc <- createDoc bPath "haskell" bSource + + expectDiagnostics [("THB.hs", [(DiagnosticSeverity_Warning, (4,1), "Top-level binding")])] + + let aSource' = T.unlines $ init (init (T.lines aSource)) ++ ["th :: DecsQ", "th = [d| a = False|]"] + changeDoc adoc [TextDocumentContentChangeEvent . InR . (.==) #text $ aSource'] + + -- modify b too + let bSource' = T.unlines $ init (T.lines bSource) ++ ["$th"] + changeDoc bdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ bSource'] + waitForProgressBegin + waitForAllProgressDone + + expectCurrentDiagnostics bdoc [(DiagnosticSeverity_Warning, (4,1), "Top-level binding")] + + closeDoc adoc + closeDoc bdoc + where + name = "th-linking-test" <> if unboxed then "-unboxed" else "" + dir | unboxed = "THUnboxed" + | otherwise = "TH" diff --git a/ghcide/test/exe/TestUtils.hs b/ghcide/test/exe/TestUtils.hs new file mode 100644 --- /dev/null +++ b/ghcide/test/exe/TestUtils.hs @@ -0,0 +1,318 @@ + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} + +module TestUtils where + +import Control.Applicative.Combinators +import Control.Concurrent.Async +import Control.Exception (bracket_, finally) +import Control.Lens ((.~)) +import qualified Control.Lens as Lens +import qualified Control.Lens.Extras as Lens +import Control.Monad +import Control.Monad.IO.Class (liftIO) +import Data.Foldable +import Data.Function ((&)) +import Data.Maybe +import qualified Data.Text as T +import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) +import Development.IDE.GHC.Util +import qualified Development.IDE.Main as IDE +import Development.IDE.Test (canonicalizeUri, + configureCheckProject, + expectNoMoreDiagnostics) +import Development.IDE.Test.Runfiles +import Development.IDE.Types.Location +import Development.Shake (getDirectoryFilesIO) +import Ide.Logger (Recorder, WithPriority, + cmapWithPrio) +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.Directory +import System.Environment.Blank (getEnv, setEnv, unsetEnv) +import System.FilePath +import System.Info.Extra (isMac, isWindows) +import qualified System.IO.Extra +import System.Process.Extra (createPipe) +import Test.Tasty +import Test.Tasty.ExpectedFailure +import Test.Tasty.HUnit + +import LogType + +-- | Wait for the next progress begin step +waitForProgressBegin :: Session () +waitForProgressBegin = skipManyTill anyMessage $ satisfyMaybe $ \case + FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | Lens.is _workDoneProgressBegin v-> Just () + _ -> Nothing + +-- | Wait for the first progress end step +-- Also implemented in hls-test-utils Test.Hls +waitForProgressDone :: Session () +waitForProgressDone = skipManyTill anyMessage $ satisfyMaybe $ \case + FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | Lens.is _workDoneProgressEnd v -> Just () + _ -> Nothing + +-- | Wait for all progress to be done +-- Needs at least one progress done notification to return +-- Also implemented in hls-test-utils Test.Hls +waitForAllProgressDone :: Session () +waitForAllProgressDone = loop + where + loop = do + ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case + FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) |Lens.is _workDoneProgressEnd v-> Just () + _ -> Nothing + done <- null <$> getIncompleteProgressSessions + unless done loop + +run :: Session a -> IO a +run s = run' (const s) + +run' :: (FilePath -> Session a) -> IO a +run' s = withTempDir $ \dir -> runInDir dir (s dir) + +runInDir :: FilePath -> Session a -> IO a +runInDir dir = runInDir' dir "." "." [] + +-- | Takes a directory as well as relative paths to where we should launch the executable as well as the session root. +runInDir' :: FilePath -> FilePath -> FilePath -> [String] -> Session a -> IO a +runInDir' = runInDir'' lspTestCaps + +runInDir'' + :: ClientCapabilities + -> FilePath + -> FilePath + -> FilePath + -> [String] + -> Session b + -> IO b +runInDir'' lspCaps dir startExeIn startSessionIn extraOptions s = do + + ghcideExe <- locateGhcideExecutable + let startDir = dir startExeIn + let projDir = dir startSessionIn + + createDirectoryIfMissing True startDir + createDirectoryIfMissing True projDir + -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56 + -- since the package import test creates "Data/List.hs", which otherwise has no physical home + createDirectoryIfMissing True $ projDir ++ "/Data" + + shakeProfiling <- getEnv "SHAKE_PROFILING" + let cmd = unwords $ + [ghcideExe, "--lsp", "--test", "--verify-core-file", "--verbose", "-j2", "--cwd", startDir + ] ++ ["--shake-profiling=" <> dir | Just dir <- [shakeProfiling] + ] ++ extraOptions + -- HIE calls getXgdDirectory which assumes that HOME is set. + -- Only sets HOME if it wasn't already set. + setEnv "HOME" "/homeless-shelter" False + conf <- getConfigFromEnv + runSessionWithConfig conf cmd lspCaps projDir $ do + configureCheckProject False + s + +-- | Version of 'System.IO.Extra.withTempDir' that canonicalizes the path +-- Which we need to do on macOS since the $TMPDIR can be in @/private/var@ or +-- @/var@ +withTempDir :: (FilePath -> IO a) -> IO a +withTempDir f = System.IO.Extra.withTempDir $ \dir -> do + dir' <- canonicalizePath dir + f dir' + +lspTestCaps :: ClientCapabilities +lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities (Just True) Nothing Nothing } + +getConfigFromEnv :: IO SessionConfig +getConfigFromEnv = do + logColor <- fromMaybe True <$> checkEnv "LSP_TEST_LOG_COLOR" + timeoutOverride <- fmap read <$> getEnv "LSP_TIMEOUT" + return defaultConfig + { messageTimeout = fromMaybe (messageTimeout defaultConfig) timeoutOverride + , logColor + } + where + checkEnv :: String -> IO (Maybe Bool) + checkEnv s = fmap convertVal <$> getEnv s + convertVal "0" = False + convertVal _ = True + +testSessionWait :: HasCallStack => String -> Session () -> TestTree +testSessionWait name = testSession name . + -- Check that any diagnostics produced were already consumed by the test case. + -- + -- If in future we add test cases where we don't care about checking the diagnostics, + -- this could move elsewhere. + -- + -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear. + ( >> expectNoMoreDiagnostics 0.5) + +testSession :: String -> Session () -> TestTree +testSession name = testCase name . run + +xfail :: TestTree -> String -> TestTree +xfail = flip expectFailBecause + +ignoreInWindowsBecause :: String -> TestTree -> TestTree +ignoreInWindowsBecause = ignoreFor (BrokenForOS Windows) + +knownBrokenForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree +knownBrokenForGhcVersions ghcVers = knownBrokenFor (BrokenForGHC ghcVers) + +data BrokenOS = Linux | MacOS | Windows deriving (Show) + +data IssueSolution = Broken | Ignore deriving (Show) + +data BrokenTarget = + BrokenSpecific BrokenOS [GhcVersion] + -- ^Broken for `BrokenOS` with `GhcVersion` + | BrokenForOS BrokenOS + -- ^Broken for `BrokenOS` + | BrokenForGHC [GhcVersion] + -- ^Broken for `GhcVersion` + deriving (Show) + +-- | Ignore test for specific os and ghc with reason. +ignoreFor :: BrokenTarget -> String -> TestTree -> TestTree +ignoreFor = knownIssueFor Ignore + +-- | Known broken for specific os and ghc with reason. +knownBrokenFor :: BrokenTarget -> String -> TestTree -> TestTree +knownBrokenFor = knownIssueFor Broken + +-- | Deal with `IssueSolution` for specific OS and GHC. +knownIssueFor :: IssueSolution -> BrokenTarget -> String -> TestTree -> TestTree +knownIssueFor solution = go . \case + BrokenSpecific bos vers -> isTargetOS bos && isTargetGhc vers + BrokenForOS bos -> isTargetOS bos + BrokenForGHC vers -> isTargetGhc vers + where + isTargetOS = \case + Windows -> isWindows + MacOS -> isMac + Linux -> not isWindows && not isMac + + isTargetGhc = elem ghcVersion + + go True = case solution of + Broken -> expectFailBecause + Ignore -> ignoreTestBecause + go False = const id + +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 + +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 + + + +testSessionWithExtraFiles :: FilePath -> String -> (FilePath -> Session ()) -> TestTree +testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix + +testSession' :: String -> (FilePath -> Session ()) -> TestTree +testSession' name = testCase name . run' + + + +mkRange :: UInt -> UInt -> UInt -> UInt -> Range +mkRange a b c d = Range (Position a b) (Position c d) + + +runWithExtraFiles :: FilePath -> (FilePath -> Session a) -> IO a +runWithExtraFiles prefix s = withTempDir $ \dir -> do + copyTestDataFiles dir prefix + runInDir dir (s dir) + +copyTestDataFiles :: FilePath -> FilePath -> IO () +copyTestDataFiles dir prefix = do + -- Copy all the test data files to the temporary workspace + testDataFiles <- getDirectoryFilesIO ("ghcide/test/data" prefix) ["//*"] + for_ testDataFiles $ \f -> do + createDirectoryIfMissing True $ dir takeDirectory f + copyFile ("ghcide/test/data" prefix f) (dir f) + +withLongTimeout :: IO a -> IO a +withLongTimeout = bracket_ (setEnv "LSP_TIMEOUT" "120" True) (unsetEnv "LSP_TIMEOUT") + + + +lspTestCapsNoFileWatches :: ClientCapabilities +lspTestCapsNoFileWatches = lspTestCaps & L.workspace . Lens._Just . L.didChangeWatchedFiles .~ Nothing + +openTestDataDoc :: FilePath -> Session TextDocumentIdentifier +openTestDataDoc path = do + source <- liftIO $ readFileUtf8 $ "ghcide/test/data" path + createDoc path "haskell" source + +pattern R :: UInt -> UInt -> UInt -> UInt -> Range +pattern R x y x' y' = Range (Position x y) (Position x' y') + +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 + +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)) = [] + +testIde :: Recorder (WithPriority Log) -> IDE.Arguments -> Session () -> IO () +testIde recorder arguments session = do + config <- getConfigFromEnv + cwd <- getCurrentDirectory + (hInRead, hInWrite) <- createPipe + (hOutRead, hOutWrite) <- createPipe + + let server = IDE.defaultMain (cmapWithPrio LogIDEMain recorder) arguments + { IDE.argsHandleIn = pure hInRead + , IDE.argsHandleOut = pure hOutWrite + } + + withTempDir $ \dir -> do + flip finally (setCurrentDirectory cwd) $ withAsync server $ \_ -> + runSessionWithHandles hInWrite hOutRead config lspTestCaps dir session diff --git a/ghcide/test/exe/UnitTests.hs b/ghcide/test/exe/UnitTests.hs new file mode 100644 --- /dev/null +++ b/ghcide/test/exe/UnitTests.hs @@ -0,0 +1,110 @@ + +module UnitTests (tests) where + +import Control.Concurrent +import Control.Monad.IO.Class (liftIO) +import Data.IORef +import Data.IORef.Extra (atomicModifyIORef_) +import Data.List.Extra +import Data.String (IsString (fromString)) +import qualified Data.Text as T +import Development.IDE.Core.FileStore (getModTime) +import qualified Development.IDE.Main as IDE +import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide +import qualified Development.IDE.Types.Diagnostics as Diagnostics +import Development.IDE.Types.Location +import qualified FuzzySearch +import Ide.Logger (Recorder, WithPriority, + cmapWithPrio) +import Ide.PluginUtils (pluginDescToIdePlugins) +import Ide.Types +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +import LogType (Log (..)) +import Network.URI +import qualified Progress +import System.IO.Extra hiding (withTempDir) +import System.Mem (performGC) +import Test.Tasty +import Test.Tasty.ExpectedFailure +import Test.Tasty.HUnit +import TestUtils +import Text.Printf (printf) + +tests :: Recorder (WithPriority Log) -> TestTree +tests recorder = do + testGroup "Unit" + [ testCase "empty file path does NOT work with the empty String literal" $ + uriToFilePath' (fromNormalizedUri $ filePathToUri' "") @?= Just "." + , testCase "empty file path works using toNormalizedFilePath'" $ + uriToFilePath' (fromNormalizedUri $ filePathToUri' (toNormalizedFilePath' "")) @?= Just "" + , testCase "empty path URI" $ do + Just URI{..} <- pure $ parseURI (T.unpack $ getUri $ fromNormalizedUri emptyPathUri) + uriScheme @?= "file:" + uriPath @?= "" + , testCase "from empty path URI" $ do + let uri = Uri "file://" + uriToFilePath' uri @?= Just "" + , testCase "showDiagnostics prints ranges 1-based (like vscode)" $ do + let diag = ("", Diagnostics.ShowDiag, Diagnostic + { _codeDescription = Nothing + , _data_ = Nothing + , _range = Range + { _start = Position{_line = 0, _character = 1} + , _end = Position{_line = 2, _character = 3} + } + , _severity = Nothing + , _code = Nothing + , _source = Nothing + , _message = "" + , _relatedInformation = Nothing + , _tags = Nothing + }) + let shown = T.unpack (Diagnostics.showDiagnostics [diag]) + let expected = "1:2-3:4" + assertBool (unwords ["expected to find range", expected, "in diagnostic", shown]) $ + expected `isInfixOf` shown + , testCase "notification handlers run in priority order" $ do + orderRef <- newIORef [] + let plugins = pluginDescToIdePlugins $ + [ (priorityPluginDescriptor i) + { pluginNotificationHandlers = mconcat + [ mkPluginNotificationHandler SMethod_TextDocumentDidOpen $ \_ _ _ _ -> + liftIO $ atomicModifyIORef_ orderRef (i:) + ] + } + | i <- [1..20] + ] ++ Ghcide.descriptors (cmapWithPrio LogGhcIde recorder) + priorityPluginDescriptor i = (defaultPluginDescriptor (fromString $ show i) ""){pluginPriority = i} + + testIde recorder (IDE.testing (cmapWithPrio LogIDEMain recorder) plugins) $ do + _ <- createDoc "A.hs" "haskell" "module A where" + waitForProgressDone + actualOrder <- liftIO $ reverse <$> readIORef orderRef + + -- Handlers are run in priority descending order + liftIO $ actualOrder @?= [20, 19 .. 1] + , ignoreTestBecause "The test fails sometimes showing 10000us" $ + testCase "timestamps have millisecond resolution" $ do + resolution_us <- findResolution_us 1 + let msg = printf "Timestamps do not have millisecond resolution: %dus" resolution_us + assertBool msg (resolution_us <= 1000) + , Progress.tests + , FuzzySearch.tests + ] + +findResolution_us :: Int -> IO Int +findResolution_us delay_us | delay_us >= 1000000 = error "Unable to compute timestamp resolution" +findResolution_us delay_us = withTempFile $ \f -> withTempFile $ \f' -> do + performGC + writeFile f "" + threadDelay delay_us + writeFile f' "" + t <- getModTime f + t' <- getModTime f' + if t /= t' then return delay_us else findResolution_us (delay_us * 10) diff --git a/ghcide/test/exe/WatchedFileTests.hs b/ghcide/test/exe/WatchedFileTests.hs new file mode 100644 --- /dev/null +++ b/ghcide/test/exe/WatchedFileTests.hs @@ -0,0 +1,83 @@ + +{-# LANGUAGE GADTs #-} + +module WatchedFileTests (tests) where + +import Control.Applicative.Combinators +import Control.Monad.IO.Class (liftIO) +import qualified Data.Aeson as A +import qualified Data.Text as T +import Development.IDE.Test (expectDiagnostics) +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +import System.Directory +import System.FilePath +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + +tests :: TestTree +tests = testGroup "watched files" + [ testGroup "Subscriptions" + [ testSession' "workspace files" $ \sessionDir -> do + liftIO $ writeFile (sessionDir "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"WatchedFilesMissingModule\"]}}" + _doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule" + setIgnoringRegistrationRequests False + watchedFileRegs <- getWatchedFilesSubscriptionsUntil SMethod_TextDocumentPublishDiagnostics + + -- Expect 2 subscriptions: one for all .hs files and one for the hie.yaml cradle + liftIO $ length watchedFileRegs @?= 2 + + , testSession' "non workspace file" $ \sessionDir -> do + tmpDir <- liftIO getTemporaryDirectory + let yaml = "cradle: {direct: {arguments: [\"-i" <> tail(init(show tmpDir)) <> "\", \"A\", \"WatchedFilesMissingModule\"]}}" + liftIO $ writeFile (sessionDir "hie.yaml") yaml + _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule" + setIgnoringRegistrationRequests False + watchedFileRegs <- getWatchedFilesSubscriptionsUntil SMethod_TextDocumentPublishDiagnostics + + -- Expect 2 subscriptions: one for all .hs files and one for the hie.yaml cradle + liftIO $ length watchedFileRegs @?= 2 + + -- TODO add a test for didChangeWorkspaceFolder + ] + , testGroup "Changes" + [ + testSession' "workspace files" $ \sessionDir -> do + liftIO $ writeFile (sessionDir "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"B\"]}}" + liftIO $ writeFile (sessionDir "B.hs") $ unlines + ["module B where" + ,"b :: Bool" + ,"b = False"] + _doc <- createDoc "A.hs" "haskell" $ T.unlines + ["module A where" + ,"import B" + ,"a :: ()" + ,"a = b" + ] + expectDiagnostics [("A.hs", [(DiagnosticSeverity_Error, (3, 4), "Couldn't match expected type '()' with actual type 'Bool'")])] + -- modify B off editor + liftIO $ writeFile (sessionDir "B.hs") $ unlines + ["module B where" + ,"b :: Int" + ,"b = 0"] + sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ + [FileEvent (filePathToUri $ sessionDir "B.hs") FileChangeType_Changed ] + expectDiagnostics [("A.hs", [(DiagnosticSeverity_Error, (3, 4), "Couldn't match expected type '()' with actual type 'Int'")])] + ] + ] + +getWatchedFilesSubscriptionsUntil :: forall m. SServerMethod m -> Session [DidChangeWatchedFilesRegistrationOptions] +getWatchedFilesSubscriptionsUntil m = do + msgs <- manyTill (Just <$> message SMethod_ClientRegisterCapability <|> Nothing <$ anyMessage) (message m) + return + [ x + | Just TRequestMessage{_params = RegistrationParams regs} <- msgs + , Registration _id "workspace/didChangeWatchedFiles" (Just args) <- regs + , Just x@(DidChangeWatchedFilesRegistrationOptions _) <- [A.decode . A.encode $ args] + ] diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -1,7 +1,7 @@ cabal-version: 3.4 category: Development name: haskell-language-server -version: 2.7.0.0 +version: 2.8.0.0 synopsis: LSP server for GHC description: Please see the README on GitHub at @@ -64,7 +64,9 @@ if flag(pedantic) ghc-options: -Werror - -- Note [unused-packages] Some packages need CPP conditioned on MIN_VERSION_ghc(x,y,z). + -- Note [unused-packages] + -- ~~~~~~~~~~~~~~~~~~~~~~ + -- Some packages need CPP conditioned on MIN_VERSION_ghc(x,y,z). -- MIN_VERSION_ is CPP macro that cabal defines only when is declared as a dependency. -- But -Wunused-packages still reports it as unused dependency if it's not imported. -- For packages with such "unused" dependencies we demote -Wunused-packages error @@ -116,14 +118,16 @@ library hls-cabal-fmt-plugin import: defaults, pedantic, warnings + if !flag(cabalfmt) + buildable: False exposed-modules: Ide.Plugin.CabalFmt hs-source-dirs: plugins/hls-cabal-fmt-plugin/src build-depends: , base >=4.12 && <5 , directory , filepath - , ghcide == 2.7.0.0 - , hls-plugin-api == 2.7.0.0 + , ghcide == 2.8.0.0 + , hls-plugin-api == 2.8.0.0 , lens , lsp-types , mtl @@ -132,6 +136,8 @@ test-suite hls-cabal-fmt-plugin-tests import: defaults, pedantic, test-defaults, warnings + if !flag(cabalfmt) + buildable: False type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-cabal-fmt-plugin/test main-is: Main.hs @@ -140,12 +146,68 @@ , directory , filepath , haskell-language-server:hls-cabal-fmt-plugin - , hls-test-utils == 2.7.0.0 + , hls-test-utils == 2.8.0.0 if flag(isolateCabalfmtTests) build-tool-depends: cabal-fmt:cabal-fmt ^>=0.1.6 + cpp-options: -Dhls_isolate_cabalfmt_tests ----------------------------- +-- cabal-gild plugin +----------------------------- + +flag cabalgild + description: Enable cabal-gild plugin + default: True + manual: True + +common cabalgild + if flag(cabalgild) + build-depends: haskell-language-server:hls-cabal-gild-plugin + cpp-options: -Dhls_cabalgild + +flag isolateCabalGildTests + description: Should tests search for 'cabal-gild' on the $PATH or shall we install it via build-tool-depends? + -- By default, search on the PATH + default: False + manual: True + +library hls-cabal-gild-plugin + import: defaults, pedantic, warnings + if !flag(cabalgild) + buildable: False + exposed-modules: Ide.Plugin.CabalGild + hs-source-dirs: plugins/hls-cabal-gild-plugin/src + build-depends: + , base >=4.12 && <5 + , directory + , filepath + , ghcide == 2.8.0.0 + , hls-plugin-api == 2.8.0.0 + , lsp-types + , text + , mtl + , process-extras + +test-suite hls-cabal-gild-plugin-tests + import: defaults, pedantic, test-defaults, warnings + if !flag(cabalgild) + buildable: False + type: exitcode-stdio-1.0 + hs-source-dirs: plugins/hls-cabal-gild-plugin/test + main-is: Main.hs + build-depends: + , base + , directory + , filepath + , haskell-language-server:hls-cabal-gild-plugin + , hls-test-utils == 2.8.0.0 + + if flag(isolateCabalGildTests) + build-tool-depends: cabal-gild:cabal-gild ^>=1.1 + cpp-options: -Dhls_isolate_cabalgild_tests + +----------------------------- -- cabal plugin ----------------------------- @@ -161,6 +223,8 @@ library hls-cabal-plugin import: defaults, pedantic, warnings + if !flag(cabal) + buildable: False exposed-modules: Ide.Plugin.Cabal Ide.Plugin.Cabal.Diagnostics @@ -186,10 +250,10 @@ , directory , filepath , extra >=1.7.4 - , ghcide == 2.7.0.0 + , ghcide == 2.8.0.0 , hashable - , hls-plugin-api == 2.7.0.0 - , hls-graph == 2.7.0.0 + , hls-plugin-api == 2.8.0.0 + , hls-graph == 2.8.0.0 , lens , lsp ^>=2.4 , lsp-types ^>=2.1 @@ -204,6 +268,8 @@ test-suite hls-cabal-plugin-tests import: defaults, pedantic, test-defaults, warnings + if !flag(cabal) + buildable: False type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-cabal-plugin/test main-is: Main.hs @@ -218,7 +284,7 @@ , filepath , ghcide , haskell-language-server:hls-cabal-plugin - , hls-test-utils == 2.7.0.0 + , hls-test-utils == 2.8.0.0 , lens , lsp-types , text @@ -242,6 +308,8 @@ library hls-class-plugin import: defaults, pedantic, warnings + if !flag(class) + buildable: False exposed-modules: Ide.Plugin.Class other-modules: Ide.Plugin.Class.CodeAction , Ide.Plugin.Class.CodeLens @@ -257,9 +325,9 @@ , extra , ghc , ghc-exactprint >= 1.5 - , ghcide == 2.7.0.0 + , ghcide == 2.8.0.0 , hls-graph - , hls-plugin-api == 2.7.0.0 + , hls-plugin-api == 2.8.0.0 , lens , lsp , mtl @@ -272,6 +340,8 @@ test-suite hls-class-plugin-tests import: defaults, pedantic, test-defaults, warnings + if !flag(class) + buildable: False type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-class-plugin/test main-is: Main.hs @@ -279,7 +349,7 @@ , base , filepath , haskell-language-server:hls-class-plugin - , hls-test-utils == 2.7.0.0 + , hls-test-utils == 2.8.0.0 , lens , lsp-types , row-types @@ -301,7 +371,8 @@ library hls-call-hierarchy-plugin import: defaults, pedantic, warnings - buildable: True + if !flag(callHierarchy) + buildable: False exposed-modules: Ide.Plugin.CallHierarchy other-modules: Ide.Plugin.CallHierarchy.Internal @@ -314,9 +385,9 @@ , base >=4.12 && <5 , containers , extra - , ghcide == 2.7.0.0 + , ghcide == 2.8.0.0 , hiedb ^>= 0.6.0.0 - , hls-plugin-api == 2.7.0.0 + , hls-plugin-api == 2.8.0.0 , lens , lsp >=2.4 , sqlite-simple @@ -326,6 +397,8 @@ test-suite hls-call-hierarchy-plugin-tests import: defaults, pedantic, test-defaults, warnings + if !flag(callHierarchy) + buildable: False type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-call-hierarchy-plugin/test main-is: Main.hs @@ -336,7 +409,7 @@ , extra , filepath , haskell-language-server:hls-call-hierarchy-plugin - , hls-test-utils == 2.7.0.0 + , hls-test-utils == 2.8.0.0 , ghcide:ghcide-test-utils , lens , lsp @@ -359,6 +432,8 @@ library hls-eval-plugin import: defaults, pedantic, warnings + if !flag(eval) + buildable: False exposed-modules: Ide.Plugin.Eval Ide.Plugin.Eval.Types @@ -386,9 +461,9 @@ , filepath , ghc , ghc-boot-th - , ghcide == 2.7.0.0 + , ghcide == 2.8.0.0 , hls-graph - , hls-plugin-api == 2.7.0.0 + , hls-plugin-api == 2.8.0.0 , lens , lsp , lsp-types @@ -405,6 +480,8 @@ test-suite hls-eval-plugin-tests import: defaults, pedantic, test-defaults, warnings + if !flag(eval) + buildable: False type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-eval-plugin/test main-is: Main.hs @@ -417,7 +494,7 @@ , filepath , haskell-language-server:hls-eval-plugin , hls-plugin-api - , hls-test-utils == 2.7.0.0 + , hls-test-utils == 2.8.0.0 , lens , lsp-types , text @@ -439,6 +516,8 @@ library hls-explicit-imports-plugin import: defaults, pedantic, warnings + if !flag(importlens) + buildable: False exposed-modules: Ide.Plugin.ExplicitImports hs-source-dirs: plugins/hls-explicit-imports-plugin/src build-depends: @@ -447,9 +526,9 @@ , containers , deepseq , ghc - , ghcide == 2.7.0.0 + , ghcide == 2.8.0.0 , hls-graph - , hls-plugin-api == 2.7.0.0 + , hls-plugin-api == 2.8.0.0 , lens , lsp , mtl @@ -461,6 +540,8 @@ test-suite hls-explicit-imports-plugin-tests import: defaults, pedantic, test-defaults, warnings + if !flag(importlens) + buildable: False type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-explicit-imports-plugin/test main-is: Main.hs @@ -469,7 +550,7 @@ , extra , filepath , haskell-language-server:hls-explicit-imports-plugin - , hls-test-utils == 2.7.0.0 + , hls-test-utils == 2.8.0.0 , lens , lsp-types , row-types @@ -491,16 +572,18 @@ library hls-rename-plugin import: defaults, pedantic, warnings + if !flag(rename) + buildable: False exposed-modules: Ide.Plugin.Rename hs-source-dirs: plugins/hls-rename-plugin/src build-depends: , base >=4.12 && <5 , containers - , ghcide == 2.7.0.0 + , ghcide == 2.8.0.0 , hashable , hiedb ^>= 0.6.0.0 , hie-compat - , hls-plugin-api == 2.7.0.0 + , hls-plugin-api == 2.8.0.0 , haskell-language-server:hls-refactor-plugin , lens , lsp @@ -508,6 +591,7 @@ , mtl , mod , syb + , row-types , text , transformers , unordered-containers @@ -515,6 +599,8 @@ test-suite hls-rename-plugin-tests import: defaults, pedantic, test-defaults, warnings + if !flag(rename) + buildable: False type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-rename-plugin/test main-is: Main.hs @@ -525,7 +611,11 @@ , filepath , hls-plugin-api , haskell-language-server:hls-rename-plugin - , hls-test-utils == 2.7.0.0 + , hls-test-utils == 2.8.0.0 + , lens + , lsp-types + , row-types + , text ----------------------------- -- retrie plugin @@ -543,6 +633,8 @@ library hls-retrie-plugin import: defaults, pedantic, warnings + if !flag(retrie) + buildable: False exposed-modules: Ide.Plugin.Retrie hs-source-dirs: plugins/hls-retrie-plugin/src build-depends: @@ -553,9 +645,9 @@ , directory , extra , ghc - , ghcide == 2.7.0.0 + , ghcide == 2.8.0.0 , hashable - , hls-plugin-api == 2.7.0.0 + , hls-plugin-api == 2.8.0.0 , haskell-language-server:hls-refactor-plugin , lens , lsp @@ -573,6 +665,8 @@ test-suite hls-retrie-plugin-tests import: defaults, pedantic, test-defaults, warnings + if !flag(retrie) + buildable: False type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-retrie-plugin/test main-is: Main.hs @@ -582,25 +676,34 @@ , filepath , hls-plugin-api , haskell-language-server:{hls-refactor-plugin, hls-retrie-plugin} - , hls-test-utils == 2.7.0.0 + , hls-test-utils == 2.8.0.0 , text ----------------------------- -- hlint plugin ----------------------------- +flag ghc-lib + description: + Use ghc-lib-parser rather than the ghc library (requires hlint and + ghc-lib-parser-ex to also be built with it) + default: True + manual: True + flag hlint description: Enable hlint plugin default: True manual: True common hlint - if flag(hlint) && (impl(ghc < 9.8.0) || flag(ignore-plugins-ghc-bounds)) + if flag(hlint) build-depends: haskell-language-server:hls-hlint-plugin cpp-options: -Dhls_hlint library hls-hlint-plugin import: defaults, pedantic, warnings + if !flag(hlint) + buildable: False exposed-modules: Ide.Plugin.Hlint hs-source-dirs: plugins/hls-hlint-plugin/src build-depends: @@ -610,10 +713,10 @@ , containers , deepseq , filepath - , ghcide == 2.7.0.0 + , ghcide == 2.8.0.0 , hashable , hlint >= 3.5 && < 3.9 - , hls-plugin-api == 2.7.0.0 + , hls-plugin-api == 2.8.0.0 , lens , lsp , mtl @@ -624,17 +727,25 @@ , text , transformers , unordered-containers - , ghc-lib-parser , ghc-lib-parser-ex , apply-refact - cpp-options: -DHLINT_ON_GHC_LIB + if flag(ghc-lib) + cpp-options: -DGHC_LIB + build-depends: + ghc-lib-parser + else + build-depends: + ghc + , ghc-boot default-extensions: DataKinds test-suite hls-hlint-plugin-tests import: defaults, pedantic, test-defaults, warnings + if !flag(hlint) + buildable: False type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-hlint-plugin/test main-is: Main.hs @@ -645,7 +756,7 @@ , filepath , haskell-language-server:hls-hlint-plugin , hls-plugin-api - , hls-test-utils == 2.7.0.0 + , hls-test-utils == 2.8.0.0 , lens , lsp-types , row-types @@ -667,7 +778,7 @@ library hls-stan-plugin import: defaults, pedantic, warnings - if (impl(ghc > 8.8.1) && impl(ghc <= 9.2.3) || impl(ghc >= 9.4.0) && impl(ghc < 9.10.0)) + if flag(stan) && (impl(ghc > 8.8.1) && impl(ghc <= 9.2.3) || impl(ghc >= 9.4.0) && impl(ghc < 9.10.0)) buildable: True else buildable: False @@ -695,7 +806,7 @@ test-suite hls-stan-plugin-tests import: defaults, pedantic, test-defaults, warnings - if (impl(ghc > 8.8.1) && impl(ghc <= 9.2.3) || impl(ghc >= 9.4.0) && impl(ghc < 9.10.0)) + if flag(stan) && (impl(ghc > 8.8.1) && impl(ghc <= 9.2.3) || impl(ghc >= 9.4.0) && impl(ghc < 9.10.0)) buildable: True else buildable: False @@ -707,11 +818,11 @@ , filepath , haskell-language-server:hls-stan-plugin , hls-plugin-api - , hls-test-utils == 2.7.0.0 + , hls-test-utils == 2.8.0.0 , lens , lsp-types , text - default-extensions: + default-extensions: OverloadedStrings ----------------------------- @@ -730,6 +841,8 @@ library hls-module-name-plugin import: defaults, pedantic, warnings + if !flag(modulename) + buildable: False exposed-modules: Ide.Plugin.ModuleName hs-source-dirs: plugins/hls-module-name-plugin/src build-depends: @@ -738,8 +851,8 @@ , containers , directory , filepath - , ghcide == 2.7.0.0 - , hls-plugin-api == 2.7.0.0 + , ghcide == 2.8.0.0 + , hls-plugin-api == 2.8.0.0 , lsp , text , transformers @@ -747,6 +860,8 @@ test-suite hls-module-name-plugin-tests import: defaults, pedantic, test-defaults, warnings + if !flag(modulename) + buildable: False type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-module-name-plugin/test main-is: Main.hs @@ -754,7 +869,7 @@ , base , filepath , haskell-language-server:hls-module-name-plugin - , hls-test-utils == 2.7.0.0 + , hls-test-utils == 2.8.0.0 ----------------------------- -- pragmas plugin @@ -772,14 +887,16 @@ library hls-pragmas-plugin import: defaults, pedantic, warnings + if !flag(pragmas) + buildable: False exposed-modules: Ide.Plugin.Pragmas hs-source-dirs: plugins/hls-pragmas-plugin/src build-depends: , base >=4.12 && <5 , extra , fuzzy - , ghcide == 2.7.0.0 - , hls-plugin-api == 2.7.0.0 + , ghcide == 2.8.0.0 + , hls-plugin-api == 2.8.0.0 , lens , lsp , text @@ -788,6 +905,8 @@ test-suite hls-pragmas-plugin-tests import: defaults, pedantic, test-defaults, warnings + if !flag(pragmas) + buildable: False type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-pragmas-plugin/test main-is: Main.hs @@ -796,7 +915,7 @@ , base , filepath , haskell-language-server:hls-pragmas-plugin - , hls-test-utils == 2.7.0.0 + , hls-test-utils == 2.8.0.0 , lens , lsp-types , text @@ -817,6 +936,8 @@ library hls-splice-plugin import: defaults, pedantic, warnings + if !flag(splice) + buildable: False exposed-modules: Ide.Plugin.Splice Ide.Plugin.Splice.Types @@ -829,8 +950,8 @@ , foldl , ghc , ghc-exactprint - , ghcide == 2.7.0.0 - , hls-plugin-api == 2.7.0.0 + , ghcide == 2.8.0.0 + , hls-plugin-api == 2.8.0.0 , haskell-language-server:hls-refactor-plugin , lens , lsp @@ -845,6 +966,8 @@ test-suite hls-splice-plugin-tests import: defaults, pedantic, test-defaults, warnings + if !flag(splice) + buildable: False type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-splice-plugin/test main-is: Main.hs @@ -852,7 +975,7 @@ , base , filepath , haskell-language-server:hls-splice-plugin - , hls-test-utils == 2.7.0.0 + , hls-test-utils == 2.8.0.0 , text , row-types @@ -872,6 +995,8 @@ library hls-alternate-number-format-plugin import: defaults, pedantic, warnings + if !flag(alternateNumberFormat) + buildable: False exposed-modules: Ide.Plugin.AlternateNumberFormat, Ide.Plugin.Conversion other-modules: Ide.Plugin.Literals hs-source-dirs: plugins/hls-alternate-number-format-plugin/src @@ -879,10 +1004,10 @@ , base >=4.12 && < 5 , containers , extra - , ghcide == 2.7.0.0 + , ghcide == 2.8.0.0 , ghc-boot-th , hls-graph - , hls-plugin-api == 2.7.0.0 + , hls-plugin-api == 2.8.0.0 , lens , lsp ^>=2.4 , mtl @@ -897,6 +1022,8 @@ test-suite hls-alternate-number-format-plugin-tests import: defaults, pedantic, test-defaults, warnings + if !flag(alternateNumberFormat) + buildable: False type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-alternate-number-format-plugin/test other-modules: Properties.Conversion @@ -906,7 +1033,7 @@ , base >=4.12 && < 5 , filepath , haskell-language-server:hls-alternate-number-format-plugin - , hls-test-utils == 2.7.0.0 + , hls-test-utils == 2.8.0.0 , regex-tdfa , tasty-quickcheck , text @@ -932,13 +1059,15 @@ library hls-qualify-imported-names-plugin import: defaults, pedantic, warnings + if !flag(qualifyImportedNames) + buildable: False exposed-modules: Ide.Plugin.QualifyImportedNames hs-source-dirs: plugins/hls-qualify-imported-names-plugin/src build-depends: , base >=4.12 && <5 , containers - , ghcide == 2.7.0.0 - , hls-plugin-api == 2.7.0.0 + , ghcide == 2.8.0.0 + , hls-plugin-api == 2.8.0.0 , lens , lsp , text @@ -950,6 +1079,8 @@ test-suite hls-qualify-imported-names-plugin-tests import: defaults, pedantic, test-defaults, warnings + if !flag(qualifyImportedNames) + buildable: False type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-qualify-imported-names-plugin/test main-is: Main.hs @@ -958,7 +1089,7 @@ , text , filepath , haskell-language-server:hls-qualify-imported-names-plugin - , hls-test-utils == 2.7.0.0 + , hls-test-utils == 2.8.0.0 ----------------------------- -- code range plugin @@ -976,6 +1107,8 @@ library hls-code-range-plugin import: defaults, pedantic, warnings + if !flag(codeRange) + buildable: False exposed-modules: Ide.Plugin.CodeRange Ide.Plugin.CodeRange.Rules @@ -987,9 +1120,9 @@ , containers , deepseq , extra - , ghcide == 2.7.0.0 + , ghcide == 2.8.0.0 , hashable - , hls-plugin-api == 2.7.0.0 + , hls-plugin-api == 2.8.0.0 , lens , lsp , mtl @@ -999,6 +1132,8 @@ test-suite hls-code-range-plugin-tests import: defaults, pedantic, test-defaults, warnings + if !flag(codeRange) + buildable: False type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-code-range-plugin/test main-is: Main.hs @@ -1010,7 +1145,7 @@ , bytestring , filepath , haskell-language-server:hls-code-range-plugin - , hls-test-utils == 2.7.0.0 + , hls-test-utils == 2.8.0.0 , lens , lsp , lsp-test @@ -1033,12 +1168,14 @@ library hls-change-type-signature-plugin import: defaults, pedantic, warnings + if !flag(changeTypeSignature) + buildable: False exposed-modules: Ide.Plugin.ChangeTypeSignature hs-source-dirs: plugins/hls-change-type-signature-plugin/src build-depends: , base >=4.12 && < 5 - , ghcide == 2.7.0.0 - , hls-plugin-api == 2.7.0.0 + , ghcide == 2.8.0.0 + , hls-plugin-api == 2.8.0.0 , lsp-types , regex-tdfa , syb @@ -1054,6 +1191,8 @@ test-suite hls-change-type-signature-plugin-tests import: defaults, pedantic, test-defaults, warnings + if !flag(changeTypeSignature) + buildable: False type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-change-type-signature-plugin/test main-is: Main.hs @@ -1061,7 +1200,7 @@ , base >=4.12 && < 5 , filepath , haskell-language-server:hls-change-type-signature-plugin - , hls-test-utils == 2.7.0.0 + , hls-test-utils == 2.8.0.0 , regex-tdfa , text default-extensions: @@ -1084,6 +1223,8 @@ library hls-gadt-plugin import: defaults, pedantic, warnings + if !flag(gadt) + buildable: False exposed-modules: Ide.Plugin.GADT other-modules: Ide.Plugin.GHC hs-source-dirs: plugins/hls-gadt-plugin/src @@ -1093,9 +1234,9 @@ , containers , extra , ghc - , ghcide == 2.7.0.0 + , ghcide == 2.8.0.0 , ghc-exactprint - , hls-plugin-api == 2.7.0.0 + , hls-plugin-api == 2.8.0.0 , haskell-language-server:hls-refactor-plugin , lens , lsp >=2.4 @@ -1107,6 +1248,8 @@ test-suite hls-gadt-plugin-tests import: defaults, pedantic, test-defaults, warnings + if !flag(gadt) + buildable: False type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-gadt-plugin/test main-is: Main.hs @@ -1114,7 +1257,7 @@ , base , filepath , haskell-language-server:hls-gadt-plugin - , hls-test-utils == 2.7.0.0 + , hls-test-utils == 2.8.0.0 , text ----------------------------- @@ -1133,6 +1276,8 @@ library hls-explicit-fixity-plugin import: defaults, pedantic, warnings + if !flag(explicitFixity) + buildable: False exposed-modules: Ide.Plugin.ExplicitFixity hs-source-dirs: plugins/hls-explicit-fixity-plugin/src build-depends: @@ -1140,9 +1285,9 @@ , containers , deepseq , extra - , ghcide == 2.7.0.0 + , ghcide == 2.8.0.0 , hashable - , hls-plugin-api == 2.7.0.0 + , hls-plugin-api == 2.8.0.0 , lsp >=2.4 , text @@ -1150,6 +1295,8 @@ test-suite hls-explicit-fixity-plugin-tests import: defaults, pedantic, test-defaults, warnings + if !flag(explicitFixity) + buildable: False type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-explicit-fixity-plugin/test main-is: Main.hs @@ -1157,7 +1304,7 @@ , base , filepath , haskell-language-server:hls-explicit-fixity-plugin - , hls-test-utils == 2.7.0.0 + , hls-test-utils == 2.8.0.0 , text ----------------------------- @@ -1176,11 +1323,13 @@ library hls-explicit-record-fields-plugin import: defaults, pedantic, warnings + if !flag(explicitFields) + buildable: False exposed-modules: Ide.Plugin.ExplicitFields build-depends: , base >=4.12 && <5 - , ghcide == 2.7.0.0 - , hls-plugin-api == 2.7.0.0 + , ghcide == 2.8.0.0 + , hls-plugin-api == 2.8.0.0 , lsp , lens , hls-graph @@ -1196,6 +1345,8 @@ test-suite hls-explicit-record-fields-plugin-tests import: defaults, pedantic, test-defaults, warnings + if !flag(explicitFields) + buildable: False type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-explicit-record-fields-plugin/test main-is: Main.hs @@ -1204,7 +1355,7 @@ , filepath , text , haskell-language-server:hls-explicit-record-fields-plugin - , hls-test-utils == 2.7.0.0 + , hls-test-utils == 2.8.0.0 ----------------------------- -- overloaded record dot plugin @@ -1222,6 +1373,8 @@ library hls-overloaded-record-dot-plugin import: defaults, pedantic, warnings + if !flag(overloadedRecordDot) + buildable: False exposed-modules: Ide.Plugin.OverloadedRecordDot build-depends: , base >=4.16 && <5 @@ -1240,6 +1393,8 @@ test-suite hls-overloaded-record-dot-plugin-tests import: defaults, pedantic, test-defaults, warnings + if !flag(overloadedRecordDot) + buildable: False type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-overloaded-record-dot-plugin/test main-is: Main.hs @@ -1248,7 +1403,7 @@ , filepath , text , haskell-language-server:hls-overloaded-record-dot-plugin - , hls-test-utils == 2.7.0.0 + , hls-test-utils == 2.8.0.0 ----------------------------- @@ -1261,19 +1416,21 @@ manual: True common floskell - if flag(floskell) && (impl(ghc < 9.7) || flag(ignore-plugins-ghc-bounds)) + if flag(floskell) build-depends: haskell-language-server:hls-floskell-plugin cpp-options: -Dhls_floskell library hls-floskell-plugin import: defaults, pedantic, warnings + if !flag(floskell) + buildable: False exposed-modules: Ide.Plugin.Floskell hs-source-dirs: plugins/hls-floskell-plugin/src build-depends: , base >=4.12 && <5 , floskell ^>=0.11.0 - , ghcide == 2.7.0.0 - , hls-plugin-api == 2.7.0.0 + , ghcide == 2.8.0.0 + , hls-plugin-api == 2.8.0.0 , lsp-types ^>=2.1 , mtl , text @@ -1281,6 +1438,8 @@ test-suite hls-floskell-plugin-tests import: defaults, pedantic, test-defaults, warnings + if !flag(floskell) + buildable: False type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-floskell-plugin/test main-is: Main.hs @@ -1288,7 +1447,7 @@ , base , filepath , haskell-language-server:hls-floskell-plugin - , hls-test-utils == 2.7.0.0 + , hls-test-utils == 2.8.0.0 ----------------------------- -- fourmolu plugin @@ -1306,6 +1465,8 @@ library hls-fourmolu-plugin import: defaults, pedantic, warnings + if !flag(fourmolu) + buildable: False exposed-modules: Ide.Plugin.Fourmolu hs-source-dirs: plugins/hls-fourmolu-plugin/src build-depends: @@ -1313,8 +1474,8 @@ , filepath , fourmolu ^>= 0.14 || ^>= 0.15 , ghc-boot-th - , ghcide == 2.7.0.0 - , hls-plugin-api == 2.7.0.0 + , ghcide == 2.8.0.0 + , hls-plugin-api == 2.8.0.0 , lens , lsp , mtl @@ -1325,6 +1486,8 @@ test-suite hls-fourmolu-plugin-tests import: defaults, pedantic, test-defaults, warnings + if !flag(fourmolu) + buildable: False type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-fourmolu-plugin/test main-is: Main.hs @@ -1336,7 +1499,7 @@ , filepath , haskell-language-server:hls-fourmolu-plugin , hls-plugin-api - , hls-test-utils == 2.7.0.0 + , hls-test-utils == 2.8.0.0 , lsp-test ----------------------------- @@ -1355,6 +1518,8 @@ library hls-ormolu-plugin import: defaults, pedantic, warnings + if !flag(ormolu) + buildable: False exposed-modules: Ide.Plugin.Ormolu hs-source-dirs: plugins/hls-ormolu-plugin/src build-depends: @@ -1362,8 +1527,8 @@ , extra , filepath , ghc-boot-th - , ghcide == 2.7.0.0 - , hls-plugin-api == 2.7.0.0 + , ghcide == 2.8.0.0 + , hls-plugin-api == 2.8.0.0 , lsp , mtl , process-extras >= 0.7.1 @@ -1374,6 +1539,8 @@ test-suite hls-ormolu-plugin-tests import: defaults, pedantic, test-defaults, warnings + if !flag(ormolu) + buildable: False type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-ormolu-plugin/test main-is: Main.hs @@ -1385,7 +1552,7 @@ , filepath , haskell-language-server:hls-ormolu-plugin , hls-plugin-api - , hls-test-utils == 2.7.0.0 + , hls-test-utils == 2.8.0.0 , lsp-types , ormolu @@ -1399,12 +1566,14 @@ manual: True common stylishHaskell - if flag(stylishHaskell) && (impl(ghc < 9.8.0) || flag(ignore-plugins-ghc-bounds)) + if flag(stylishHaskell) build-depends: haskell-language-server:hls-stylish-haskell-plugin cpp-options: -Dhls_stylishHaskell library hls-stylish-haskell-plugin import: defaults, pedantic, warnings + if !flag(stylishHaskell) + buildable: False exposed-modules: Ide.Plugin.StylishHaskell hs-source-dirs: plugins/hls-stylish-haskell-plugin/src build-depends: @@ -1412,16 +1581,18 @@ , directory , filepath , ghc-boot-th - , ghcide == 2.7.0.0 - , hls-plugin-api == 2.7.0.0 + , ghcide == 2.8.0.0 + , hls-plugin-api == 2.8.0.0 , lsp-types , mtl - , stylish-haskell ^>=0.12 || ^>=0.13 || ^>=0.14.2 + , stylish-haskell ^>=0.12 || ^>=0.13 || ^>=0.14 , text test-suite hls-stylish-haskell-plugin-tests import: defaults, pedantic, test-defaults, warnings + if !flag(stylishHaskell) + buildable: False type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-stylish-haskell-plugin/test main-is: Main.hs @@ -1429,7 +1600,7 @@ , base , filepath , haskell-language-server:hls-stylish-haskell-plugin - , hls-test-utils == 2.7.0.0 + , hls-test-utils == 2.8.0.0 ----------------------------- -- refactor plugin @@ -1447,6 +1618,8 @@ library hls-refactor-plugin import: defaults, pedantic, warnings + if !flag(refactor) + buildable: False exposed-modules: Development.IDE.GHC.ExactPrint Development.IDE.GHC.Compat.ExactPrint Development.IDE.Plugin.CodeAction @@ -1480,8 +1653,8 @@ , bytestring , ghc-boot , regex-tdfa - , ghcide == 2.7.0.0 - , hls-plugin-api == 2.7.0.0 + , ghcide == 2.8.0.0 + , hls-plugin-api == 2.8.0.0 , lsp , text , transformers @@ -1504,6 +1677,8 @@ test-suite hls-refactor-plugin-tests import: defaults, pedantic, test-defaults, warnings + if !flag(refactor) + buildable: False type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-refactor-plugin/test main-is: Main.hs @@ -1513,7 +1688,7 @@ , base , filepath , haskell-language-server:hls-refactor-plugin - , hls-test-utils == 2.7.0.0 + , hls-test-utils == 2.8.0.0 , lens , lsp-types , text @@ -1547,7 +1722,8 @@ library hls-semantic-tokens-plugin import: defaults, pedantic, warnings - buildable: True + if !flag(semanticTokens) + buildable: False exposed-modules: Ide.Plugin.SemanticTokens Ide.Plugin.SemanticTokens.Types @@ -1566,8 +1742,8 @@ , extra , text-rope , mtl >= 2.2 - , ghcide == 2.7.0.0 - , hls-plugin-api == 2.7.0.0 + , ghcide == 2.8.0.0 + , hls-plugin-api == 2.8.0.0 , lens , lsp >=2.4 , text @@ -1577,7 +1753,7 @@ , array , deepseq , dlist - , hls-graph == 2.7.0.0 + , hls-graph == 2.8.0.0 , template-haskell , data-default , stm @@ -1587,6 +1763,8 @@ test-suite hls-semantic-tokens-plugin-tests import: defaults, pedantic, test-defaults, warnings + if !flag(semanticTokens) + buildable: False type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-semantic-tokens-plugin/test main-is: SemanticTokensTest.hs @@ -1597,7 +1775,7 @@ , containers , filepath , haskell-language-server:hls-semantic-tokens-plugin - , hls-test-utils == 2.7.0.0 + , hls-test-utils == 2.8.0.0 , ghcide:ghcide-test-utils , hls-plugin-api , lens @@ -1606,11 +1784,69 @@ , lsp-test , text , data-default - , ghcide == 2.7.0.0 - , hls-plugin-api == 2.7.0.0 + , ghcide == 2.8.0.0 + , hls-plugin-api == 2.8.0.0 , data-default , row-types +----------------------------- +-- notes plugin +----------------------------- + +flag notes + description: Enable notes plugin + default: True + manual: True + +common notes + if flag(notes) + build-depends: haskell-language-server:hls-notes-plugin + cpp-options: -Dhls_notes + +library hls-notes-plugin + import: defaults, pedantic, warnings + if !flag(notes) + buildable: False + exposed-modules: + Ide.Plugin.Notes + hs-source-dirs: plugins/hls-notes-plugin/src + build-depends: + , base >=4.12 && <5 + , array + , ghcide == 2.8.0.0 + , hls-graph == 2.8.0.0 + , hls-plugin-api == 2.8.0.0 + , lens + , lsp >=2.4 + , mtl >= 2.2 + , regex-tdfa >= 1.3.1 + , text + , text-rope + , unordered-containers + default-extensions: + DataKinds + , DeriveAnyClass + , DerivingStrategies + , OverloadedStrings + , LambdaCase + , TypeFamilies + +test-suite hls-notes-plugin-tests + import: defaults, pedantic, test-defaults, warnings + if !flag(notes) + buildable: False + type: exitcode-stdio-1.0 + hs-source-dirs: plugins/hls-notes-plugin/test + main-is: NotesTest.hs + build-depends: + , base + , directory + , filepath + , ghcide:ghcide-test-utils + , haskell-language-server:hls-notes-plugin + , hls-test-utils == 2.8.0.0 + default-extensions: OverloadedStrings + ---------------------------- ---------------------------- -- HLS @@ -1625,6 +1861,7 @@ , cabal , callHierarchy , cabalfmt + , cabalgild , changeTypeSignature , class , eval @@ -1649,6 +1886,7 @@ , refactor , overloadedRecordDot , semanticTokens + , notes exposed-modules: Ide.Arguments @@ -1667,10 +1905,10 @@ , extra , filepath , ghc - , ghcide == 2.7.0.0 + , ghcide == 2.8.0.0 , githash >=0.1.6.1 , hie-bios - , hls-plugin-api == 2.7.0.0 + , hls-plugin-api == 2.8.0.0 , optparse-applicative , optparse-simple , prettyprinter >= 1.7 @@ -1777,7 +2015,7 @@ , ghcide:{ghcide, ghcide-test-utils} , hashable , hls-plugin-api - , hls-test-utils == 2.7.0.0 + , hls-test-utils == 2.8.0.0 , lens , lsp-test , lsp-types @@ -1822,7 +2060,7 @@ build-depends: , base >=4.16 && <5 , extra - , hls-test-utils == 2.7.0.0 + , hls-test-utils == 2.8.0.0 , process hs-source-dirs: test/wrapper @@ -1831,8 +2069,6 @@ benchmark benchmark import: defaults, warnings -- Depends on shake-bench which is unbuildable after this point - if impl(ghc >= 9.5) - buildable: False type: exitcode-stdio-1.0 ghc-options: -threaded main-is: Main.hs @@ -1840,7 +2076,6 @@ build-tool-depends: ghcide-bench:ghcide-bench, hp2pretty:hp2pretty, - implicit-hie:gen-hie default-extensions: LambdaCase RecordWildCards @@ -1863,3 +2098,104 @@ , shake-bench == 0.2.* , text , yaml + + +test-suite ghcide-tests + import: warnings + type: exitcode-stdio-1.0 + default-language: GHC2021 + build-tool-depends: + , ghcide:ghcide + , ghcide:ghcide-test-preprocessor + , implicit-hie:gen-hie + + build-depends: + , aeson + , async + , base + , containers + , data-default + , directory + , enummapset + , extra + , filepath + , fuzzy + , ghcide + , ghcide:ghcide-test-utils + , hls-plugin-api + , lens + , list-t + , lsp + , lsp-test ^>=0.17.0.0 + , lsp-types + , monoid-subclasses + , mtl + , network-uri + , QuickCheck + , random + , regex-tdfa ^>=1.3.1 + , row-types + , shake + , sqlite-simple + , stm + , stm-containers + , tasty + , tasty-expected-failure + , tasty-hunit >=0.10 + , tasty-quickcheck + , tasty-rerun + , text + , text-rope + , unordered-containers + , hls-test-utils == 2.8.0.0 + + if impl(ghc <9.3) + build-depends: ghc-typelits-knownnat + + hs-source-dirs: ghcide/test/exe + ghc-options: -threaded -O0 + + main-is: Main.hs + other-modules: + Config + AsyncTests + BootTests + ClientSettingsTests + CodeLensTests + CompletionTests + CPPTests + CradleTests + DependentFileTest + DiagnosticTests + ExceptionTests + FindDefinitionAndHoverTests + FuzzySearch + GarbageCollectionTests + HaddockTests + HieDbRetry + HighlightTests + IfaceTests + InitializeResponseTests + LogType + NonLspCommandLine + OpenCloseTest + OutlineTests + PluginSimpleTests + PositionMappingTests + PreprocessorTests + Progress + ReferenceTests + RootUriTests + SafeTests + SymlinkTests + TestUtils + THTests + UnitTests + WatchedFileTests + + -- Tests that have been pulled out of the main file + default-extensions: + LambdaCase + OverloadedStrings + RecordWildCards + ViewPatterns diff --git a/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs --- a/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs +++ b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs @@ -112,7 +112,7 @@ mkWorkspaceEdit :: NormalizedFilePath -> [TextEdit] -> WorkspaceEdit mkWorkspaceEdit nfp edits = WorkspaceEdit changes Nothing Nothing where - changes = Just $ Map.fromList [(filePathToUri $ fromNormalizedFilePath nfp, edits)] + changes = Just $ Map.singleton (filePathToUri $ fromNormalizedFilePath nfp) edits mkCodeActionTitle :: Literal -> AlternateFormat -> [GhcExtension] -> Text mkCodeActionTitle lit (alt, ext) ghcExts diff --git a/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/Conversion.hs b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/Conversion.hs --- a/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/Conversion.hs +++ b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/Conversion.hs @@ -160,9 +160,9 @@ | otherwise = header <> upper (conv n "") #if MIN_VERSION_base(4,17,0) -toOctal, toDecimal, toBinary, toHex :: Integral a => a -> String +toOctal, toBinary, toHex :: Integral a => a -> String #else -toOctal, toDecimal, toBinary, toHex:: (Integral a, Show a) => a -> String +toOctal, toBinary, toHex:: (Integral a, Show a) => a -> String #endif toBinary = toBase showBin_ "0b" @@ -172,9 +172,10 @@ toOctal = toBase showOct "0o" -toDecimal = toBase showInt "" - toHex = toBase showHex "0x" + +toDecimal :: Integral a => a -> String +toDecimal = toBase showInt "" toFloatDecimal :: RealFloat a => a -> String toFloatDecimal val = showFFloat Nothing val "" diff --git a/plugins/hls-cabal-fmt-plugin/src/Ide/Plugin/CabalFmt.hs b/plugins/hls-cabal-fmt-plugin/src/Ide/Plugin/CabalFmt.hs --- a/plugins/hls-cabal-fmt-plugin/src/Ide/Plugin/CabalFmt.hs +++ b/plugins/hls-cabal-fmt-plugin/src/Ide/Plugin/CabalFmt.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} module Ide.Plugin.CabalFmt where @@ -9,6 +11,7 @@ import qualified Data.Text as T import Development.IDE hiding (pluginHandlers) import Ide.Plugin.Error (PluginError (PluginInternalError, PluginInvalidParams)) +import Ide.Plugin.Properties import Ide.PluginUtils import Ide.Types import qualified Language.LSP.Protocol.Lens as L @@ -24,7 +27,7 @@ = LogProcessInvocationFailure Int | LogReadCreateProcessInfo T.Text [String] | LogInvalidInvocationInfo - | LogCabalFmtNotFound + | LogFormatterBinNotFound FilePath deriving (Show) instance Pretty Log where @@ -35,29 +38,39 @@ ["Invocation of cabal-fmt with arguments" <+> pretty args] ++ ["failed with standard error:" <+> pretty stdErrorOut | not (T.null stdErrorOut)] LogInvalidInvocationInfo -> "Invocation of cabal-fmt with range was called but is not supported." - LogCabalFmtNotFound -> "Couldn't find executable 'cabal-fmt'" + LogFormatterBinNotFound fp -> "Couldn't find formatter executable 'cabal-fmt' at:" <+> pretty fp descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultCabalPluginDescriptor plId "Provides formatting of cabal files with cabal-fmt") - { pluginHandlers = mkFormattingHandlers (provider recorder) + { pluginHandlers = mkFormattingHandlers (provider recorder plId) + , pluginConfigDescriptor = defaultConfigDescriptor{configCustomConfig = mkCustomConfig properties} } +properties :: Properties '[ 'PropertyKey "path" 'TString] +properties = + emptyProperties + & defineStringProperty + #path + "Set path to 'cabal-fmt' executable" + "cabal-fmt" + -- | Formatter provider of cabal fmt. -- Formats the given source in either a given Range or the whole Document. -- If the provider fails an error is returned that can be displayed to the user. -provider :: Recorder (WithPriority Log) -> FormattingHandler IdeState -provider recorder _ _ (FormatRange _) _ _ _ = do +provider :: Recorder (WithPriority Log) -> PluginId -> FormattingHandler IdeState +provider recorder _ _ _ (FormatRange _) _ _ _ = do logWith recorder Info LogInvalidInvocationInfo throwError $ PluginInvalidParams "You cannot format a text-range using cabal-fmt." -provider recorder _ide _ FormatText contents nfp opts = do +provider recorder plId ideState _ FormatText contents nfp opts = do let cabalFmtArgs = [ "--indent", show tabularSize] - x <- liftIO $ findExecutable "cabal-fmt" + cabalFmtExePath <- fmap T.unpack $ liftIO $ runAction "cabal-gild" ideState $ usePropertyAction #path plId properties + x <- liftIO $ findExecutable cabalFmtExePath case x of Just _ -> do (exitCode, out, err) <- liftIO $ Process.readCreateProcessWithExitCode - ( proc "cabal-fmt" cabalFmtArgs + ( proc cabalFmtExePath cabalFmtArgs ) { cwd = Just $ takeDirectory fp } @@ -71,8 +84,8 @@ let fmtDiff = makeDiffTextEdit contents out pure $ InL fmtDiff Nothing -> do - log Error LogCabalFmtNotFound - throwError (PluginInternalError "No installation of cabal-fmt could be found. Please install it into your global environment.") + log Error $ LogFormatterBinNotFound cabalFmtExePath + throwError (PluginInternalError "No installation of cabal-gild could be found. Please install it globally, or provide the full path to the executable") where fp = fromNormalizedFilePath nfp tabularSize = opts ^. L.tabSize diff --git a/plugins/hls-cabal-fmt-plugin/test/Main.hs b/plugins/hls-cabal-fmt-plugin/test/Main.hs --- a/plugins/hls-cabal-fmt-plugin/test/Main.hs +++ b/plugins/hls-cabal-fmt-plugin/test/Main.hs @@ -12,7 +12,7 @@ data CabalFmtFound = Found | NotFound isTestIsolated :: Bool -#if isolateTests +#if hls_isolate_cabalfmt_tests isTestIsolated = True #else isTestIsolated = False @@ -21,7 +21,7 @@ isCabalFmtFound :: IO CabalFmtFound isCabalFmtFound = case isTestIsolated of True -> pure Found - False-> do + False -> do cabalFmt <- findExecutable "cabal-fmt" pure $ maybe NotFound (const Found) cabalFmt @@ -51,7 +51,7 @@ cabalFmtGolden NotFound title _ _ _ = testCase title $ assertFailure $ "Couldn't find cabal-fmt on PATH or this is not an isolated run. " - <> "Use cabal flag 'isolateTests' to make it isolated or install cabal-fmt locally." + <> "Use cabal flag 'isolateCabalFmtTests' to make it isolated or install cabal-fmt locally." cabalFmtGolden Found title path desc act = goldenWithCabalDocFormatter def cabalFmtPlugin "cabal-fmt" conf title testDataDir path desc "cabal" act where conf = def diff --git a/plugins/hls-cabal-gild-plugin/src/Ide/Plugin/CabalGild.hs b/plugins/hls-cabal-gild-plugin/src/Ide/Plugin/CabalGild.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-gild-plugin/src/Ide/Plugin/CabalGild.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} + +module Ide.Plugin.CabalGild where + +import Control.Monad.Except (throwError) +import Control.Monad.IO.Class +import qualified Data.Text as T +import Development.IDE hiding (pluginHandlers) +import Ide.Plugin.Error (PluginError (PluginInternalError, PluginInvalidParams)) +import Ide.Plugin.Properties +import Ide.PluginUtils +import Ide.Types +import Language.LSP.Protocol.Types +import Prelude hiding (log) +import System.Directory +import System.Exit +import System.FilePath +import System.Process.ListLike +import qualified System.Process.Text as Process + +data Log + = LogProcessInvocationFailure Int T.Text + | LogReadCreateProcessInfo [String] + | LogInvalidInvocationInfo + | LogFormatterBinNotFound FilePath + deriving (Show) + +instance Pretty Log where + pretty = \case + LogProcessInvocationFailure exitCode err -> + vcat + [ "Invocation of cabal-gild failed with code" <+> pretty exitCode + , "Stderr:" <+> pretty err + ] + LogReadCreateProcessInfo args -> + "Formatter invocation: cabal-gild " <+> pretty args + LogInvalidInvocationInfo -> "Invocation of cabal-gild with range was called but is not supported." + LogFormatterBinNotFound fp -> "Couldn't find formatter executable 'cabal-gild' at:" <+> pretty fp + +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = + (defaultCabalPluginDescriptor plId "Provides formatting of cabal files with cabal-gild") + { pluginHandlers = mkFormattingHandlers (provider recorder plId) + , pluginConfigDescriptor = defaultConfigDescriptor{configCustomConfig = mkCustomConfig properties} + } + +properties :: Properties '[ 'PropertyKey "path" 'TString] +properties = + emptyProperties + & defineStringProperty + #path + "Set path to 'cabal-gild' executable" + "cabal-gild" + +-- | Formatter provider of cabal gild. +-- Formats the given source in either a given Range or the whole Document. +-- If the provider fails an error is returned that can be displayed to the user. +provider :: Recorder (WithPriority Log) -> PluginId -> FormattingHandler IdeState +provider recorder _ _ _ (FormatRange _) _ _ _ = do + logWith recorder Info LogInvalidInvocationInfo + throwError $ PluginInvalidParams "You cannot format a text-range using cabal-gild." +provider recorder plId ideState _ FormatText contents nfp _ = do + let cabalGildArgs = ["--stdin=" <> fp, "--input=-"] -- < Read from stdin + + cabalGildExePath <- fmap T.unpack $ liftIO $ runAction "cabal-gild" ideState $ usePropertyAction #path plId properties + x <- liftIO $ findExecutable cabalGildExePath + case x of + Just _ -> do + log Debug $ LogReadCreateProcessInfo cabalGildArgs + (exitCode, out, err) <- + liftIO $ Process.readCreateProcessWithExitCode + ( proc cabalGildExePath cabalGildArgs + ) + { cwd = Just $ takeDirectory fp + } + contents + case exitCode of + ExitFailure code -> do + log Error $ LogProcessInvocationFailure code err + throwError (PluginInternalError "Failed to invoke cabal-gild") + ExitSuccess -> do + let fmtDiff = makeDiffTextEdit contents out + pure $ InL fmtDiff + Nothing -> do + log Error $ LogFormatterBinNotFound cabalGildExePath + throwError (PluginInternalError "No installation of cabal-gild could be found. Please install it globally, or provide the full path to the executable.") + where + fp = fromNormalizedFilePath nfp + log = logWith recorder diff --git a/plugins/hls-cabal-gild-plugin/test/Main.hs b/plugins/hls-cabal-gild-plugin/test/Main.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-gild-plugin/test/Main.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +module Main + ( main + ) where + +import qualified Ide.Plugin.CabalGild as CabalGild +import System.Directory (findExecutable) +import System.FilePath +import Test.Hls + +data CabalGildFound = Found | NotFound + +isTestIsolated :: Bool +#if hls_isolate_cabalgild_tests +isTestIsolated = True +#else +isTestIsolated = False +#endif + +isCabalFmtFound :: IO CabalGildFound +isCabalFmtFound = case isTestIsolated of + True -> pure Found + False -> do + cabalGild <- findExecutable "cabal-gild" + pure $ maybe NotFound (const Found) cabalGild + +main :: IO () +main = do + foundCabalFmt <- isCabalFmtFound + defaultTestRunner (tests foundCabalFmt) + +cabalGildPlugin :: PluginTestDescriptor CabalGild.Log +cabalGildPlugin = mkPluginTestDescriptor CabalGild.descriptor "cabal-gild" + +tests :: CabalGildFound -> TestTree +tests found = testGroup "cabal-gild" + [ cabalGildGolden found "formats a simple document" "simple_testdata" "formatted_document" $ \doc -> do + formatDoc doc (FormattingOptions 2 True Nothing Nothing Nothing) + + , cabalGildGolden found "formats a document with expand:src comment" "commented_testdata" "formatted_document" $ \doc -> do + formatDoc doc (FormattingOptions 2 True Nothing Nothing Nothing) + + , cabalGildGolden found "formats a document with lib information" "lib_testdata" "formatted_document" $ \doc -> do + formatDoc doc (FormattingOptions 10 True Nothing Nothing Nothing) + ] + +cabalGildGolden :: CabalGildFound -> TestName -> FilePath -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree +cabalGildGolden NotFound title _ _ _ = + testCase title $ + assertFailure $ "Couldn't find cabal-gild on PATH or this is not an isolated run. " + <> "Use cabal flag 'isolateCabalGildTests' to make it isolated or install cabal-gild locally." +cabalGildGolden Found title path desc act = goldenWithCabalDocFormatter def cabalGildPlugin "cabal-gild" conf title testDataDir path desc "cabal" act + where + conf = def + +testDataDir :: FilePath +testDataDir = "plugins" "hls-cabal-gild-plugin" "test" "testdata" diff --git a/plugins/hls-cabal-gild-plugin/test/testdata/commented_testdata.cabal b/plugins/hls-cabal-gild-plugin/test/testdata/commented_testdata.cabal new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-gild-plugin/test/testdata/commented_testdata.cabal @@ -0,0 +1,12 @@ +cabal-version: 2.4 +name: testdata +version: 0.1.0.0 +author: Banana +extra-source-files: CHANGELOG.md + +library + -- cabal-gild: discover src + exposed-modules: MyLib + build-depends: base ^>=4.14.1.0 + hs-source-dirs: src + default-language: Haskell2010 diff --git a/plugins/hls-cabal-gild-plugin/test/testdata/commented_testdata.formatted_document.cabal b/plugins/hls-cabal-gild-plugin/test/testdata/commented_testdata.formatted_document.cabal new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-gild-plugin/test/testdata/commented_testdata.formatted_document.cabal @@ -0,0 +1,15 @@ +cabal-version: 2.4 +name: testdata +version: 0.1.0.0 +author: Banana +extra-source-files: CHANGELOG.md + +library + -- cabal-gild: discover src + exposed-modules: + MyLib + MyOtherLib + + build-depends: base ^>=4.14.1.0 + hs-source-dirs: src + default-language: Haskell2010 diff --git a/plugins/hls-cabal-gild-plugin/test/testdata/hie.yaml b/plugins/hls-cabal-gild-plugin/test/testdata/hie.yaml new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-gild-plugin/test/testdata/hie.yaml @@ -0,0 +1,3 @@ +cradle: + direct: + arguments: [] diff --git a/plugins/hls-cabal-gild-plugin/test/testdata/lib_testdata.cabal b/plugins/hls-cabal-gild-plugin/test/testdata/lib_testdata.cabal new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-gild-plugin/test/testdata/lib_testdata.cabal @@ -0,0 +1,19 @@ +cabal-version: 2.4 +name: testdata +version: 0.1.0.0 +author: Gregg +extra-source-files: CHANGELOG.md + +library + exposed-modules: MyLib + build-depends: base ^>=4.14.1.0 + hs-source-dirs: src + default-language: Haskell2010 + +executable testdata + main-is: Main.hs + build-depends: + base ^>=4.14.1.0,testdata + hs-source-dirs: app + default-language: + Haskell2010 diff --git a/plugins/hls-cabal-gild-plugin/test/testdata/lib_testdata.formatted_document.cabal b/plugins/hls-cabal-gild-plugin/test/testdata/lib_testdata.formatted_document.cabal new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-gild-plugin/test/testdata/lib_testdata.formatted_document.cabal @@ -0,0 +1,20 @@ +cabal-version: 2.4 +name: testdata +version: 0.1.0.0 +author: Gregg +extra-source-files: CHANGELOG.md + +library + exposed-modules: MyLib + build-depends: base ^>=4.14.1.0 + hs-source-dirs: src + default-language: Haskell2010 + +executable testdata + main-is: Main.hs + build-depends: + base ^>=4.14.1.0, + testdata, + + hs-source-dirs: app + default-language: Haskell2010 diff --git a/plugins/hls-cabal-gild-plugin/test/testdata/simple_testdata.cabal b/plugins/hls-cabal-gild-plugin/test/testdata/simple_testdata.cabal new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-gild-plugin/test/testdata/simple_testdata.cabal @@ -0,0 +1,36 @@ +cabal-version: 2.4 +name: testdata +version: 0.1.0.0 + +-- A short (one-line) description of the package. +-- synopsis: + +-- A longer description of the package. +-- description: + +-- A URL where users can report bugs. +-- bug-reports: + +-- The license under which the package is released. +-- license: +author: Milky + +-- An email address to which users can send suggestions, bug reports, and patches. +-- maintainer: + +-- A copyright notice. +-- copyright: +-- category: +extra-source-files: CHANGELOG.md + +executable testdata + main-is: Main.hs + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + build-depends: base ^>=4.14.1.0 + hs-source-dirs: app + default-language: Haskell2010 diff --git a/plugins/hls-cabal-gild-plugin/test/testdata/simple_testdata.formatted_document.cabal b/plugins/hls-cabal-gild-plugin/test/testdata/simple_testdata.formatted_document.cabal new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-gild-plugin/test/testdata/simple_testdata.formatted_document.cabal @@ -0,0 +1,28 @@ +cabal-version: 2.4 +name: testdata +version: 0.1.0.0 +-- A short (one-line) description of the package. +-- synopsis: +-- A longer description of the package. +-- description: +-- A URL where users can report bugs. +-- bug-reports: +-- The license under which the package is released. +-- license: +author: Milky +-- An email address to which users can send suggestions, bug reports, and patches. +-- maintainer: +-- A copyright notice. +-- copyright: +-- category: +extra-source-files: CHANGELOG.md + +executable testdata + main-is: Main.hs + -- Modules included in this executable, other than Main. + -- other-modules: + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + build-depends: base ^>=4.14.1.0 + hs-source-dirs: app + default-language: Haskell2010 diff --git a/plugins/hls-cabal-gild-plugin/test/testdata/src/MyLib.hs b/plugins/hls-cabal-gild-plugin/test/testdata/src/MyLib.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-gild-plugin/test/testdata/src/MyLib.hs @@ -0,0 +1,4 @@ +module MyLib (someFunc) where + +someFunc :: IO () +someFunc = putStrLn "someFunc" diff --git a/plugins/hls-cabal-gild-plugin/test/testdata/src/MyOtherLib.hs b/plugins/hls-cabal-gild-plugin/test/testdata/src/MyOtherLib.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-gild-plugin/test/testdata/src/MyOtherLib.hs @@ -0,0 +1,3 @@ +module MyOtherLib where + +bar = 2 diff --git a/plugins/hls-change-type-signature-plugin/test/testdata/TErrorGivenPartialSignature.hs b/plugins/hls-change-type-signature-plugin/test/testdata/TErrorGivenPartialSignature.hs --- a/plugins/hls-change-type-signature-plugin/test/testdata/TErrorGivenPartialSignature.hs +++ b/plugins/hls-change-type-signature-plugin/test/testdata/TErrorGivenPartialSignature.hs @@ -1,4 +1,4 @@ -module ErrorGivenPartialSignature where +module TErrorGivenPartialSignature where partial :: Int -> Int partial x = init x diff --git a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/ASTPreProcess.hs b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/ASTPreProcess.hs --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/ASTPreProcess.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/ASTPreProcess.hs @@ -174,7 +174,7 @@ && isDef where isDef :: Bool - isDef = any isContextInfoDef . toList . identInfo $ detail + isDef = any isContextInfoDef $ identInfo detail -- Determines if the 'ContextInfo' represents a variable/function definition isContextInfoDef :: ContextInfo -> Bool diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs @@ -8,16 +8,15 @@ -} module Ide.Plugin.Eval ( descriptor, - Log(..) + Eval.Log(..) ) where import Development.IDE (IdeState) -import Ide.Logger (Pretty (pretty), Recorder, - WithPriority, cmapWithPrio) +import Ide.Logger (Recorder, WithPriority) import qualified Ide.Plugin.Eval.CodeLens as CL import Ide.Plugin.Eval.Config import Ide.Plugin.Eval.Rules (rules) -import qualified Ide.Plugin.Eval.Rules as EvalRules +import qualified Ide.Plugin.Eval.Types as Eval import Ide.Types (ConfigDescriptor (..), PluginDescriptor (..), PluginId, defaultConfigDescriptor, @@ -25,19 +24,13 @@ mkCustomConfig, mkPluginHandler) import Language.LSP.Protocol.Message -newtype Log = LogEvalRules EvalRules.Log deriving Show - -instance Pretty Log where - pretty = \case - LogEvalRules log -> pretty log - -- |Plugin descriptor -descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState +descriptor :: Recorder (WithPriority Eval.Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId "Provies a code lens to evaluate expressions in doctest comments") - { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeLens CL.codeLens - , pluginCommands = [CL.evalCommand plId] - , pluginRules = rules (cmapWithPrio LogEvalRules recorder) + { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeLens (CL.codeLens recorder) + , pluginCommands = [CL.evalCommand recorder plId] + , pluginRules = rules recorder , pluginConfigDescriptor = defaultConfigDescriptor { configCustomConfig = mkCustomConfig properties } diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs @@ -85,7 +85,7 @@ myExecStmt :: String -> ExecOptions -> Ghc (Either String (Maybe String)) myExecStmt stmt opts = do (temp, purge) <- liftIO newTempFile - evalPrint <- head <$> runDecls ("evalPrint x = P.writeFile "<> show temp <> " (P.show x)") + evalPrint <- head <$> runDecls ("evalPrint x = P.writeFile " <> show temp <> " (P.show x)") modifySession $ \hsc -> hsc {hsc_IC = setInteractivePrintName (hsc_IC hsc) evalPrint} result <- execStmt stmt opts >>= \case ExecComplete (Left err) _ -> pure $ Left $ show err diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -95,6 +95,10 @@ import Development.IDE.Core.PluginUtils import Development.IDE.Types.Shake (toKey) import GHC.Types.SrcLoc (UnhelpfulSpanReason (UnhelpfulInteractive)) +import Ide.Logger (Priority (..), + Recorder, + WithPriority, + logWith) import Ide.Plugin.Error (PluginError (PluginInternalError), handleMaybe, handleMaybeM) @@ -119,7 +123,7 @@ import Ide.Plugin.Eval.Types import Ide.Plugin.Eval.Util (gStrictTry, isLiterate, - logWith, + prettyWarnings, response', timed) import Ide.Types import qualified Language.LSP.Protocol.Lens as L @@ -131,17 +135,17 @@ {- | Code Lens provider NOTE: Invoked every time the document is modified, not just when the document is saved. -} -codeLens :: PluginMethodHandler IdeState Method_TextDocumentCodeLens -codeLens st plId CodeLensParams{_textDocument} = - let dbg = logWith st - perf = timed dbg +codeLens :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Method_TextDocumentCodeLens +codeLens recorder st plId CodeLensParams{_textDocument} = + let dbg = logWith recorder Debug + perf = timed (\lbl duration -> dbg $ LogExecutionTime lbl duration) in perf "codeLens" $ do let TextDocumentIdentifier uri = _textDocument fp <- uriToFilePathE uri let nfp = toNormalizedFilePath' fp isLHS = isLiterate fp - dbg "fp" fp + dbg $ LogCodeLensFp fp (comments, _) <- runActionE "eval.GetParsedModuleWithComments" st $ useWithStaleE GetEvalComments nfp -- dbg "excluded comments" $ show $ DL.toList $ @@ -152,7 +156,7 @@ -- _ -> DL.singleton (a, b) -- ) -- $ apiAnnComments' pm_annotations - dbg "comments" $ show comments + dbg $ LogCodeLensComments comments -- Extract tests from source code let Sections{..} = commentsToSections isLHS comments @@ -174,17 +178,11 @@ ] perf "tests" $ - dbg "Tests" $ - unwords - [ show (length tests) - , "tests in" - , show (length nonSetupSections) - , "sections" - , show (length setupSections) - , "setups" - , show (length lenses) - , "lenses." - ] + dbg $ LogTests + (length tests) + (length nonSetupSections) + (length setupSections) + (length lenses) return $ InL lenses where @@ -193,15 +191,15 @@ evalCommandName :: CommandId evalCommandName = "evalCommand" -evalCommand :: PluginId -> PluginCommand IdeState -evalCommand plId = PluginCommand evalCommandName "evaluate" (runEvalCmd plId) +evalCommand :: Recorder (WithPriority Log) -> PluginId -> PluginCommand IdeState +evalCommand recorder plId = PluginCommand evalCommandName "evaluate" (runEvalCmd recorder plId) type EvalId = Int -runEvalCmd :: PluginId -> CommandFunction IdeState EvalParams -runEvalCmd plId st mtoken EvalParams{..} = - let dbg = logWith st - perf = timed dbg +runEvalCmd :: Recorder (WithPriority Log) -> PluginId -> CommandFunction IdeState EvalParams +runEvalCmd recorder plId st mtoken EvalParams{..} = + let dbg = logWith recorder Debug + perf = timed (\lbl duration -> dbg $ LogExecutionTime lbl duration) cmd :: ExceptT PluginError (LspM Config) WorkspaceEdit cmd = do let tests = map (\(a,_,b) -> (a,b)) $ testsBySection sections @@ -226,9 +224,9 @@ perf "edits" $ liftIO $ evalGhcEnv final_hscEnv $ do - runTests evalCfg (st, fp) tests + runTests recorder evalCfg fp tests - let workspaceEditsMap = Map.fromList [(_uri, addFinalReturn mdlText edits)] + let workspaceEditsMap = Map.singleton _uri (addFinalReturn mdlText edits) let workspaceEdits = WorkspaceEdit (Just workspaceEditsMap) Nothing Nothing return workspaceEdits @@ -277,6 +275,7 @@ . flip xopt_unset LangExt.MonomorphismRestriction . flip gopt_set Opt_ImplicitImportQualified . flip gopt_unset Opt_DiagnosticsShowCaret + . setBackend ghciBackend $ (ms_hspp_opts ms) { useColor = Never , canUseColor = False } @@ -313,7 +312,7 @@ , test <- sectionTests section ] -type TEnv = (IdeState, String) +type TEnv = String -- |GHC declarations required for expression evaluation evalSetup :: Ghc () evalSetup = do @@ -321,26 +320,26 @@ context <- getContext setContext (IIDecl preludeAsP : context) -runTests :: EvalConfig -> TEnv -> [(Section, Test)] -> Ghc [TextEdit] -runTests EvalConfig{..} e@(_st, _) tests = do +runTests :: Recorder (WithPriority Log) -> EvalConfig -> TEnv -> [(Section, Test)] -> Ghc [TextEdit] +runTests recorder EvalConfig{..} e tests = do df <- getInteractiveDynFlags evalSetup - when (hasQuickCheck df && needsQuickCheck tests) $ void $ evals True e df propSetup + when (hasQuickCheck df && needsQuickCheck tests) $ void $ evals recorder True e df propSetup mapM (processTest e df) tests where processTest :: TEnv -> DynFlags -> (Section, Test) -> Ghc TextEdit - processTest e@(st, fp) df (section, test) = do - let dbg = logWith st + processTest fp df (section, test) = do + let dbg = logWith recorder Debug let pad = pad_ $ (if isLiterate fp then ("> " `T.append`) else id) $ padPrefix (sectionFormat section) rs <- runTest e df test - dbg "TEST RESULTS" rs + dbg $ LogRunTestResults rs let checkedResult = testCheck eval_cfg_diff (section, test) rs let resultLines = concatMap T.lines checkedResult let edit = asEdit (sectionFormat section) test (map pad resultLines) - dbg "TEST EDIT" edit + dbg $ LogRunTestEdits edit return edit -- runTest :: String -> DynFlags -> Loc Test -> Ghc [Text] @@ -349,7 +348,7 @@ return $ singleLine "Add QuickCheck to your cabal dependencies to run this test." - runTest e df test = evals (eval_cfg_exception && not (isProperty test)) e df (asStatements test) + runTest e df test = evals recorder (eval_cfg_exception && not (isProperty test)) e df (asStatements test) asEdit :: Format -> Test -> [Text] -> TextEdit asEdit (MultiLine commRange) test resultLines @@ -425,27 +424,26 @@ >>> V No instance for (Show V) arising from a use of ‘evalPrint’ -} -evals :: Bool -> TEnv -> DynFlags -> [Statement] -> Ghc [Text] -evals mark_exception (st, fp) df stmts = do +evals :: Recorder (WithPriority Log) -> Bool -> TEnv -> DynFlags -> [Statement] -> Ghc [Text] +evals recorder mark_exception fp df stmts = do er <- gStrictTry $ mapM eval stmts return $ case er of Left err -> errorLines err Right rs -> concat . catMaybes $ rs where - dbg = logWith st + dbg = logWith recorder Debug eval :: Statement -> Ghc (Maybe [Text]) eval (Located l stmt) | -- GHCi flags Just (words -> flags) <- parseSetFlags stmt = do - dbg "{:SET" flags + dbg $ LogEvalFlags flags ndf <- getInteractiveDynFlags - dbg "pre set" $ showDynFlags ndf + dbg $ LogEvalPreSetDynFlags ndf eans <- liftIO $ try @GhcException $ parseDynamicFlagsCmdLine ndf (map (L $ UnhelpfulSpan unhelpfulReason) flags) - dbg "parsed flags" $ eans - <&> (_1 %~ showDynFlags >>> _3 %~ prettyWarnings) + dbg $ LogEvalParsedFlags eans case eans of Left err -> pure $ Just $ errorLines $ show err Right (df', ignoreds, warns) -> do @@ -459,7 +457,7 @@ ["Some flags have not been recognized: " <> T.pack (intercalate ", " $ map SrcLoc.unLoc ignoreds) ] - dbg "post set" $ showDynFlags df' + dbg $ LogEvalPostSetDynFlags df' setSessionAndInteractiveDynFlags df' pure $ warnings <> igns | -- A type/kind command @@ -468,23 +466,23 @@ | -- A statement isStmt pf stmt = do - dbg "{STMT " stmt + dbg $ LogEvalStmtStart stmt res <- exec stmt l let r = case res of Left err -> Just . (if mark_exception then exceptionLines else errorLines) $ err Right x -> singleLine <$> x - dbg "STMT} -> " r + dbg $ LogEvalStmtResult r return r | -- An import isImport pf stmt = do - dbg "{IMPORT " stmt + dbg $ LogEvalImport stmt _ <- addImport stmt return Nothing | -- A declaration otherwise = do - dbg "{DECL " stmt + dbg $ LogEvalDeclaration stmt void $ runDecls stmt return Nothing pf = initParserOpts df @@ -492,19 +490,6 @@ exec stmt l = let opts = execOptions{execSourceFile = fp, execLineNumber = l} in myExecStmt stmt opts - -#if MIN_VERSION_ghc(9,8,0) -prettyWarnings :: Messages DriverMessage -> String -prettyWarnings = printWithoutUniques . pprMessages (defaultDiagnosticOpts @DriverMessage) -#else -prettyWarnings :: [Warn] -> String -prettyWarnings = unlines . map prettyWarn - -prettyWarn :: Warn -> String -prettyWarn Warn{..} = - T.unpack (printOutputable $ SrcLoc.getLoc warnMsg) <> ": warning:\n" - <> " " <> SrcLoc.unLoc warnMsg -#endif needsQuickCheck :: [(Section, Test)] -> Bool needsQuickCheck = any (isProperty . snd) diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs @@ -122,7 +122,7 @@ in case parseMaybe lineGroupP $ NE.toList lcs of Nothing -> mempty Just (mls, rs) -> - ( maybe mempty (uncurry Map.singleton) ((theRan,) <$> mls) + ( maybe mempty (Map.singleton theRan) mls , -- orders setup sections in ascending order if null rs then mempty diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs @@ -1,13 +1,13 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RecordWildCards #-} --- To avoid warning "Pattern match has inaccessible right hand side" -{-# OPTIONS_GHC -Wno-overlapping-patterns #-} module Ide.Plugin.Eval.Rules (GetEvalComments(..), rules,queueForEvaluation, unqueueForEvaluation, Log) where +import Control.Lens (toListOf) import Control.Monad.IO.Class (MonadIO (liftIO)) +import qualified Data.ByteString as BS +import Data.Data.Lens (biplate) import Data.HashSet (HashSet) import qualified Data.HashSet as Set import Data.IORef @@ -24,8 +24,7 @@ fromNormalizedFilePath, msrModSummary, realSrcSpanToRange, - useWithStale_, - use_) + useWithStale_, use_) import Development.IDE.Core.PositionMapping (toCurrentRange) import Development.IDE.Core.Rules (computeLinkableTypeForDynFlags, needsCompilationRule) @@ -34,25 +33,16 @@ addIdeGlobal, getIdeGlobalAction, getIdeGlobalState) -import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat import qualified Development.IDE.GHC.Compat as SrcLoc import qualified Development.IDE.GHC.Compat.Util as FastString import Development.IDE.Graph (alwaysRerun) -import Ide.Logger (Pretty (pretty), - Recorder, WithPriority, - cmapWithPrio) import GHC.Parser.Annotation +import Ide.Logger (Recorder, WithPriority, + cmapWithPrio) import Ide.Plugin.Eval.Types -import qualified Data.ByteString as BS -newtype Log = LogShake Shake.Log deriving Show - -instance Pretty Log where - pretty = \case - LogShake shakeLog -> pretty shakeLog - rules :: Recorder (WithPriority Log) -> Rules () rules recorder = do evalParsedModuleRule recorder @@ -74,28 +64,17 @@ -- remove the module from the Evaluating state, so that next time it won't evaluate to True atomicModifyIORef' var $ \fs -> (Set.delete nfp fs, ()) -#if MIN_VERSION_ghc(9,5,0) -getAnnotations :: Development.IDE.GHC.Compat.Located (HsModule GhcPs) -> [LEpaComment] -getAnnotations (L _ m@(HsModule { hsmodExt = XModulePs {hsmodAnn = anns'}})) = -#else -getAnnotations :: Development.IDE.GHC.Compat.Located HsModule -> [LEpaComment] -getAnnotations (L _ m@(HsModule { hsmodAnn = anns'})) = -#endif - priorComments annComments <> getFollowingComments annComments - <> concatMap getCommentsForDecl (hsmodImports m) - <> concatMap getCommentsForDecl (hsmodDecls m) - where - annComments = epAnnComments anns' - -getCommentsForDecl :: GenLocated (SrcSpanAnn' (EpAnn ann)) e - -> [LEpaComment] -getCommentsForDecl (L (SrcSpanAnn (EpAnn _ _ cs) _) _) = priorComments cs <> getFollowingComments cs -getCommentsForDecl (L (SrcSpanAnn (EpAnnNotUsed) _) _) = [] - apiAnnComments' :: ParsedModule -> [SrcLoc.RealLocated EpaCommentTok] apiAnnComments' pm = do - L span (EpaComment c _) <- getAnnotations $ pm_parsed_source pm + L span (EpaComment c _) <- getEpaComments $ pm_parsed_source pm pure (L (anchor span) c) + where +#if MIN_VERSION_ghc(9,5,0) + getEpaComments :: Development.IDE.GHC.Compat.Located (HsModule GhcPs) -> [LEpaComment] +#else + getEpaComments :: Development.IDE.GHC.Compat.Located HsModule -> [LEpaComment] +#endif + getEpaComments = toListOf biplate pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcLoc.RealSrcSpan pattern RealSrcSpanAlready x = x diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs @@ -1,12 +1,16 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wwarn #-} module Ide.Plugin.Eval.Types - ( locate, + ( Log(..), + locate, locate0, Test (..), isProperty, @@ -30,17 +34,75 @@ nullComments) where -import Control.DeepSeq (deepseq) -import Data.Aeson (FromJSON, ToJSON) -import Data.List (partition) -import Data.List.NonEmpty (NonEmpty) -import Data.Map.Strict (Map) -import Data.String (IsString (..)) -import Development.IDE (Range, RuleResult) +import Control.Arrow ((>>>)) +import Control.DeepSeq (deepseq) +import Control.Lens +import Data.Aeson (FromJSON, ToJSON) +import Data.List (partition) +import Data.List.NonEmpty (NonEmpty) +import Data.Map.Strict (Map) +import Data.String (IsString (..)) +import qualified Data.Text as T +import Development.IDE (Range, RuleResult) +import qualified Development.IDE.Core.Shake as Shake +import qualified Development.IDE.GHC.Compat.Core as Core import Development.IDE.Graph.Classes -import GHC.Generics (Generic) -import Language.LSP.Protocol.Types (TextDocumentIdentifier) -import qualified Text.Megaparsec as P +import GHC.Generics (Generic) +import Ide.Logger +import Ide.Plugin.Eval.GHC (showDynFlags) +import Ide.Plugin.Eval.Util +import Language.LSP.Protocol.Types (TextDocumentIdentifier, + TextEdit) +import qualified System.Time.Extra as Extra +import qualified Text.Megaparsec as P + +data Log + = LogShake Shake.Log + | LogCodeLensFp FilePath + | LogCodeLensComments Comments + | LogExecutionTime T.Text Extra.Seconds + | LogTests !Int !Int !Int !Int + | LogRunTestResults [T.Text] + | LogRunTestEdits TextEdit + | LogEvalFlags [String] + | LogEvalPreSetDynFlags Core.DynFlags + | LogEvalParsedFlags + (Either + Core.GhcException + (Core.DynFlags, [Core.Located String], DynFlagsParsingWarnings)) + | LogEvalPostSetDynFlags Core.DynFlags + | LogEvalStmtStart String + | LogEvalStmtResult (Maybe [T.Text]) + | LogEvalImport String + | LogEvalDeclaration String + +instance Pretty Log where + pretty = \case + LogShake shakeLog -> pretty shakeLog + LogCodeLensFp fp -> "fp" <+> pretty fp + LogCodeLensComments comments -> "comments" <+> viaShow comments + LogExecutionTime lbl duration -> pretty lbl <> ":" <+> pretty (Extra.showDuration duration) + LogTests nTests nNonSetupSections nSetupSections nLenses -> "Tests" <+> fillSep + [ pretty nTests + , "tests in" + , pretty nNonSetupSections + , "sections" + , pretty nSetupSections + , "setups" + , pretty nLenses + , "lenses." + ] + LogRunTestResults results -> "TEST RESULTS" <+> viaShow results + LogRunTestEdits edits -> "TEST EDIT" <+> viaShow edits + LogEvalFlags flags -> "{:SET" <+> pretty flags + LogEvalPreSetDynFlags dynFlags -> "pre set" <+> pretty (showDynFlags dynFlags) + LogEvalParsedFlags eans -> "parsed flags" <+> viaShow (eans + <&> (_1 %~ showDynFlags >>> _3 %~ prettyWarnings)) + LogEvalPostSetDynFlags dynFlags -> "post set" <+> pretty (showDynFlags dynFlags) + LogEvalStmtStart stmt -> "{STMT" <+> pretty stmt + LogEvalStmtResult result -> "STMT}" <+> pretty result + LogEvalImport stmt -> "{IMPORT" <+> pretty stmt + LogEvalDeclaration stmt -> "{DECL" <+> pretty stmt -- | A thing with a location attached. data Located l a = Located {location :: l, located :: a} diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# OPTIONS_GHC -Wno-orphans -Wno-unused-imports #-} +{-# LANGUAGE RecordWildCards #-} -- |Debug utilities module Ide.Plugin.Eval.Util ( @@ -8,7 +9,8 @@ isLiterate, response', gStrictTry, - logWith, + DynFlagsParsingWarnings, + prettyWarnings, ) where import Control.Exception (SomeException, evaluate, @@ -22,9 +24,11 @@ import Data.Bifunctor (second) import Data.String (IsString (fromString)) import qualified Data.Text as T -import Development.IDE (IdeState, Priority (..), - ideLogger, logPriority) +import Development.IDE (IdeState, + printOutputable) import qualified Development.IDE.Core.PluginUtils as PluginUtils +import qualified Development.IDE.GHC.Compat.Core as Core +import qualified Development.IDE.GHC.Compat.Core as SrcLoc import Development.IDE.GHC.Compat.Outputable import Development.IDE.GHC.Compat.Util (MonadCatch, bagToList, catch) @@ -38,36 +42,16 @@ import Language.LSP.Protocol.Types import Language.LSP.Server import System.FilePath (takeExtension) +import qualified System.Time.Extra as Extra import System.Time.Extra (duration, showDuration) import UnliftIO.Exception (catchAny) -timed :: MonadIO m => (t -> String -> m a) -> t -> m b -> m b +timed :: MonadIO m => (t -> Extra.Seconds -> m a) -> t -> m b -> m b timed out name op = do (secs, r) <- duration op - _ <- out name (showDuration secs) + _ <- out name secs return r --- | Log using hie logger, reports source position of logging statement -logWith :: (HasCallStack, MonadIO m, Show a1, Show a2) => IdeState -> a1 -> a2 -> m () -logWith state key val = - liftIO . logPriority (ideLogger state) logLevel $ - T.unwords - [T.pack logWithPos, asT key, asT val] - where - logWithPos = - let stk = toList callStack - pr pos = concat [srcLocFile pos, ":", show . srcLocStartLine $ pos, ":", show . srcLocStartCol $ pos] - in case stk of - [] -> "" - (x:_) -> pr $ snd x - - asT :: Show a => a -> T.Text - asT = T.pack . show - --- | Set to Info to see extensive debug info in hie log, set to Debug in production -logLevel :: Priority -logLevel = Debug -- Info - isLiterate :: FilePath -> Bool isLiterate x = takeExtension x `elem` [".lhs", ".lhs-boot"] @@ -109,3 +93,20 @@ _ -> #endif return . show $ e + +#if MIN_VERSION_ghc(9,8,0) +type DynFlagsParsingWarnings = Messages DriverMessage + +prettyWarnings :: DynFlagsParsingWarnings -> String +prettyWarnings = printWithoutUniques . pprMessages (defaultDiagnosticOpts @DriverMessage) +#else +type DynFlagsParsingWarnings = [Core.Warn] + +prettyWarnings :: DynFlagsParsingWarnings -> String +prettyWarnings = unlines . map prettyWarn + +prettyWarn :: Core.Warn -> String +prettyWarn Core.Warn{..} = + T.unpack (printOutputable $ SrcLoc.getLoc warnMsg) <> ": warning:\n" + <> " " <> SrcLoc.unLoc warnMsg +#endif diff --git a/plugins/hls-eval-plugin/test/Main.hs b/plugins/hls-eval-plugin/test/Main.hs --- a/plugins/hls-eval-plugin/test/Main.hs +++ b/plugins/hls-eval-plugin/test/Main.hs @@ -73,47 +73,39 @@ , testCase "Semantic and Lexical errors are reported" $ do evalInFile "T8.hs" "-- >>> noFunctionWithThisName" "-- Variable not in scope: noFunctionWithThisName" evalInFile "T8.hs" "-- >>> res = \"a\" + \"bc\"" $ - if - | ghcVersion >= GHC96 -> "-- No instance for `Num String' arising from a use of `+'\n-- In the expression: \"a\" + \"bc\"\n-- In an equation for `res': res = \"a\" + \"bc\"" - | ghcVersion >= GHC92 -> "-- No instance for (Num String) arising from a use of `+'\n-- In the expression: \"a\" + \"bc\"\n-- In an equation for `res': res = \"a\" + \"bc\"" - | ghcVersion == GHC90 -> "-- No instance for (Num String) arising from a use of ‘+’" - | otherwise -> "-- No instance for (Num [Char]) arising from a use of ‘+’" + if ghcVersion >= GHC96 then + "-- No instance for `Num String' arising from a use of `+'\n-- In the expression: \"a\" + \"bc\"\n-- In an equation for `res': res = \"a\" + \"bc\"" + else + "-- No instance for (Num String) arising from a use of `+'\n-- In the expression: \"a\" + \"bc\"\n-- In an equation for `res': res = \"a\" + \"bc\"" + evalInFile "T8.hs" "-- >>> \"" "-- lexical error in string/character literal at end of input" evalInFile "T8.hs" "-- >>> 3 `div` 0" "-- divide by zero" -- The default for marking exceptions is False , goldenWithEval "Applies file LANGUAGE extensions" "T9" "hs" - , goldenWithEval' "Evaluate a type with :kind!" "T10" "hs" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected") - , goldenWithEval' "Reports an error for an incorrect type with :kind!" "T11" "hs" ( - if ghcVersion >= GHC94 then "ghc94.expected" - else if ghcVersion >= GHC92 then "ghc92.expected" - else "expected" - ) - , goldenWithEval' "Shows a kind with :kind" "T12" "hs" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected") - , goldenWithEval' "Reports an error for an incorrect type with :kind" "T13" "hs" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected") + , goldenWithEval "Evaluate a type with :kind!" "T10" "hs" + , goldenWithEval' "Reports an error for an incorrect type with :kind!" "T11" "hs" + (if ghcVersion >= GHC94 then "ghc94.expected" else "expected") + , goldenWithEval "Shows a kind with :kind" "T12" "hs" + , goldenWithEval "Reports an error for an incorrect type with :kind" "T13" "hs" , goldenWithEval' "Returns a fully-instantiated type for :type" "T14" "hs" (if ghcVersion >= GHC98 then "ghc98.expected" else "expected") -- See https://gitlab.haskell.org/ghc/ghc/-/issues/24069 , knownBrokenForGhcVersions [GHC92, GHC94, GHC96, GHC98] "type +v does not work anymore with 9.2" $ goldenWithEval "Returns an uninstantiated type for :type +v, admitting multiple whitespaces around arguments" "T15" "hs" + , goldenWithEval "Doesn't break in module containing main function" "T4139" "hs" , goldenWithEval "Returns defaulted type for :type +d, admitting multiple whitespaces around arguments" "T16" "hs" - , goldenWithEval' ":type reports an error when given with unknown +x option" "T17" "hs" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected") + , goldenWithEval ":type reports an error when given with unknown +x option" "T17" "hs" , goldenWithEval "Reports an error when given with unknown command" "T18" "hs" , goldenWithEval "Returns defaulted type for :type +d reflecting the default declaration specified in the >>> prompt" "T19" "hs" , expectFailBecause "known issue - see a note in P.R. #361" $ - goldenWithEval' ":type +d reflects the `default' declaration of the module" "T20" "hs" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected") + goldenWithEval ":type +d reflects the `default' declaration of the module" "T20" "hs" , testCase ":type handles a multilined result properly" $ evalInFile "T21.hs" "-- >>> :type fun" $ T.unlines [ "-- fun", - if - | ghcVersion >= GHC92 -> "-- :: forall {k1} (k2 :: Nat) (n :: Nat) (a :: k1)." - | ghcVersion == GHC90 -> "-- :: forall {k1} {k2 :: Nat} {n :: Nat} {a :: k1}." - | otherwise -> "-- :: forall k1 (k2 :: Nat) (n :: Nat) (a :: k1).", + "-- :: forall {k1} (k2 :: Nat) (n :: Nat) (a :: k1).", "-- (KnownNat k2, KnownNat n, Typeable a) =>", "-- Proxy k2 -> Proxy n -> Proxy a -> ()" ] , goldenWithEval ":t behaves exactly the same as :type" "T22" "hs" , testCase ":type does \"dovetails\" for short identifiers" $ evalInFile "T23.hs" "-- >>> :type f" $ T.unlines [ - if - | ghcVersion >= GHC92 -> "-- f :: forall {k1} (k2 :: Nat) (n :: Nat) (a :: k1)." - | ghcVersion == GHC90 -> "-- f :: forall {k1} {k2 :: Nat} {n :: Nat} {a :: k1}." - | otherwise -> "-- f :: forall k1 (k2 :: Nat) (n :: Nat) (a :: k1).", + "-- f :: forall {k1} (k2 :: Nat) (n :: Nat) (a :: k1).", "-- (KnownNat k2, KnownNat n, Typeable a) =>", "-- Proxy k2 -> Proxy n -> Proxy a -> ()" ] @@ -121,6 +113,7 @@ , goldenWithEval ":kind treats a multilined result properly" "T25" "hs" , goldenWithEvalAndFs "local imports" (FS.directProjectMulti ["T26.hs", "Util.hs"]) "T26" "hs" , goldenWithEval "Preserves one empty comment line after prompt" "T27" "hs" + , goldenWithEval "Evaluate comment after multiline function definition" "T28" "hs" , goldenWithEval "Multi line comments" "TMulti" "hs" , goldenWithEval "Multi line comments, with the last test line ends without newline" "TEndingMulti" "hs" , goldenWithEval "Evaluate expressions in Plain comments in both single line and multi line format" "TPlainComment" "hs" @@ -130,13 +123,10 @@ , goldenWithEvalAndFs "Transitive local dependency" (FS.directProjectMulti ["TTransitive.hs", "TLocalImport.hs", "Util.hs"]) "TTransitive" "hs" -- , goldenWithEval "Local Modules can be imported in a test" "TLocalImportInTest" "hs" , goldenWithEval "Setting language option TupleSections" "TLanguageOptionsTupleSections" "hs" - , goldenWithEval' ":set accepts ghci flags" "TFlags" "hs" (if ghcVersion >= GHC98 then "ghc98.expected" else if ghcVersion >= GHC92 then "ghc92.expected" else "expected") + , goldenWithEval' ":set accepts ghci flags" "TFlags" "hs" (if ghcVersion >= GHC98 then "ghc98.expected" else "expected") , testCase ":set -fprint-explicit-foralls works" $ do evalInFile "T8.hs" "-- >>> :t id" "-- id :: a -> a" - evalInFile "T8.hs" "-- >>> :set -fprint-explicit-foralls\n-- >>> :t id" - (if ghcVersion >= GHC92 - then "-- id :: forall a. a -> a" - else "-- id :: forall {a}. a -> a") + evalInFile "T8.hs" "-- >>> :set -fprint-explicit-foralls\n-- >>> :t id" "-- id :: forall a. a -> a" , goldenWithEval "The default language extensions for the eval plugin are the same as those for ghci" "TSameDefaultLanguageExtensionsAsGhci" "hs" , goldenWithEval "IO expressions are supported, stdout/stderr output is ignored" "TIO" "hs" , goldenWithEvalAndFs "Property checking" cabalProjectFS "TProperty" "hs" diff --git a/plugins/hls-eval-plugin/test/cabal.project b/plugins/hls-eval-plugin/test/cabal.project --- a/plugins/hls-eval-plugin/test/cabal.project +++ b/plugins/hls-eval-plugin/test/cabal.project @@ -1,3 +1,3 @@ packages: testdata/ - info-util/ + testdata/info-util/ diff --git a/plugins/hls-eval-plugin/test/testdata/T10.expected.hs b/plugins/hls-eval-plugin/test/testdata/T10.expected.hs --- a/plugins/hls-eval-plugin/test/testdata/T10.expected.hs +++ b/plugins/hls-eval-plugin/test/testdata/T10.expected.hs @@ -7,5 +7,5 @@ -- >>> type N = 1 -- >>> type M = 40 -- >>> :kind! N + M + 1 --- N + M + 1 :: Nat +-- N + M + 1 :: Natural -- = 42 diff --git a/plugins/hls-eval-plugin/test/testdata/T10.ghc92.expected b/plugins/hls-eval-plugin/test/testdata/T10.ghc92.expected deleted file mode 100644 --- a/plugins/hls-eval-plugin/test/testdata/T10.ghc92.expected +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE DataKinds, TypeOperators #-} -module T10 where -import GHC.TypeNats ( type (+) ) - -type Dummy = 1 + 1 - --- >>> type N = 1 --- >>> type M = 40 --- >>> :kind! N + M + 1 --- N + M + 1 :: Natural --- = 42 diff --git a/plugins/hls-eval-plugin/test/testdata/T10.ghc92.expected.hs b/plugins/hls-eval-plugin/test/testdata/T10.ghc92.expected.hs deleted file mode 100644 --- a/plugins/hls-eval-plugin/test/testdata/T10.ghc92.expected.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE DataKinds, TypeOperators #-} -module T10 where -import GHC.TypeNats ( type (+) ) - -type Dummy = 1 + 1 - --- >>> type N = 1 --- >>> type M = 40 --- >>> :kind! N + M + 1 --- N + M + 1 :: Natural --- = 42 diff --git a/plugins/hls-eval-plugin/test/testdata/T11.expected.hs b/plugins/hls-eval-plugin/test/testdata/T11.expected.hs --- a/plugins/hls-eval-plugin/test/testdata/T11.expected.hs +++ b/plugins/hls-eval-plugin/test/testdata/T11.expected.hs @@ -1,4 +1,4 @@ module T11 where -- >>> :kind! A --- Not in scope: type constructor or class ‘A’ +-- Not in scope: type constructor or class `A' diff --git a/plugins/hls-eval-plugin/test/testdata/T12.expected.hs b/plugins/hls-eval-plugin/test/testdata/T12.expected.hs --- a/plugins/hls-eval-plugin/test/testdata/T12.expected.hs +++ b/plugins/hls-eval-plugin/test/testdata/T12.expected.hs @@ -7,4 +7,4 @@ -- >>> type N = 1 -- >>> type M = 40 -- >>> :kind N + M + 1 --- N + M + 1 :: Nat +-- N + M + 1 :: Natural diff --git a/plugins/hls-eval-plugin/test/testdata/T12.ghc92.expected.hs b/plugins/hls-eval-plugin/test/testdata/T12.ghc92.expected.hs deleted file mode 100644 --- a/plugins/hls-eval-plugin/test/testdata/T12.ghc92.expected.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE DataKinds, TypeOperators #-} -module T12 where -import GHC.TypeNats ( type (+) ) - -type Dummy = 1 + 1 - --- >>> type N = 1 --- >>> type M = 40 --- >>> :kind N + M + 1 --- N + M + 1 :: Natural diff --git a/plugins/hls-eval-plugin/test/testdata/T12.ghc92_expected.hs b/plugins/hls-eval-plugin/test/testdata/T12.ghc92_expected.hs deleted file mode 100644 --- a/plugins/hls-eval-plugin/test/testdata/T12.ghc92_expected.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE DataKinds, TypeOperators #-} -module T12 where -import GHC.TypeNats ( type (+) ) - -type Dummy = 1 + 1 - --- >>> type N = 1 --- >>> type M = 40 --- >>> :kind N + M + 1 --- N + M + 1 :: Natural diff --git a/plugins/hls-eval-plugin/test/testdata/T13.expected.hs b/plugins/hls-eval-plugin/test/testdata/T13.expected.hs --- a/plugins/hls-eval-plugin/test/testdata/T13.expected.hs +++ b/plugins/hls-eval-plugin/test/testdata/T13.expected.hs @@ -1,4 +1,4 @@ module T13 where -- >>> :kind A --- Not in scope: type constructor or class ‘A’ +-- Not in scope: type constructor or class `A' diff --git a/plugins/hls-eval-plugin/test/testdata/T13.ghc92.expected.hs b/plugins/hls-eval-plugin/test/testdata/T13.ghc92.expected.hs deleted file mode 100644 --- a/plugins/hls-eval-plugin/test/testdata/T13.ghc92.expected.hs +++ /dev/null @@ -1,4 +0,0 @@ -module T13 where - --- >>> :kind A --- Not in scope: type constructor or class `A' diff --git a/plugins/hls-eval-plugin/test/testdata/T13.ghc92_expected.hs b/plugins/hls-eval-plugin/test/testdata/T13.ghc92_expected.hs deleted file mode 100644 --- a/plugins/hls-eval-plugin/test/testdata/T13.ghc92_expected.hs +++ /dev/null @@ -1,4 +0,0 @@ -module T13 where - --- >>> :kind a --- Not in scope: type variable `a' diff --git a/plugins/hls-eval-plugin/test/testdata/T15.ghc92_expected.hs b/plugins/hls-eval-plugin/test/testdata/T15.ghc92_expected.hs deleted file mode 100644 --- a/plugins/hls-eval-plugin/test/testdata/T15.ghc92_expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE TypeApplications #-} -module T15 where - -foo :: Show a => a -> String -foo = show - --- >>> :type +v foo @Int --- foo @Int :: Show Int => Int -> String diff --git a/plugins/hls-eval-plugin/test/testdata/T17.expected.hs b/plugins/hls-eval-plugin/test/testdata/T17.expected.hs --- a/plugins/hls-eval-plugin/test/testdata/T17.expected.hs +++ b/plugins/hls-eval-plugin/test/testdata/T17.expected.hs @@ -1,4 +1,4 @@ module T17 where -- >>> :type +no 42 --- parse error on input ‘+’ +-- parse error on input `+' diff --git a/plugins/hls-eval-plugin/test/testdata/T17.ghc92.expected.hs b/plugins/hls-eval-plugin/test/testdata/T17.ghc92.expected.hs deleted file mode 100644 --- a/plugins/hls-eval-plugin/test/testdata/T17.ghc92.expected.hs +++ /dev/null @@ -1,4 +0,0 @@ -module T17 where - --- >>> :type +no 42 --- parse error on input `+' diff --git a/plugins/hls-eval-plugin/test/testdata/T17.ghc92_expected.hs b/plugins/hls-eval-plugin/test/testdata/T17.ghc92_expected.hs deleted file mode 100644 --- a/plugins/hls-eval-plugin/test/testdata/T17.ghc92_expected.hs +++ /dev/null @@ -1,4 +0,0 @@ -module T17 where - --- >>> :type +no 42 --- parse error on input ‘+’ diff --git a/plugins/hls-eval-plugin/test/testdata/T20.ghc92.expected.hs b/plugins/hls-eval-plugin/test/testdata/T20.ghc92.expected.hs deleted file mode 100644 --- a/plugins/hls-eval-plugin/test/testdata/T20.ghc92.expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -module T20 where -import Data.Word (Word) - -default (Word) - --- >>> :type +d 40+ 2 --- 40+ 2 :: Word diff --git a/plugins/hls-eval-plugin/test/testdata/T20.ghc92_expected.hs b/plugins/hls-eval-plugin/test/testdata/T20.ghc92_expected.hs deleted file mode 100644 --- a/plugins/hls-eval-plugin/test/testdata/T20.ghc92_expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -module T20 where -import Data.Word (Word) - -default (Word) - --- >>> :type +d 40+ 2 --- 40+ 2 :: Integer diff --git a/plugins/hls-eval-plugin/test/testdata/T28.expected.hs b/plugins/hls-eval-plugin/test/testdata/T28.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T28.expected.hs @@ -0,0 +1,7 @@ +module T28 where + +f True = True +f False = False + +-- >>> 1+1 +-- 2 diff --git a/plugins/hls-eval-plugin/test/testdata/T28.hs b/plugins/hls-eval-plugin/test/testdata/T28.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T28.hs @@ -0,0 +1,6 @@ +module T28 where + +f True = True +f False = False + +-- >>> 1+1 diff --git a/plugins/hls-eval-plugin/test/testdata/T4139.expected.hs b/plugins/hls-eval-plugin/test/testdata/T4139.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T4139.expected.hs @@ -0,0 +1,7 @@ +module T4139 where + +-- >>> 'x' +-- 'x' + +main :: IO () +main = putStrLn "Hello World!" diff --git a/plugins/hls-eval-plugin/test/testdata/T4139.hs b/plugins/hls-eval-plugin/test/testdata/T4139.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/T4139.hs @@ -0,0 +1,6 @@ +module T4139 where + +-- >>> 'x' + +main :: IO () +main = putStrLn "Hello World!" diff --git a/plugins/hls-eval-plugin/test/testdata/TFlags.expected.hs b/plugins/hls-eval-plugin/test/testdata/TFlags.expected.hs --- a/plugins/hls-eval-plugin/test/testdata/TFlags.expected.hs +++ b/plugins/hls-eval-plugin/test/testdata/TFlags.expected.hs @@ -20,8 +20,9 @@ Options apply only in the section where they are defined (unless they are in the setup section), so this will fail: >>> class L a b c -Too many parameters for class ‘L’ +Too many parameters for class `L' (Enable MultiParamTypeClasses to allow multi-parameter classes) +In the class declaration for `L' -} @@ -31,8 +32,9 @@ Not set yet: >>> class D -No parameters for class ‘D’ +No parameters for class `D' (Enable MultiParamTypeClasses to allow no-parameter classes) +In the class declaration for `D' Now it works: diff --git a/plugins/hls-eval-plugin/test/testdata/TFlags.ghc92.expected.hs b/plugins/hls-eval-plugin/test/testdata/TFlags.ghc92.expected.hs deleted file mode 100644 --- a/plugins/hls-eval-plugin/test/testdata/TFlags.ghc92.expected.hs +++ /dev/null @@ -1,64 +0,0 @@ --- Support for language options - -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE Haskell2010 #-} - -module TFlags where - --- Language options set in the module source (ScopedTypeVariables) --- also apply to tests so this works fine --- >>> f = (\(c::Char) -> [c]) - -{- Multiple options can be set with a single `:set` - ->>> :set -XMultiParamTypeClasses -XFlexibleInstances ->>> class Z a b c --} - -{- - -Options apply only in the section where they are defined (unless they are in the setup section), so this will fail: - ->>> class L a b c -Too many parameters for class `L' -(Enable MultiParamTypeClasses to allow multi-parameter classes) -In the class declaration for `L' --} - - -{- -Options apply to all tests in the same section after their declaration. - -Not set yet: - ->>> class D -No parameters for class `D' -(Enable MultiParamTypeClasses to allow no-parameter classes) -In the class declaration for `D' - -Now it works: - ->>>:set -XMultiParamTypeClasses ->>> class C - -It still works - ->>> class F --} - -{- Now -package flag is handled correctly: - ->>> :set -package ghc-prim ->>> import GHC.Prim - --} - - -{- Invalid option/flags are reported, but valid ones will be reflected - ->>> :set -XRank2Types -XAbsent -XDatatypeContexts -XWrong -fprint-nothing-at-all -: warning: - -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language. -Some flags have not been recognized: -XAbsent, -XWrong, -fprint-nothing-at-all - --} diff --git a/plugins/hls-eval-plugin/test/testdata/TPropertyError.ghc98.expected.hs b/plugins/hls-eval-plugin/test/testdata/TPropertyError.ghc98.expected.hs --- a/plugins/hls-eval-plugin/test/testdata/TPropertyError.ghc98.expected.hs +++ b/plugins/hls-eval-plugin/test/testdata/TPropertyError.ghc98.expected.hs @@ -6,8 +6,8 @@ -- Exception: -- Prelude.head: empty list -- CallStack (from HasCallStack): --- error, called at libraries/base/GHC/List.hs:1782:3 in base:GHC.List --- errorEmptyList, called at libraries/base/GHC/List.hs:89:11 in base:GHC.List --- badHead, called at libraries/base/GHC/List.hs:83:28 in base:GHC.List +-- error, called at libraries/base/GHC/List.hs:2004:3 in base:GHC.List +-- errorEmptyList, called at libraries/base/GHC/List.hs:90:11 in base:GHC.List +-- badHead, called at libraries/base/GHC/List.hs:84:28 in base:GHC.List -- head, called at :1:27 in interactive:Ghci2 -- [] diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -232,7 +232,7 @@ pure $ mkWorkspaceEdit uri edits pm mkWorkspaceEdit :: Uri -> [ImportEdit] -> PositionMapping -> WorkspaceEdit mkWorkspaceEdit uri edits pm = - WorkspaceEdit {_changes = Just $ Map.fromList [(uri, mapMaybe toWEdit edits)] + WorkspaceEdit {_changes = Just $ Map.singleton uri (mapMaybe toWEdit edits) , _documentChanges = Nothing , _changeAnnotations = Nothing} where toWEdit ImportEdit{ieRange, ieText} = diff --git a/plugins/hls-floskell-plugin/src/Ide/Plugin/Floskell.hs b/plugins/hls-floskell-plugin/src/Ide/Plugin/Floskell.hs --- a/plugins/hls-floskell-plugin/src/Ide/Plugin/Floskell.hs +++ b/plugins/hls-floskell-plugin/src/Ide/Plugin/Floskell.hs @@ -8,6 +8,7 @@ import Control.Monad.Except (throwError) import Control.Monad.IO.Class +import Data.List (find) import qualified Data.Text as T import qualified Data.Text.Lazy as TL import Development.IDE hiding (pluginHandlers) @@ -53,7 +54,8 @@ case mbConf of Just confFile -> readAppConfig confFile Nothing -> - let gibiansky = head (filter (\s -> styleName s == "gibiansky") styles) - in pure $ defaultAppConfig { appStyle = gibiansky } + pure $ case find (\s -> styleName s == "gibiansky") styles of + Just gibiansky -> defaultAppConfig { appStyle = gibiansky } + Nothing -> defaultAppConfig -- --------------------------------------------------------------------- diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -18,7 +18,7 @@ -- lots of CPP, we just disable the warning until later. {-# OPTIONS_GHC -Wno-redundant-constraints #-} -#ifdef HLINT_ON_GHC_LIB +#ifdef GHC_LIB #define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc_lib_parser(x,y,z) #else #define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc(x,y,z) @@ -61,7 +61,6 @@ import qualified Refact.Apply as Refact import qualified Refact.Types as Refact -#ifdef HLINT_ON_GHC_LIB import Development.IDE.GHC.Compat (DynFlags, WarningFlag (Opt_WarnUnrecognisedPragmas), extensionFlags, @@ -71,18 +70,18 @@ import qualified Development.IDE.GHC.Compat.Util as EnumSet #if MIN_GHC_API_VERSION(9,4,0) -import qualified "ghc-lib-parser" GHC.Data.Strict as Strict +import qualified GHC.Data.Strict as Strict #endif #if MIN_GHC_API_VERSION(9,0,0) -import "ghc-lib-parser" GHC.Types.SrcLoc hiding +import GHC.Types.SrcLoc hiding (RealSrcSpan) -import qualified "ghc-lib-parser" GHC.Types.SrcLoc as GHC +import qualified GHC.Types.SrcLoc as GHC #else -import "ghc-lib-parser" SrcLoc hiding +import qualified SrcLoc as GHC +import SrcLoc hiding (RealSrcSpan) -import qualified "ghc-lib-parser" SrcLoc as GHC #endif -import "ghc-lib-parser" GHC.LanguageExtensions (Extension) +import GHC.LanguageExtensions (Extension) import Language.Haskell.GhclibParserEx.GHC.Driver.Session as GhclibParserEx (readExtension) import System.FilePath (takeFileName) import System.IO (IOMode (WriteMode), @@ -94,21 +93,7 @@ utf8, withFile) import System.IO.Temp -#else -import Development.IDE.GHC.Compat hiding - (setEnv, - (<+>)) -import GHC.Generics (Associativity (LeftAssociative, NotAssociative, RightAssociative)) -#if MIN_GHC_API_VERSION(9,2,0) -import Language.Haskell.GHC.ExactPrint.ExactPrint (deltaOptions) -#else -import Language.Haskell.GHC.ExactPrint.Delta (deltaOptions) -#endif -import Language.Haskell.GHC.ExactPrint.Parsers (postParseTransform) -import Language.Haskell.GHC.ExactPrint.Types (Rigidity (..)) -import Language.Haskell.GhclibParserEx.Fixity as GhclibParserEx (applyFixities) -import qualified Refact.Fixity as Refact -#endif + import Ide.Plugin.Config hiding (Config) import Ide.Plugin.Error @@ -159,7 +144,6 @@ LogGetIdeas fp -> "Getting hlint ideas for " <+> viaShow fp LogResolve msg -> pretty msg -#ifdef HLINT_ON_GHC_LIB -- Reimplementing this, since the one in Development.IDE.GHC.Compat isn't for ghc-lib #if !MIN_GHC_API_VERSION(9,0,0) type BufSpan = () @@ -173,7 +157,6 @@ pattern RealSrcSpan x y <- ((,Nothing) -> (GHC.RealSrcSpan x, y)) #endif {-# COMPLETE RealSrcSpan, UnhelpfulSpan #-} -#endif #if MIN_GHC_API_VERSION(9,4,0) fromStrictMaybe :: Strict.Maybe a -> Maybe a @@ -316,28 +299,6 @@ fmap applyHints' (moduleEx flags) where moduleEx :: ParseFlags -> Action (Maybe (Either ParseError ModuleEx)) -#ifndef HLINT_ON_GHC_LIB - moduleEx _flags = do - mbpm <- getParsedModuleWithComments nfp - return $ createModule <$> mbpm - where - createModule pm = Right (createModuleEx anns (applyParseFlagsFixities modu)) - where anns = pm_annotations pm - modu = pm_parsed_source pm - - applyParseFlagsFixities :: ParsedSource -> ParsedSource - applyParseFlagsFixities modul = GhclibParserEx.applyFixities (parseFlagsToFixities _flags) modul - - parseFlagsToFixities :: ParseFlags -> [(String, Fixity)] - parseFlagsToFixities = map toFixity . Hlint.fixities - - toFixity :: FixityInfo -> (String, Fixity) - toFixity (name, dir, i) = (name, Fixity NoSourceText i $ f dir) - where - f LeftAssociative = InfixL - f RightAssociative = InfixR - f NotAssociative = InfixN -#else moduleEx flags = do mbpm <- getParsedModuleWithComments nfp -- If ghc was not able to parse the module, we disable hlint diagnostics @@ -360,11 +321,6 @@ -- and the ModSummary dynflags. However using the parsedFlags extensions -- can sometimes interfere with the hlint parsing of the file. -- See https://github.com/haskell/haskell-language-server/issues/1279 --- --- Note: this is used when HLINT_ON_GHC_LIB is defined. We seem to need --- these extensions to construct dynflags to parse the file again. Therefore --- using hlint default extensions doesn't seem to be a problem when --- HLINT_ON_GHC_LIB is not defined because we don't parse the file again. getExtensions :: NormalizedFilePath -> Action [Extension] getExtensions nfp = do dflags <- getFlags @@ -375,7 +331,6 @@ getFlags = do modsum <- use_ GetModSummary nfp return $ ms_hspp_opts $ msrModSummary modsum -#endif -- --------------------------------------------------------------------- @@ -573,7 +528,6 @@ -- But "Idea"s returned by HLint point to starting position of the expressions -- that contain refactorings, so they are often outside the refactorings' boundaries. let position = Nothing -#ifdef HLINT_ON_GHC_LIB let writeFileUTF8NoNewLineTranslation file txt = withFile file WriteMode $ \h -> do hSetEncoding h utf8 @@ -589,22 +543,6 @@ let refactExts = map show $ enabled ++ disabled (Right <$> applyRefactorings (topDir dflags) position commands temp refactExts) `catches` errorHandlers -#else - mbParsedModule <- liftIO $ runAction' $ getParsedModuleWithComments nfp - res <- - case mbParsedModule of - Nothing -> throwError "Apply hint: error parsing the module" - Just pm -> do - let anns = pm_annotations pm - let modu = pm_parsed_source pm - -- apply-refact uses RigidLayout - let rigidLayout = deltaOptions RigidLayout - (anns', modu') <- - ExceptT $ mapM (uncurry Refact.applyFixities) - $ postParseTransform (Right (anns, [], dflags, modu)) rigidLayout - liftIO $ (Right <$> Refact.applyRefactorings' position commands anns' modu') - `catches` errorHandlers -#endif case res of Right appliedFile -> do let wsEdit = diffText' True (verTxtDocId, oldContent) (T.pack appliedFile) IncludeDeletions diff --git a/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs b/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs --- a/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs +++ b/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs @@ -25,7 +25,7 @@ import Data.Aeson (toJSON) import Data.Char (isLower, isUpper) import Data.List (intercalate, minimumBy, - stripPrefix, uncons) + stripPrefix) import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import Data.Maybe (mapMaybe) @@ -138,7 +138,7 @@ -- directories are nested inside each other. pathModuleNames :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> FilePath -> ExceptT PluginError IO [T.Text] pathModuleNames recorder state normFilePath filePath - | isLower . head $ takeFileName filePath = return ["Main"] + | firstLetter isLower $ takeFileName filePath = return ["Main"] | otherwise = do (session, _) <- runActionE "ModuleName.ghcSession" state $ useWithStaleE GhcSession normFilePath srcPaths <- liftIO $ evalGhcEnv (hscEnvWithImportPaths session) $ importPaths <$> getSessionDynFlags @@ -156,12 +156,16 @@ let suffixes = mapMaybe (`stripPrefix` mdlPath) paths pure (map moduleNameFrom suffixes) where + firstLetter :: (Char -> Bool) -> FilePath -> Bool + firstLetter _ [] = False + firstLetter pred (c:_) = pred c + moduleNameFrom = T.pack . intercalate "." -- Do not suggest names whose components start from a lower-case char, -- they are guaranteed to be malformed. - . filter (maybe False (isUpper . fst) . uncons) + . filter (firstLetter isUpper) . splitDirectories . dropExtension diff --git a/plugins/hls-notes-plugin/src/Ide/Plugin/Notes.hs b/plugins/hls-notes-plugin/src/Ide/Plugin/Notes.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-notes-plugin/src/Ide/Plugin/Notes.hs @@ -0,0 +1,145 @@ +module Ide.Plugin.Notes (descriptor, Log) where + +import Control.Lens ((^.)) +import Control.Monad.Except (throwError) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans (lift) +import qualified Data.Array as A +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as HS +import Data.Maybe (catMaybes, listToMaybe, + mapMaybe) +import Data.Text (Text, intercalate) +import qualified Data.Text as T +import qualified Data.Text.Utf16.Rope.Mixed as Rope +import Development.IDE hiding (line) +import Development.IDE.Core.PluginUtils (runActionE, useE) +import Development.IDE.Core.Shake (toKnownFiles) +import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.Graph.Classes (Hashable, NFData) +import GHC.Generics (Generic) +import Ide.Plugin.Error (PluginError (..)) +import Ide.Types +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message (Method (Method_TextDocumentDefinition), + SMethod (SMethod_TextDocumentDefinition)) +import Language.LSP.Protocol.Types +import qualified Language.LSP.Server as LSP +import Language.LSP.VFS (VirtualFile (..)) +import Text.Regex.TDFA (Regex, caseSensitive, + defaultCompOpt, + defaultExecOpt, + makeRegexOpts, matchAllText) + +data Log + = LogShake Shake.Log + | LogNotesFound NormalizedFilePath [(Text, Position)] + deriving Show + +data GetNotesInFile = MkGetNotesInFile + deriving (Show, Generic, Eq, Ord) + deriving anyclass (Hashable, NFData) +type instance RuleResult GetNotesInFile = HM.HashMap Text Position + +data GetNotes = MkGetNotes + deriving (Show, Generic, Eq, Ord) + deriving anyclass (Hashable, NFData) +type instance RuleResult GetNotes = HashMap Text (NormalizedFilePath, Position) + +instance Pretty Log where + pretty = \case + LogShake l -> pretty l + LogNotesFound file notes -> + "Found notes in " <> pretty (show file) <> ": [" + <> pretty (intercalate ", " (fmap (\(s, p) -> "\"" <> s <> "\" at " <> T.pack (show p)) notes)) <> "]" + +{- +The first time the user requests a jump-to-definition on a note reference, the +project is indexed and searched for all note definitions. Their location and +title is then saved in the HLS database to be retrieved for all future requests. +-} +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = (defaultPluginDescriptor plId "Provides goto definition support for GHC-style notes") + { Ide.Types.pluginRules = findNotesRules recorder + , Ide.Types.pluginHandlers = mkPluginHandler SMethod_TextDocumentDefinition jumpToNote + } + +findNotesRules :: Recorder (WithPriority Log) -> Rules () +findNotesRules recorder = do + defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \MkGetNotesInFile nfp -> do + findNotesInFile nfp recorder + + defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \MkGetNotes _ -> do + targets <- toKnownFiles <$> useNoFile_ GetKnownTargets + definedNotes <- catMaybes <$> mapM (\nfp -> fmap (HM.map (nfp,)) <$> use MkGetNotesInFile nfp) (HS.toList targets) + pure $ Just $ HM.unions definedNotes + +jumpToNote :: PluginMethodHandler IdeState Method_TextDocumentDefinition +jumpToNote state _ param + | Just nfp <- uriToNormalizedFilePath uriOrig + = do + let Position l c = param ^. L.position + contents <- fmap _file_text . err "Error getting file contents" + =<< lift (LSP.getVirtualFile uriOrig) + line <- err "Line not found in file" (listToMaybe $ Rope.lines $ fst + (Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (fromIntegral l) contents)) + let noteOpt = listToMaybe $ mapMaybe (atPos $ fromIntegral c) $ matchAllText noteRefRegex line + case noteOpt of + Nothing -> pure (InR (InR Null)) + Just note -> do + notes <- runActionE "notes.definedNotes" state $ useE MkGetNotes nfp + (noteFp, pos) <- err ("Note definition (a comment of the form `{- Note [" <> note <> "]\\n~~~ ... -}`) not found") (HM.lookup note notes) + pure $ InL (Definition (InL + (Location (fromNormalizedUri $ normalizedFilePathToUri noteFp) (Range pos pos)) + )) + where + uriOrig = toNormalizedUri $ param ^. (L.textDocument . L.uri) + err s = maybe (throwError $ PluginInternalError s) pure + atPos c arr = case arr A.! 0 of + -- We check if the line we are currently at contains a note + -- reference. However, we need to know if the cursor is within the + -- match or somewhere else. The second entry of the array contains + -- the title of the note as extracted by the regex. + (_, (c', len)) -> if c' <= c && c <= c' + len + then Just (fst (arr A.! 1)) else Nothing +jumpToNote _ _ _ = throwError $ PluginInternalError "conversion to normalized file path failed" + +findNotesInFile :: NormalizedFilePath -> Recorder (WithPriority Log) -> Action (Maybe (HM.HashMap Text Position)) +findNotesInFile file recorder = do + -- GetFileContents only returns a value if the file is open in the editor of + -- the user. If not, we need to read it from disk. + contentOpt <- (snd =<<) <$> use GetFileContents file + content <- case contentOpt of + Just x -> pure x + Nothing -> liftIO $ readFileUtf8 $ fromNormalizedFilePath file + let matches = (A.! 1) <$> matchAllText noteRegex content + m = toPositions matches content + logWith recorder Debug $ LogNotesFound file (HM.toList m) + pure $ Just m + where + uint = fromIntegral . toInteger + -- the regex library returns the character index of the match. However + -- to return the position from HLS we need it as a (line, character) + -- tuple. To convert between the two we count the newline characters and + -- reset the current character index every time. For every regex match, + -- once we have counted up to their character index, we save the current + -- line and character values instead. + toPositions matches = snd . fst . T.foldl' (\case + (([], m), _) -> const (([], m), (0, 0, 0)) + ((x@(name, (char, _)):xs, m), (n, nc, c)) -> \char' -> + let !c' = c + 1 + (!n', !nc') = if char' == '\n' then (n + 1, c') else (n, nc) + p@(!_, !_) = if char == c then + (xs, HM.insert name (Position (uint n') (uint (char - nc'))) m) + else (x:xs, m) + in (p, (n', nc', c')) + ) ((matches, HM.empty), (0, 0, 0)) + +noteRefRegex, noteRegex :: Regex +(noteRefRegex, noteRegex) = + ( mkReg ("note \\[(.+)\\]" :: String) + , mkReg ("note \\[([[:print:]]+)\\][[:blank:]]*\r?\n[[:blank:]]*(--)?[[:blank:]]*~~~" :: String) + ) + where + mkReg = makeRegexOpts (defaultCompOpt { caseSensitive = False }) defaultExecOpt diff --git a/plugins/hls-notes-plugin/test/NotesTest.hs b/plugins/hls-notes-plugin/test/NotesTest.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-notes-plugin/test/NotesTest.hs @@ -0,0 +1,64 @@ +module Main (main) where + +import Development.IDE.Test +import Ide.Plugin.Notes (Log, descriptor) +import System.Directory (canonicalizePath) +import System.FilePath (()) +import Test.Hls hiding (waitForBuildQueue) + +plugin :: PluginTestDescriptor Log +plugin = mkPluginTestDescriptor descriptor "notes" + +main :: IO () +main = defaultTestRunner $ + testGroup "Notes" + [ gotoNoteTests + ] + +gotoNoteTests :: TestTree +gotoNoteTests = testGroup "Goto Note Definition" + [ testCase "single_file" $ runSessionWithServer def plugin testDataDir $ do + doc <- openDoc "NoteDef.hs" "haskell" + waitForBuildQueue + waitForAllProgressDone + defs <- getDefinitions doc (Position 3 41) + liftIO $ do + fp <- canonicalizePath "NoteDef.hs" + defs @?= InL (Definition (InR [Location (filePathToUri fp) (Range (Position 8 9) (Position 8 9))])) + , testCase "liberal_format" $ runSessionWithServer def plugin testDataDir $ do + doc <- openDoc "NoteDef.hs" "haskell" + waitForBuildQueue + waitForAllProgressDone + defs <- getDefinitions doc (Position 5 64) + liftIO $ do + fp <- canonicalizePath "NoteDef.hs" + defs @?= InL (Definition (InR [Location (filePathToUri fp) (Range (Position 18 11) (Position 18 11))])) + + , testCase "invalid_note" $ runSessionWithServer def plugin testDataDir $ do + doc <- openDoc "NoteDef.hs" "haskell" + waitForBuildQueue + waitForAllProgressDone + defs <- getDefinitions doc (Position 6 54) + liftIO $ do + defs @?= InL (Definition (InR [])) + + , testCase "no_note" $ runSessionWithServer def plugin testDataDir $ do + doc <- openDoc "NoteDef.hs" "haskell" + waitForBuildQueue + waitForAllProgressDone + defs <- getDefinitions doc (Position 1 0) + liftIO $ defs @?= InL (Definition (InR [])) + + , testCase "unopened_file" $ runSessionWithServer def plugin testDataDir $ do + doc <- openDoc "Other.hs" "haskell" + waitForCustomMessage "ghcide/cradle/loaded" (const $ Just ()) + waitForBuildQueue + waitForAllProgressDone + defs <- getDefinitions doc (Position 5 20) + liftIO $ do + fp <- canonicalizePath "NoteDef.hs" + defs @?= InL (Definition (InR [Location (filePathToUri fp) (Range (Position 12 6) (Position 12 6))])) + ] + +testDataDir :: FilePath +testDataDir = "plugins" "hls-notes-plugin" "test" "testdata" diff --git a/plugins/hls-notes-plugin/test/testdata/NoteDef.hs b/plugins/hls-notes-plugin/test/testdata/NoteDef.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-notes-plugin/test/testdata/NoteDef.hs @@ -0,0 +1,28 @@ +module NoteDef (foo) where + +foo :: Int -> Int +foo _ = 0 -- We always return zero, see Note [Returning zero from foo] + +-- The plugin is more liberal with the note definitions, see Note [Single line comments] +-- It does not work on wrong note definitions, see Note [Not a valid Note] + +{- Note [Returning zero from foo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This is a big long form note, with very important info + +Note [Multiple notes in comment] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This is also a very common thing to do for GHC + +-} + + -- Note [Single line comments] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- GHC's notes script only allows multiline comments to define notes, but in the + -- HLS codebase this single line style can be found as well. + +{- Note [Not a valid Note] + +~~~~~~~~~~~~ +The underline needs to be directly under the Note header +-} diff --git a/plugins/hls-notes-plugin/test/testdata/Other.hs b/plugins/hls-notes-plugin/test/testdata/Other.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-notes-plugin/test/testdata/Other.hs @@ -0,0 +1,6 @@ +module Other where + +import NoteDef + +bar :: Int +bar = 4 -- See @Note [Multiple notes in comment]@ in NoteDef diff --git a/plugins/hls-notes-plugin/test/testdata/hie.yaml b/plugins/hls-notes-plugin/test/testdata/hie.yaml new file mode 100644 --- /dev/null +++ b/plugins/hls-notes-plugin/test/testdata/hie.yaml @@ -0,0 +1,5 @@ +cradle: + direct: + arguments: + - Other + - NoteDef diff --git a/plugins/hls-qualify-imported-names-plugin/src/Ide/Plugin/QualifyImportedNames.hs b/plugins/hls-qualify-imported-names-plugin/src/Ide/Plugin/QualifyImportedNames.hs --- a/plugins/hls-qualify-imported-names-plugin/src/Ide/Plugin/QualifyImportedNames.hs +++ b/plugins/hls-qualify-imported-names-plugin/src/Ide/Plugin/QualifyImportedNames.hs @@ -17,6 +17,7 @@ import qualified Data.List as List import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe, isJust, mapMaybe) +import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as Text import Development.IDE (spanContainsRange) @@ -164,7 +165,7 @@ getUsedIdentifier identifier span IdentifierDetails {..} | Just identifierSpan <- realSrcSpanToIdentifierSpan span , Right name <- identifier - , Use `elem` identInfo = Just $ UsedIdentifier name identifierSpan + , Use `Set.member` identInfo = Just $ UsedIdentifier name identifierSpan | otherwise = Nothing updateColOffset :: Int -> Int -> Int -> Int diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -75,7 +75,6 @@ EpAnn (..), EpaLocation (..), LEpaComment) -import GHC.Exts (fromList) import qualified GHC.LanguageExtensions as Lang import Ide.Logger hiding (group) @@ -189,18 +188,18 @@ extendImportHandler ideState _ edit@ExtendImport {..} = ExceptT $ do res <- liftIO $ runMaybeT $ extendImportHandler' ideState edit whenJust res $ \(nfp, wedit@WorkspaceEdit {_changes}) -> do - let (_, head -> TextEdit {_range}) = fromJust $ _changes >>= listToMaybe . M.toList - srcSpan = rangeToSrcSpan nfp _range - LSP.sendNotification SMethod_WindowShowMessage $ - ShowMessageParams MessageType_Info $ - "Import " - <> maybe ("‘" <> newThing) (\x -> "‘" <> x <> " (" <> newThing <> ")") thingParent - <> "’ from " - <> importName - <> " (at " - <> printOutputable srcSpan - <> ")" - void $ LSP.sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) + whenJust (listToMaybe =<< listToMaybe . M.elems =<< _changes) $ \TextEdit {_range} -> do + let srcSpan = rangeToSrcSpan nfp _range + LSP.sendNotification SMethod_WindowShowMessage $ + ShowMessageParams MessageType_Info $ + "Import " + <> maybe ("‘" <> newThing) (\x -> "‘" <> x <> " (" <> newThing <> ")") thingParent + <> "’ from " + <> importName + <> " (at " + <> printOutputable srcSpan + <> ")" + void $ LSP.sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) return $ Right $ InR Null extendImportHandler' :: IdeState -> ExtendImport -> MaybeT IO (NormalizedFilePath, WorkspaceEdit) @@ -223,8 +222,7 @@ case existingImport of Just imp -> do fmap (nfp,) $ liftEither $ - rewriteToWEdit df doc - $ + rewriteToWEdit df doc $ extendImport (T.unpack <$> thingParent) (T.unpack newThing) (makeDeltaAst imp) Nothing -> do @@ -235,7 +233,7 @@ Nothing -> newThing Just p -> p <> "(" <> newThing <> ")" t <- liftMaybe $ snd <$> newImportToEdit n ps (fromMaybe "" contents) - return (nfp, WorkspaceEdit {_changes=Just (GHC.Exts.fromList [(doc, [t])]), _documentChanges=Nothing, _changeAnnotations=Nothing}) + return (nfp, WorkspaceEdit {_changes=Just (M.singleton doc [t]), _documentChanges=Nothing, _changeAnnotations=Nothing}) | otherwise = mzero @@ -446,6 +444,7 @@ extendedRange = extendToFullLines r -- Note [Removing imports is preferred] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- It's good to prefer the remove imports code action because an unused import -- is likely to be removed and less likely the warning will be disabled. -- Therefore actions to remove a single or all redundant imports should be @@ -609,7 +608,7 @@ let maybeIdx = findIndex (\(L _ id) -> isSameName id name) lnames in case maybeIdx of Nothing -> Nothing - Just _ | length lnames == 1 -> Just (getLoc $ reLoc $ head lnames, True) + Just _ | [lname] <- lnames -> Just (getLoc $ reLoc lname, True) Just idx -> let targetLname = getLoc $ reLoc $ lnames !! idx startLoc = srcSpanStart targetLname @@ -1052,7 +1051,7 @@ parensed = "(" `T.isPrefixOf` T.strip (textInRange _range txt) -- > removeAllDuplicates [1, 1, 2, 3, 2] = [3] - removeAllDuplicates = map head . filter ((==1) <$> length) . group . sort + removeAllDuplicates = map NE.head . filter ((==1) . length) . NE.group . sort hasDuplicate xs = length xs /= length (S.fromList xs) suggestions symbol mods local | hasDuplicate mods = case mapM toModuleTarget (removeAllDuplicates mods) of @@ -1290,7 +1289,7 @@ | otherwise = [] findTypeSignatureName :: T.Text -> Maybe T.Text -findTypeSignatureName t = matchRegexUnifySpaces t "([^ ]+) :: " <&> head +findTypeSignatureName t = matchRegexUnifySpaces t "([^ ]+) :: " >>= listToMaybe -- | Suggests a constraint for a type signature with any number of existing constraints. suggestFunctionConstraint :: DynFlags -> ParsedSource -> Diagnostic -> T.Text -> [(T.Text, Rewrite)] @@ -1378,7 +1377,8 @@ & take 2 & mapMaybe ((`matchRegexUnifySpaces` "Redundant constraints?: (.+)") . T.strip) & listToMaybe - <&> (head >>> parseConstraints) + >>= listToMaybe + <&> parseConstraints formatConstraints :: [T.Text] -> T.Text formatConstraints [] = "" @@ -1658,7 +1658,7 @@ #endif EpAnn _ annsModule _ -> do -- Find the first 'where' - whereLocation <- fmap NE.head . NE.nonEmpty . mapMaybe filterWhere . am_main $ annsModule + whereLocation <- listToMaybe . mapMaybe filterWhere $ am_main annsModule epaLocationToLine whereLocation EpAnnNotUsed -> Nothing filterWhere (AddEpAnn AnnWhere loc) = Just loc @@ -1973,15 +1973,18 @@ _ -> Nothing -- | Process a list of (module_name, filename:src_span) values --- | Eg. [(Data.Map, app/ModuleB.hs:2:1-18), (Data.HashMap.Strict, app/ModuleB.hs:3:1-29)] +-- +-- Eg. [(Data.Map, app/ModuleB.hs:2:1-18), (Data.HashMap.Strict, app/ModuleB.hs:3:1-29)] regExImports :: T.Text -> Maybe [(T.Text, T.Text)] regExImports msg | Just mods' <- allMatchRegex msg "‘([^’]*)’" , Just srcspans' <- allMatchRegex msg + -- This regex has to be able to deal both with single-line srcpans like "(/path/to/File.hs:2:1-18)" + -- as well as multi-line srcspans like "(/path/to/File.hs:(3,1)-(5,2))" #if MIN_VERSION_ghc(9,7,0) - "\\(at ([^)]*)\\)" + "\\(at ([^:]+:[^ ]+)\\)" #else - "\\(([^)]*)\\)" + "\\(([^:]+:[^ ]+)\\)" #endif , mods <- [mod | [_,mod] <- mods'] , srcspans <- [srcspan | [_,srcspan] <- srcspans'] diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs @@ -37,7 +37,7 @@ import Control.Lens (_head, _last, over) import Data.Bifunctor (first) import Data.Default (Default (..)) -import Data.Maybe (fromJust, fromMaybe, +import Data.Maybe (fromMaybe, mapMaybe) import GHC (AddEpAnn (..), AnnContext (..), @@ -82,15 +82,13 @@ Either String [TextEdit] rewriteToEdit dflags (Rewrite dst f) = do - (ast, _ , _) <- runTransformT - $ do + (ast, _ , _) <- runTransformT $ do ast <- f dflags pure $ traceAst "REWRITE_result" $ resetEntryDP ast - let editMap = - [ TextEdit (fromJust $ srcSpanToRange dst) $ - T.pack $ exactPrint ast - ] - pure editMap + let edits = case srcSpanToRange dst of + Just range -> [ TextEdit range $ T.pack $ exactPrint ast ] + Nothing -> [] + pure edits -- | Convert a 'Rewrite' into a 'WorkspaceEdit' rewriteToWEdit :: DynFlags diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -667,7 +667,7 @@ , "func x y = x + y" ] [ if ghcVersion >= GHC98 - then "func :: a -> a -> a" -- 9.8 has a different suggestion + then "func :: a -> a -> a" -- since 9.8 GHC no longer does type defaulting (see https://gitlab.haskell.org/ghc/ghc/-/issues/24522) else "func :: Integer -> Integer -> Integer" , "func x y = x + y" ] @@ -697,7 +697,7 @@ , "func x y = x + y" ] [ if ghcVersion >= GHC98 - then "func::a -> a -> a" -- 9.8 has a different suggestion + then "func::a -> a -> a" -- since 9.8 GHC no longer does type defaulting (see https://gitlab.haskell.org/ghc/ghc/-/issues/24522) else "func::Integer -> Integer -> Integer" , "func x y = x + y" ] @@ -1501,6 +1501,30 @@ , "f :: Foo" , "f = undefined" ]) + , testSession "data constructor with two multiline import lists that can be extended with it" $ template + [] + ("A.hs", T.unlines + [ "module A where" + , "import Prelude (" + , " )" + , "import Data.Maybe (" + , " )" + , "f = Nothing" + ]) + (Range (Position 5 5) (Position 5 6)) + [ "Add Maybe(..) to the import list of Data.Maybe" + , "Add Maybe(..) to the import list of Prelude" + , "Add Maybe(Nothing) to the import list of Data.Maybe" + , "Add Maybe(Nothing) to the import list of Prelude" + ] + (T.unlines + ["module A where" + , "import Prelude (" + , " )" + , "import Data.Maybe (Maybe (..)" + , " )" + , "f = Nothing" + ]) ] where codeActionTitle CodeAction{_title=x} = x @@ -1725,7 +1749,7 @@ suggestAddRecordFieldImportTests :: TestTree suggestAddRecordFieldImportTests = testGroup "suggest imports of record fields when using OverloadedRecordDot" [ testGroup "The field is suggested when an instance resolution failure occurs" - [ ignoreForGhcVersions [GHC90, GHC94, GHC96] "Extension not present <9.2, and the assist is derived from the help message in >=9.4" theTest + [ ignoreForGhcVersions [GHC94, GHC96] "Extension not present <9.2, and the assist is derived from the help message in >=9.4" theTest ] ] where diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -14,7 +14,7 @@ import Control.Monad.Except (ExceptT, throwError) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Class (lift) -import Data.Bifunctor (first) +import Data.Either (rights) import Data.Foldable (fold) import Data.Generics import Data.Hashable @@ -25,19 +25,17 @@ import qualified Data.Map as M import Data.Maybe import Data.Mod.Word +import Data.Row import qualified Data.Set as S import qualified Data.Text as T import Development.IDE (Recorder, WithPriority, usePropertyAction) 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.Core +import Development.IDE.GHC.Compat import Development.IDE.GHC.Compat.ExactPrint -import Development.IDE.GHC.Compat.Parser -import Development.IDE.GHC.Compat.Units import Development.IDE.GHC.Error import Development.IDE.GHC.ExactPrint import qualified Development.IDE.GHC.ExactPrint as E @@ -57,44 +55,67 @@ instance Hashable (Mod a) where hash n = hash (unMod n) descriptor :: Recorder (WithPriority E.Log) -> PluginId -> PluginDescriptor IdeState -descriptor recorder pluginId = mkExactprintPluginDescriptor recorder $ (defaultPluginDescriptor pluginId "Provides renaming of Haskell identifiers") - { pluginHandlers = mkPluginHandler SMethod_TextDocumentRename renameProvider - , pluginConfigDescriptor = defaultConfigDescriptor - { configCustomConfig = mkCustomConfig properties } - } +descriptor recorder pluginId = mkExactprintPluginDescriptor recorder $ + (defaultPluginDescriptor pluginId "Provides renaming of Haskell identifiers") + { pluginHandlers = mconcat + [ mkPluginHandler SMethod_TextDocumentRename renameProvider + , mkPluginHandler SMethod_TextDocumentPrepareRename prepareRenameProvider + ] + , pluginConfigDescriptor = defaultConfigDescriptor + { configCustomConfig = mkCustomConfig properties } + } +prepareRenameProvider :: PluginMethodHandler IdeState Method_TextDocumentPrepareRename +prepareRenameProvider state _pluginId (PrepareRenameParams (TextDocumentIdentifier uri) pos _progressToken) = do + nfp <- getNormalizedFilePathE uri + namesUnderCursor <- getNamesAtPos state nfp pos + -- When this handler says that rename is invalid, VSCode shows "The element can't be renamed" + -- and doesn't even allow you to create full rename request. + -- This handler deliberately approximates "things that definitely can't be renamed" + -- to mean "there is no Name at given position". + -- + -- In particular it allows some cases through (e.g. cross-module renames), + -- so that the full rename handler can give more informative error about them. + let renameValid = not $ null namesUnderCursor + pure $ InL $ PrepareRenameResult $ InR $ InR $ #defaultBehavior .== renameValid + renameProvider :: PluginMethodHandler IdeState Method_TextDocumentRename renameProvider state pluginId (RenameParams _prog (TextDocumentIdentifier uri) pos newNameText) = do - nfp <- getNormalizedFilePathE uri - directOldNames <- getNamesAtPos state nfp pos - directRefs <- concat <$> mapM (refsAtName state nfp) directOldNames + nfp <- getNormalizedFilePathE uri + directOldNames <- getNamesAtPos state nfp pos + directRefs <- concat <$> mapM (refsAtName state nfp) directOldNames - {- References in HieDB are not necessarily transitive. With `NamedFieldPuns`, we can have - indirect references through punned names. To find the transitive closure, we do a pass of - the direct references to find the references for any punned names. - See the `IndirectPuns` test for an example. -} - indirectOldNames <- concat . filter ((>1) . length) <$> - mapM (uncurry (getNamesAtPos state) <=< locToFilePos) directRefs - let oldNames = filter matchesDirect indirectOldNames ++ directOldNames - matchesDirect n = occNameFS (nameOccName n) `elem` directFS - where - directFS = map (occNameFS. nameOccName) directOldNames - refs <- HS.fromList . concat <$> mapM (refsAtName state nfp) oldNames + {- References in HieDB are not necessarily transitive. With `NamedFieldPuns`, we can have + indirect references through punned names. To find the transitive closure, we do a pass of + the direct references to find the references for any punned names. + See the `IndirectPuns` test for an example. -} + indirectOldNames <- concat . filter ((>1) . length) <$> + mapM (uncurry (getNamesAtPos state) <=< locToFilePos) directRefs + let oldNames = filter matchesDirect indirectOldNames ++ directOldNames + where + matchesDirect n = occNameFS (nameOccName n) `elem` directFS + directFS = map (occNameFS . nameOccName) directOldNames - -- Validate rename - crossModuleEnabled <- liftIO $ runAction "rename: config" state $ usePropertyAction #crossModule pluginId properties - unless crossModuleEnabled $ failWhenImportOrExport state nfp refs oldNames - when (any isBuiltInSyntax oldNames) $ throwError $ PluginInternalError "Invalid rename of built-in syntax" + case oldNames of + -- There were no Names at given position (e.g. rename triggered within a comment or on a keyword) + [] -> throwError $ PluginInvalidParams "No symbol to rename at given position" + _ -> do + refs <- HS.fromList . concat <$> mapM (refsAtName state nfp) oldNames - -- Perform rename - let newName = mkTcOcc $ T.unpack newNameText - filesRefs = collectWith locToUri refs - getFileEdit (uri, locations) = do - verTxtDocId <- lift $ getVersionedTextDoc (TextDocumentIdentifier uri) - getSrcEdit state verTxtDocId (replaceRefs newName locations) - fileEdits <- mapM getFileEdit filesRefs - pure $ InL $ fold fileEdits + -- Validate rename + crossModuleEnabled <- liftIO $ runAction "rename: config" state $ usePropertyAction #crossModule pluginId properties + unless crossModuleEnabled $ failWhenImportOrExport state nfp refs oldNames + when (any isBuiltInSyntax oldNames) $ throwError $ PluginInternalError "Invalid rename of built-in syntax" + -- Perform rename + let newName = mkTcOcc $ T.unpack newNameText + filesRefs = collectWith locToUri refs + getFileEdit (uri, locations) = do + verTxtDocId <- lift $ getVersionedTextDoc (TextDocumentIdentifier uri) + getSrcEdit state verTxtDocId (replaceRefs newName locations) + fileEdits <- mapM getFileEdit filesRefs + pure $ InL $ fold fileEdits + -- | Limit renaming across modules. failWhenImportOrExport :: (MonadLsp config m) => @@ -188,9 +209,9 @@ ) pure $ nameLocs name ast ++ dbRefs -nameLocs :: Name -> (HieAstResult, PositionMapping) -> [Location] -nameLocs name (HAR _ _ rm _ _, pm) = - concatMap (mapMaybe (toCurrentLocation pm . realSrcSpanToLocation . fst)) +nameLocs :: Name -> HieAstResult -> [Location] +nameLocs name (HAR _ _ rm _ _) = + concatMap (map (realSrcSpanToLocation . fst)) (M.lookup (Right name) rm) --------------------------------------------------------------------------------------------------- @@ -198,16 +219,19 @@ getNamesAtPos :: MonadIO m => IdeState -> NormalizedFilePath -> Position -> ExceptT PluginError m [Name] getNamesAtPos state nfp pos = do - (HAR{hieAst}, pm) <- handleGetHieAst state nfp - pure $ getNamesAtPoint hieAst pos pm + HAR{hieAst} <- handleGetHieAst state nfp + pure $ getNamesAtPoint' hieAst pos handleGetHieAst :: MonadIO m => IdeState -> NormalizedFilePath -> - ExceptT PluginError m (HieAstResult, PositionMapping) + ExceptT PluginError m HieAstResult handleGetHieAst state nfp = - fmap (first removeGenerated) $ runActionE "Rename.GetHieAst" state $ useWithStaleE GetHieAst nfp + -- We explicitly do not want to allow a stale version here - we only want to rename if + -- the module compiles, otherwise we can't guarantee that we'll rename everything, + -- which is bad (see https://github.com/haskell/haskell-language-server/issues/3799) + fmap removeGenerated $ runActionE "Rename.GetHieAst" state $ useE GetHieAst nfp -- | We don't want to rename in code generated by GHC as this gives false positives. -- So we restrict the HIE file to remove all the generated code. @@ -221,6 +245,11 @@ collectWith :: (Hashable a, Eq b) => (a -> b) -> HashSet a -> [(b, HashSet a)] collectWith f = map (\(a :| as) -> (f a, HS.fromList (a:as))) . groupWith f . HS.toList + +-- | A variant 'getNamesAtPoint' that does not expect a 'PositionMapping' +getNamesAtPoint' :: HieASTs a -> Position -> [Name] +getNamesAtPoint' hf pos = + concat $ pointCommand hf pos (rights . M.keys . getNodeIds) locToUri :: Location -> Uri locToUri (Location uri _) = uri diff --git a/plugins/hls-rename-plugin/test/Main.hs b/plugins/hls-rename-plugin/test/Main.hs --- a/plugins/hls-rename-plugin/test/Main.hs +++ b/plugins/hls-rename-plugin/test/Main.hs @@ -1,11 +1,16 @@ +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} module Main (main) where +import Control.Lens ((^.)) import Data.Aeson -import qualified Data.Map as M +import qualified Data.Map as M +import Data.Row ((.+), (.==)) +import Data.Text (Text, pack) import Ide.Plugin.Config -import qualified Ide.Plugin.Rename as Rename +import qualified Ide.Plugin.Rename as Rename +import qualified Language.LSP.Protocol.Lens as L import System.FilePath import Test.Hls @@ -25,7 +30,7 @@ rename doc (Position 0 15) "Op" , goldenWithRename "Exported function" "ExportedFunction" $ \doc -> rename doc (Position 2 1) "quux" - , ignoreForGhcVersions [GHC90, GHC92] recordConstructorIssue $ + , ignoreForGhcVersions [GHC92] recordConstructorIssue $ goldenWithRename "Field Puns" "FieldPuns" $ \doc -> rename doc (Position 7 13) "bleh" , goldenWithRename "Function argument" "FunctionArgument" $ \doc -> @@ -40,7 +45,7 @@ rename doc (Position 3 8) "baz" , goldenWithRename "Import hiding" "ImportHiding" $ \doc -> rename doc (Position 0 22) "hiddenFoo" - , ignoreForGhcVersions [GHC90, GHC92] recordConstructorIssue $ + , ignoreForGhcVersions [GHC92] recordConstructorIssue $ goldenWithRename "Indirect Puns" "IndirectPuns" $ \doc -> rename doc (Position 4 23) "blah" , goldenWithRename "Let expression" "LetExpression" $ \doc -> @@ -53,7 +58,7 @@ rename doc (Position 3 12) "baz" , goldenWithRename "Realigns do block indentation" "RealignDo" $ \doc -> rename doc (Position 0 2) "fooBarQuux" - , ignoreForGhcVersions [GHC90, GHC92] recordConstructorIssue $ + , ignoreForGhcVersions [GHC92] recordConstructorIssue $ goldenWithRename "Record field" "RecordField" $ \doc -> rename doc (Position 6 9) "number" , goldenWithRename "Shadowed name" "ShadowedName" $ \doc -> @@ -64,11 +69,78 @@ rename doc (Position 2 17) "BinaryTree" , goldenWithRename "Type variable" "TypeVariable" $ \doc -> rename doc (Position 0 13) "b" + , goldenWithRename "Rename within comment" "Comment" $ \doc -> do + let expectedError = ResponseError + (InR ErrorCodes_InvalidParams) + "rename: Invalid Params: No symbol to rename at given position" + Nothing + renameExpectError expectedError doc (Position 0 10) "ImpossibleRename" + + , testCase "fails when module does not compile" $ runRenameSession "" $ do + doc <- openDoc "FunctionArgument.hs" "haskell" + expectNoMoreDiagnostics 3 doc "typecheck" + + -- Update the document so it doesn't compile + let change = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 2 13) (Position 2 17) + .+ #rangeLength .== Nothing + .+ #text .== "A" + changeDoc doc [change] + diags@(tcDiag : _) <- waitForDiagnosticsFrom doc + + -- Make sure there's a typecheck error + liftIO $ do + length diags @?= 1 + tcDiag ^. L.range @?= Range (Position 2 13) (Position 2 14) + tcDiag ^. L.severity @?= Just DiagnosticSeverity_Error + tcDiag ^. L.source @?= Just "typecheck" + + -- Make sure renaming fails + renameErr <- expectRenameError doc (Position 3 0) "foo'" + liftIO $ do + renameErr ^. L.code @?= InL LSPErrorCodes_RequestFailed + renameErr ^. L.message @?= "rename: Rule Failed: GetHieAst" + + -- Update the document so it compiles + let change' = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 2 13) (Position 2 14) + .+ #rangeLength .== Nothing + .+ #text .== "Int" + changeDoc doc [change'] + expectNoMoreDiagnostics 3 doc "typecheck" + + -- Make sure renaming succeeds + rename doc (Position 3 0) "foo'" ] goldenWithRename :: TestName-> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree goldenWithRename title path act = - goldenWithHaskellDoc (def { plugins = M.fromList [("rename", def { plcConfig = "crossModule" .= True })] }) renamePlugin title testDataDir path "expected" "hs" act + goldenWithHaskellDoc (def { plugins = M.fromList [("rename", def { plcConfig = "crossModule" .= True })] }) + renamePlugin title testDataDir path "expected" "hs" act +renameExpectError :: ResponseError -> TextDocumentIdentifier -> Position -> Text -> Session () +renameExpectError expectedError doc pos newName = do + let params = RenameParams Nothing doc pos newName + rsp <- request SMethod_TextDocumentRename params + case rsp ^. L.result of + Right _ -> liftIO $ assertFailure $ "Was expecting " <> show expectedError <> ", got success" + Left actualError -> liftIO $ assertEqual "ResponseError" expectedError actualError + testDataDir :: FilePath testDataDir = "plugins" "hls-rename-plugin" "test" "testdata" + +-- | Attempts to renames the term at the specified position, expecting a failure +expectRenameError :: + TextDocumentIdentifier -> + Position -> + String -> + Session ResponseError +expectRenameError doc pos newName = do + let params = RenameParams Nothing doc pos (pack newName) + rsp <- request SMethod_TextDocumentRename params + case rsp ^. L.result of + Left err -> pure err + Right _ -> liftIO $ assertFailure $ + "Got unexpected successful rename response for " <> show (doc ^. L.uri) + +runRenameSession :: FilePath -> Session a -> IO a +runRenameSession subdir = failIfSessionTimeout + . runSessionWithServerAndCaps def renamePlugin codeActionNoResolveCaps (testDataDir subdir) diff --git a/plugins/hls-rename-plugin/test/testdata/Comment.expected.hs b/plugins/hls-rename-plugin/test/testdata/Comment.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/Comment.expected.hs @@ -0,0 +1,1 @@ +{- IShouldNotBeRenaemable -} diff --git a/plugins/hls-rename-plugin/test/testdata/Comment.hs b/plugins/hls-rename-plugin/test/testdata/Comment.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-rename-plugin/test/testdata/Comment.hs @@ -0,0 +1,1 @@ +{- IShouldNotBeRenaemable -} diff --git a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -11,7 +11,7 @@ {-# OPTIONS -Wno-orphans #-} -module Ide.Plugin.Retrie (descriptor) where +module Ide.Plugin.Retrie (descriptor, Log) where import Control.Concurrent.STM (readTVarIO) import Control.Exception.Safe (Exception (..), @@ -135,11 +135,18 @@ import GHC.Types.PkgQual #endif -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor plId = +data Log + = LogParsingModule FilePath + +instance Pretty Log where + pretty = \case + LogParsingModule fp -> "Parsing module:" <+> pretty fp + +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = (defaultPluginDescriptor plId "Provides code actions to inline Haskell definitions") { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction provider, - pluginCommands = [retrieCommand, retrieInlineThisCommand] + pluginCommands = [retrieCommand recorder, retrieInlineThisCommand recorder] } retrieCommandId :: CommandId @@ -148,14 +155,14 @@ retrieInlineThisCommandId :: CommandId retrieInlineThisCommandId = "retrieInlineThisCommand" -retrieCommand :: PluginCommand IdeState -retrieCommand = - PluginCommand retrieCommandId "run the refactoring" runRetrieCmd +retrieCommand :: Recorder (WithPriority Log) -> PluginCommand IdeState +retrieCommand recorder = + PluginCommand retrieCommandId "run the refactoring" (runRetrieCmd recorder) -retrieInlineThisCommand :: PluginCommand IdeState -retrieInlineThisCommand = +retrieInlineThisCommand :: Recorder (WithPriority Log) -> PluginCommand IdeState +retrieInlineThisCommand recorder = PluginCommand retrieInlineThisCommandId "inline function call" - runRetrieInlineThisCmd + (runRetrieInlineThisCmd recorder) -- | Parameters for the runRetrie PluginCommand. data RunRetrieParams = RunRetrieParams @@ -166,8 +173,8 @@ } deriving (Eq, Show, Generic, FromJSON, ToJSON) -runRetrieCmd :: CommandFunction IdeState RunRetrieParams -runRetrieCmd state token RunRetrieParams{originatingFile = uri, ..} = ExceptT $ +runRetrieCmd :: Recorder (WithPriority Log) -> CommandFunction IdeState RunRetrieParams +runRetrieCmd recorder state token RunRetrieParams{originatingFile = uri, ..} = ExceptT $ withIndefiniteProgress description token Cancellable $ \_updater -> do _ <- runExceptT $ do nfp <- getNormalizedFilePathE uri @@ -179,6 +186,7 @@ let importRewrites = concatMap (extractImports ms binds) rewrites (errors, edits) <- liftIO $ callRetrie + recorder state (hscEnv session) (map Right rewrites <> map Left importRewrites) @@ -201,8 +209,8 @@ } deriving (Eq, Show, Generic, FromJSON, ToJSON) -runRetrieInlineThisCmd :: CommandFunction IdeState RunRetrieInlineThisParams -runRetrieInlineThisCmd state _token RunRetrieInlineThisParams{..} = do +runRetrieInlineThisCmd :: Recorder (WithPriority Log) -> CommandFunction IdeState RunRetrieInlineThisParams +runRetrieInlineThisCmd recorder state _token RunRetrieInlineThisParams{..} = do nfp <- getNormalizedFilePathE $ getLocationUri inlineIntoThisLocation nfpSource <- getNormalizedFilePathE $ getLocationUri inlineFromThisLocation -- What we do here: @@ -219,7 +227,7 @@ when (null inlineRewrite) $ throwError $ PluginInternalError "Empty rewrite" (session, _) <- runActionE "retrie" state $ useWithStaleE GhcSessionDeps nfp - (fixityEnv, cpp) <- liftIO $ getCPPmodule state (hscEnv session) $ fromNormalizedFilePath nfp + (fixityEnv, cpp) <- liftIO $ getCPPmodule recorder state (hscEnv session) $ fromNormalizedFilePath nfp result <- liftIO $ try @_ @SomeException $ runRetrie fixityEnv (applyWithUpdate myContextUpdater inlineRewrite) cpp case result of @@ -506,13 +514,14 @@ instance Exception CallRetrieError callRetrie :: + Recorder (WithPriority Log) -> IdeState -> HscEnv -> [Either ImportSpec RewriteSpec] -> NormalizedFilePath -> Bool -> IO ([CallRetrieError], WorkspaceEdit) -callRetrie state session rewrites origin restrictToOriginatingFile = do +callRetrie recorder state session rewrites origin restrictToOriginatingFile = do knownFiles <- toKnownFiles . unhashed <$> readTVarIO (knownTargetsVar $ shakeExtras state) let -- TODO cover all workspaceFolders @@ -540,7 +549,7 @@ targets <- getTargetFiles retrieOptions (getGroundTerms retrie) results <- forM targets $ \t -> runExceptT $ do - (fixityEnv, cpp) <- ExceptT $ try $ getCPPmodule state session t + (fixityEnv, cpp) <- ExceptT $ try $ getCPPmodule recorder state session t -- TODO add the imports to the resulting edits (_user, _ast, change@(Change _replacements _imports)) <- lift $ runRetrie fixityEnv retrie cpp @@ -751,8 +760,8 @@ (fixities, pm') <- fixFixities state f (fixAnns pm) return (fixities, pm') -getCPPmodule :: IdeState -> HscEnv -> FilePath -> IO (FixityEnv, CPP AnnotatedModule) -getCPPmodule state session t = do +getCPPmodule :: Recorder (WithPriority Log) -> IdeState -> HscEnv -> FilePath -> IO (FixityEnv, CPP AnnotatedModule) +getCPPmodule recorder state session t = do nt <- toNormalizedFilePath' <$> makeAbsolute t let getParsedModule f contents = do modSummary <- msrModSummary <$> @@ -762,7 +771,7 @@ { ms_hspp_buf = Just (stringToStringBuffer contents) } - logPriority (ideLogger state) Info $ T.pack $ "Parsing module: " <> t + logWith recorder Info $ LogParsingModule t parsed <- evalGhcEnv session (GHCGHC.parseModule ms') `catch` \e -> throwIO (GHCParseError nt (show @SomeException e)) (fixities, parsed) <- fixFixities state f (fixAnns parsed) diff --git a/plugins/hls-retrie-plugin/test/Main.hs b/plugins/hls-retrie-plugin/test/Main.hs --- a/plugins/hls-retrie-plugin/test/Main.hs +++ b/plugins/hls-retrie-plugin/test/Main.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PartialTypeSignatures #-} @@ -7,21 +8,31 @@ import Control.Monad (void) import qualified Data.Map as M import Data.Text (Text) -import qualified Development.IDE.GHC.ExactPrint +import qualified Development.IDE.GHC.ExactPrint as ExactPrint import qualified Development.IDE.Plugin.CodeAction as Refactor +import Ide.Logger import Ide.Plugin.Config import qualified Ide.Plugin.Retrie as Retrie import System.FilePath import Test.Hls +data LogWrap + = RetrieLog Retrie.Log + | ExactPrintLog ExactPrint.Log + +instance Pretty LogWrap where + pretty = \case + RetrieLog msg -> pretty msg + ExactPrintLog msg -> pretty msg + main :: IO () main = defaultTestRunner tests -retriePlugin :: PluginTestDescriptor a -retriePlugin = mkPluginTestDescriptor' Retrie.descriptor "retrie" +retriePlugin :: PluginTestDescriptor LogWrap +retriePlugin = mkPluginTestDescriptor (Retrie.descriptor . cmapWithPrio RetrieLog) "retrie" -refactorPlugin :: PluginTestDescriptor Development.IDE.GHC.ExactPrint.Log -refactorPlugin = mkPluginTestDescriptor Refactor.iePluginDescriptor "refactor" +refactorPlugin :: PluginTestDescriptor LogWrap +refactorPlugin = mkPluginTestDescriptor (Refactor.iePluginDescriptor . cmapWithPrio ExactPrintLog) "refactor" tests :: TestTree tests = testGroup "Retrie" @@ -74,12 +85,12 @@ goldenWithRetrie :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree goldenWithRetrie title path act = - goldenWithHaskellDoc (def { plugins = M.fromList [("retrie", def)] }) testPlugins title testDataDir path "expected" "hs" act + goldenWithHaskellDoc (def { plugins = M.singleton "retrie" def }) testPlugins title testDataDir path "expected" "hs" act runWithRetrie :: Session a -> IO a runWithRetrie = runSessionWithServer def testPlugins testDataDir -testPlugins :: PluginTestDescriptor Development.IDE.GHC.ExactPrint.Log +testPlugins :: PluginTestDescriptor LogWrap testPlugins = retriePlugin <> refactorPlugin -- needed for the GetAnnotatedParsedSource rule diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs --- a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs @@ -33,15 +33,14 @@ WithPriority, cmapWithPrio, define, fromNormalizedFilePath, - hieKind, use_) -import Development.IDE.Core.PluginUtils (runActionE, + hieKind) +import Development.IDE.Core.PluginUtils (runActionE, useE, useWithStaleE) import Development.IDE.Core.Rules (toIdeResult) import Development.IDE.Core.RuleTypes (DocAndTyThingMap (..)) import Development.IDE.Core.Shake (ShakeExtras (..), getShakeExtras, - getVirtualFile, - useWithStale_) + getVirtualFile) import Development.IDE.GHC.Compat hiding (Warning) import Development.IDE.GHC.Compat.Util (mkFastString) import Ide.Logger (logWith) @@ -124,8 +123,8 @@ getSemanticTokensRule :: Recorder (WithPriority SemanticLog) -> Rules () getSemanticTokensRule recorder = define (cmapWithPrio LogShake recorder) $ \GetSemanticTokens nfp -> handleError recorder $ do - (HAR {..}) <- lift $ use_ GetHieAst nfp - (DKMap {getTyThingMap}, _) <- lift $ useWithStale_ GetDocMap nfp + (HAR {..}) <- withExceptT LogDependencyError $ useE GetHieAst nfp + (DKMap {getTyThingMap}, _) <- withExceptT LogDependencyError $ useWithStaleE GetDocMap nfp ast <- handleMaybe (LogNoAST $ show nfp) $ getAsts hieAst M.!? (HiePath . mkFastString . fromNormalizedFilePath) nfp virtualFile <- handleMaybeM LogNoVF $ getVirtualFile nfp let hsFinder = idSemantic getTyThingMap (hieKindFunMasksKind hieKind) refMap diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Types.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Types.hs --- a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Types.hs +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Types.hs @@ -19,6 +19,7 @@ import Language.LSP.Protocol.Types -- import template haskell import Data.Text (Text) +import Ide.Plugin.Error (PluginError) import Language.Haskell.TH.Syntax (Lift) @@ -137,12 +138,12 @@ data SemanticLog = LogShake Shake.Log + | LogDependencyError PluginError | LogNoAST FilePath | LogConfig SemanticTokensConfig | LogMsg String | LogNoVF | LogSemanticTokensDeltaMisMatch Text (Maybe Text) - deriving (Show) instance Pretty SemanticLog where pretty theLog = case theLog of @@ -154,6 +155,7 @@ LogSemanticTokensDeltaMisMatch previousIdFromRequest previousIdFromCache -> "SemanticTokensDeltaMisMatch: previousIdFromRequest: " <> pretty previousIdFromRequest <> " previousIdFromCache: " <> pretty previousIdFromCache + LogDependencyError err -> "SemanticTokens' dependency error: " <> pretty err type SemanticTokenId = Text diff --git a/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs b/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs --- a/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs +++ b/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs @@ -148,7 +148,7 @@ FiascoL es -> do logWith recorder Development.IDE.Warning (LogWarnConf es) -- If we can't read the config file, default to using all inspections: - let allInspections = HM.fromList [(relativeHsFilePath, inspectionsIds)] + let allInspections = HM.singleton relativeHsFilePath inspectionsIds pure (allInspections, []) ResultL _warnings stanConfig -> do -- HashMap of *relative* file paths to info about enabled checks for those file paths. diff --git a/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs b/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs --- a/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs +++ b/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs @@ -1,9 +1,11 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} module Ide.Plugin.StylishHaskell ( descriptor , provider + , Log ) where @@ -26,9 +28,17 @@ import System.Directory import System.FilePath -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor plId = (defaultPluginDescriptor plId desc) - { pluginHandlers = mkFormattingHandlers provider +data Log + = LogLanguageExtensionFromDynFlags + +instance Pretty Log where + pretty = \case + LogLanguageExtensionFromDynFlags -> "stylish-haskell uses the language extensions from DynFlags" + + +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = (defaultPluginDescriptor plId desc) + { pluginHandlers = mkFormattingHandlers (provider recorder) } where desc = "Provides formatting of Haskell files via stylish-haskell. Built with stylish-haskell-" <> VERSION_stylish_haskell @@ -36,8 +46,8 @@ -- | Formatter provider of stylish-haskell. -- Formats the given source in either a given Range or the whole Document. -- If the provider fails an error is returned that can be displayed to the user. -provider :: FormattingHandler IdeState -provider ide _token typ contents fp _opts = do +provider :: Recorder (WithPriority Log) -> FormattingHandler IdeState +provider recorder ide _token typ contents fp _opts = do (msrModSummary -> ms_hspp_opts -> dyn) <- runActionE "stylish-haskell" ide $ useE GetModSummary fp let file = fromNormalizedFilePath fp config <- liftIO $ loadConfigFrom file @@ -53,7 +63,7 @@ getMergedConfig dyn config | null (configLanguageExtensions config) = do - logInfo (ideLogger ide) "stylish-haskell uses the language extensions from DynFlags" + logWith recorder Info LogLanguageExtensionFromDynFlags pure $ config { configLanguageExtensions = getExtensions dyn } diff --git a/plugins/hls-stylish-haskell-plugin/test/Main.hs b/plugins/hls-stylish-haskell-plugin/test/Main.hs --- a/plugins/hls-stylish-haskell-plugin/test/Main.hs +++ b/plugins/hls-stylish-haskell-plugin/test/Main.hs @@ -10,8 +10,8 @@ main :: IO () main = defaultTestRunner tests -stylishHaskellPlugin :: PluginTestDescriptor () -stylishHaskellPlugin = mkPluginTestDescriptor' StylishHaskell.descriptor "stylishHaskell" +stylishHaskellPlugin :: PluginTestDescriptor StylishHaskell.Log +stylishHaskellPlugin = mkPluginTestDescriptor StylishHaskell.descriptor "stylishHaskell" tests :: TestTree tests = testGroup "stylish-haskell" diff --git a/src/HlsPlugins.hs b/src/HlsPlugins.hs --- a/src/HlsPlugins.hs +++ b/src/HlsPlugins.hs @@ -93,6 +93,10 @@ import qualified Ide.Plugin.OverloadedRecordDot as OverloadedRecordDot #endif +#if hls_notes +import qualified Ide.Plugin.Notes as Notes +#endif + -- formatters #if hls_floskell @@ -107,6 +111,10 @@ import qualified Ide.Plugin.CabalFmt as CabalFmt #endif +#if hls_cabalgild +import qualified Ide.Plugin.CabalGild as CabalGild +#endif + #if hls_ormolu import qualified Ide.Plugin.Ormolu as Ormolu #endif @@ -157,21 +165,26 @@ let pId = "fourmolu" in Fourmolu.descriptor (pluginRecorder pId) pId: #endif #if hls_cabalfmt + let pId = "cabal-fmt" in CabalFmt.descriptor (pluginRecorder pId) pId: +#endif +#if hls_cabalgild -- this pId needs to be kept in sync with the hardcoded -- cabalFormattingProvider in the Default Config - let pId = "cabal-fmt" in CabalFmt.descriptor (pluginRecorder pId) pId: + let pId = "cabal-gild" in CabalGild.descriptor (pluginRecorder pId) pId: #endif #if hls_ormolu + -- this pId needs to be kept in sync with the hardcoded + -- haskellFormattingProvider in the Default Config let pId = "ormolu" in Ormolu.descriptor (pluginRecorder pId) pId : #endif #if hls_stylishHaskell - StylishHaskell.descriptor "stylish-haskell" : + let pId = "stylish-haskell" in StylishHaskell.descriptor (pluginRecorder pId) pId : #endif #if hls_rename let pId = "rename" in Rename.descriptor (pluginRecorder pId) pId: #endif #if hls_retrie - Retrie.descriptor "retrie" : + let pId = "retrie" in Retrie.descriptor (pluginRecorder pId) pId : #endif #if hls_callHierarchy CallHierarchy.descriptor "callHierarchy" : @@ -230,6 +243,9 @@ #endif #if hls_overloaded_record_dot let pId = "overloaded-record-dot" in OverloadedRecordDot.descriptor (pluginRecorder pId) pId : +#endif +#if hls_notes + let pId = "notes" in Notes.descriptor (pluginRecorder pId) pId : #endif GhcIde.descriptors (pluginRecorder "ghcide") diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -12,18 +12,18 @@ import qualified Data.Aeson.Encode.Pretty as A import Data.Coerce (coerce) import Data.Default +import Data.Function ((&)) import Data.List (sortOn) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Lazy.Encoding (decodeUtf8) import qualified Data.Text.Lazy.IO as LT import Development.IDE.Core.Rules hiding (Log, logToPriority) -import Development.IDE.Core.Tracing (withTelemetryLogger) +import Development.IDE.Core.Tracing (withTelemetryRecorder) import Development.IDE.Main (isLSP) import qualified Development.IDE.Main as IDEMain import qualified Development.IDE.Session as Session import qualified Development.IDE.Types.Options as Ghcide -import GHC.Stack (emptyCallStack) import qualified HIE.Bios.Environment as HieBios import HIE.Bios.Types hiding (Log) import qualified HIE.Bios.Types as HieBios @@ -121,7 +121,7 @@ -- --------------------------------------------------------------------- runLspMode :: Recorder (WithPriority Log) -> GhcideArguments -> IdePlugins IdeState -> IO () -runLspMode recorder ghcideArgs@GhcideArguments{..} idePlugins = withTelemetryLogger $ \telemetryLogger -> do +runLspMode recorder ghcideArgs@GhcideArguments{..} idePlugins = withTelemetryRecorder $ \telemetryRecorder' -> do let log = logWith recorder whenJust argsCwd IO.setCurrentDirectory dir <- IO.getCurrentDirectory @@ -130,14 +130,13 @@ when (isLSP argsCommand) $ do log Info $ LogLspStart ghcideArgs (map pluginId $ ipMap idePlugins) - -- exists so old-style logging works. intended to be phased out - let logger = Logger $ \p m -> logger_ recorder (WithPriority p emptyCallStack $ LogOther m) - args = (if argsTesting then IDEMain.testing else IDEMain.defaultArguments) - (cmapWithPrio LogIDEMain recorder) logger idePlugins + let args = (if argsTesting then IDEMain.testing else IDEMain.defaultArguments) + (cmapWithPrio LogIDEMain recorder) idePlugins - IDEMain.defaultMain (cmapWithPrio LogIDEMain recorder) args + let telemetryRecorder = telemetryRecorder' & cmapWithPrio pretty + + IDEMain.defaultMain (cmapWithPrio LogIDEMain $ recorder <> telemetryRecorder) args { IDEMain.argCommand = argsCommand - , IDEMain.argsLogger = pure logger <> pure telemetryLogger , IDEMain.argsThreads = if argsThreads == 0 then Nothing else Just $ fromIntegral argsThreads , IDEMain.argsIdeOptions = \config sessionLoader -> let defOptions = IDEMain.argsIdeOptions args config sessionLoader diff --git a/test/functional/Main.hs b/test/functional/Main.hs --- a/test/functional/Main.hs +++ b/test/functional/Main.hs @@ -12,8 +12,8 @@ main = defaultTestRunner $ testGroup "haskell-language-server" [ Config.tests , ConfigSchema.tests - , ignoreInEnv [HostOS Windows, GhcVer GHC90, GhcVer GHC92] "Tests gets stuck in ci" $ Format.tests + , ignoreInEnv [HostOS Windows, GhcVer GHC92] "Tests gets stuck in ci" $ Format.tests , FunctionalBadProject.tests , HieBios.tests - , ignoreInEnv [HostOS Windows, GhcVer GHC90] "Tests gets stuck in ci" $ Progress.tests + , ignoreInEnv [HostOS Windows] "Tests gets stuck in ci" $ Progress.tests ] diff --git a/test/functional/Progress.hs b/test/functional/Progress.hs --- a/test/functional/Progress.hs +++ b/test/functional/Progress.hs @@ -37,7 +37,7 @@ (codeLensResponse, activeProgressTokens) <- expectProgressMessagesTill (responseForId SMethod_TextDocumentCodeLens lspId) - ["Setting up testdata (for T1.hs)", "Processing", "Indexing"] + ["Setting up testdata (for T1.hs)", "Processing"] [] -- this is a test so exceptions result in fails @@ -59,7 +59,7 @@ void configurationRequest setHlsConfig (formatLspConfig "ormolu") doc <- openDoc "Format.hs" "haskell" - expectProgressMessages ["Setting up testdata (for Format.hs)", "Processing", "Indexing"] [] + expectProgressMessages ["Setting up format (for Format.hs)", "Processing", "Indexing"] [] _ <- sendRequest SMethod_TextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing) expectProgressMessages ["Formatting Format.hs"] [] , requiresFourmoluPlugin $ testCase "fourmolu plugin sends progress notifications" $ do @@ -67,7 +67,7 @@ void configurationRequest setHlsConfig (formatLspConfig "fourmolu") doc <- openDoc "Format.hs" "haskell" - expectProgressMessages ["Setting up testdata (for Format.hs)", "Processing", "Indexing"] [] + expectProgressMessages ["Setting up format (for Format.hs)", "Processing", "Indexing"] [] _ <- sendRequest SMethod_TextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing) expectProgressMessages ["Formatting Format.hs"] [] ] diff --git a/test/testdata/hieBiosMainIs/dist-newstyle/cache/plan.json b/test/testdata/hieBiosMainIs/dist-newstyle/cache/plan.json new file mode 100644 --- /dev/null +++ b/test/testdata/hieBiosMainIs/dist-newstyle/cache/plan.json @@ -0,0 +1,1 @@ +{"cabal-version":"3.10.2.0","cabal-lib-version":"3.10.2.1","compiler-id":"ghc-9.8.1","os":"linux","arch":"x86_64","install-plan":[{"type":"pre-existing","id":"base-4.19.0.0-c1f2","pkg-name":"base","pkg-version":"4.19.0.0","depends":["ghc-bignum-1.3-d2d5","ghc-prim-0.11.0-b1d6","rts-1.0.2"]},{"type":"pre-existing","id":"ghc-bignum-1.3-d2d5","pkg-name":"ghc-bignum","pkg-version":"1.3","depends":["ghc-prim-0.11.0-b1d6"]},{"type":"pre-existing","id":"ghc-prim-0.11.0-b1d6","pkg-name":"ghc-prim","pkg-version":"0.11.0","depends":["rts-1.0.2"]},{"type":"configured","id":"hieBiosMainIs-0.1.0.0-inplace-hieBiosMainIs","pkg-name":"hieBiosMainIs","pkg-version":"0.1.0.0","flags":{},"style":"local","pkg-src":{"type":"local","path":"/home/zubin/haskell-language-server/test/testdata/hieBiosMainIs/."},"dist-dir":"/home/zubin/haskell-language-server/test/testdata/hieBiosMainIs/dist-newstyle/build/x86_64-linux/ghc-9.8.1/hieBiosMainIs-0.1.0.0/x/hieBiosMainIs","build-info":"/home/zubin/haskell-language-server/test/testdata/hieBiosMainIs/dist-newstyle/build/x86_64-linux/ghc-9.8.1/hieBiosMainIs-0.1.0.0/x/hieBiosMainIs/build-info.json","depends":["base-4.19.0.0-c1f2"],"exe-depends":[],"component-name":"exe:hieBiosMainIs","bin-file":"/home/zubin/haskell-language-server/test/testdata/hieBiosMainIs/dist-newstyle/build/x86_64-linux/ghc-9.8.1/hieBiosMainIs-0.1.0.0/x/hieBiosMainIs/build/hieBiosMainIs/hieBiosMainIs"},{"type":"pre-existing","id":"rts-1.0.2","pkg-name":"rts","pkg-version":"1.0.2","depends":[]}]} diff --git a/test/testdata/missingModuleTest/missingModule/dist-newstyle/cache/plan.json b/test/testdata/missingModuleTest/missingModule/dist-newstyle/cache/plan.json new file mode 100644 --- /dev/null +++ b/test/testdata/missingModuleTest/missingModule/dist-newstyle/cache/plan.json @@ -0,0 +1,1 @@ +{"cabal-version":"3.10.2.0","cabal-lib-version":"3.10.2.1","compiler-id":"ghc-9.8.1","os":"linux","arch":"x86_64","install-plan":[{"type":"pre-existing","id":"base-4.19.0.0-c1f2","pkg-name":"base","pkg-version":"4.19.0.0","depends":["ghc-bignum-1.3-d2d5","ghc-prim-0.11.0-b1d6","rts-1.0.2"]},{"type":"pre-existing","id":"ghc-bignum-1.3-d2d5","pkg-name":"ghc-bignum","pkg-version":"1.3","depends":["ghc-prim-0.11.0-b1d6"]},{"type":"pre-existing","id":"ghc-prim-0.11.0-b1d6","pkg-name":"ghc-prim","pkg-version":"0.11.0","depends":["rts-1.0.2"]},{"type":"configured","id":"missingModule-0.1.0.0-inplace","pkg-name":"missingModule","pkg-version":"0.1.0.0","flags":{},"style":"local","pkg-src":{"type":"local","path":"/home/zubin/haskell-language-server/test/testdata/missingModuleTest/missingModule/."},"dist-dir":"/home/zubin/haskell-language-server/test/testdata/missingModuleTest/missingModule/dist-newstyle/build/x86_64-linux/ghc-9.8.1/missingModule-0.1.0.0","build-info":"/home/zubin/haskell-language-server/test/testdata/missingModuleTest/missingModule/dist-newstyle/build/x86_64-linux/ghc-9.8.1/missingModule-0.1.0.0/build-info.json","depends":["base-4.19.0.0-c1f2"],"exe-depends":[],"component-name":"lib"},{"type":"pre-existing","id":"rts-1.0.2","pkg-name":"rts","pkg-version":"1.0.2","depends":[]}]} diff --git a/test/testdata/missingModuleTest/noPrefixMatch/dist-newstyle/cache/plan.json b/test/testdata/missingModuleTest/noPrefixMatch/dist-newstyle/cache/plan.json new file mode 100644 --- /dev/null +++ b/test/testdata/missingModuleTest/noPrefixMatch/dist-newstyle/cache/plan.json @@ -0,0 +1,1 @@ +{"cabal-version":"3.10.2.0","cabal-lib-version":"3.10.2.1","compiler-id":"ghc-9.8.1","os":"linux","arch":"x86_64","install-plan":[{"type":"pre-existing","id":"base-4.19.0.0-c1f2","pkg-name":"base","pkg-version":"4.19.0.0","depends":["ghc-bignum-1.3-d2d5","ghc-prim-0.11.0-b1d6","rts-1.0.2"]},{"type":"pre-existing","id":"ghc-bignum-1.3-d2d5","pkg-name":"ghc-bignum","pkg-version":"1.3","depends":["ghc-prim-0.11.0-b1d6"]},{"type":"pre-existing","id":"ghc-prim-0.11.0-b1d6","pkg-name":"ghc-prim","pkg-version":"0.11.0","depends":["rts-1.0.2"]},{"type":"configured","id":"noPrefixMatch-0.1.0.0-inplace-testExe","pkg-name":"noPrefixMatch","pkg-version":"0.1.0.0","flags":{},"style":"local","pkg-src":{"type":"local","path":"/home/zubin/haskell-language-server/test/testdata/missingModuleTest/noPrefixMatch/."},"dist-dir":"/home/zubin/haskell-language-server/test/testdata/missingModuleTest/noPrefixMatch/dist-newstyle/build/x86_64-linux/ghc-9.8.1/noPrefixMatch-0.1.0.0/x/testExe","build-info":"/home/zubin/haskell-language-server/test/testdata/missingModuleTest/noPrefixMatch/dist-newstyle/build/x86_64-linux/ghc-9.8.1/noPrefixMatch-0.1.0.0/x/testExe/build-info.json","depends":["base-4.19.0.0-c1f2"],"exe-depends":[],"component-name":"exe:testExe","bin-file":"/home/zubin/haskell-language-server/test/testdata/missingModuleTest/noPrefixMatch/dist-newstyle/build/x86_64-linux/ghc-9.8.1/noPrefixMatch-0.1.0.0/x/testExe/build/testExe/testExe"},{"type":"pre-existing","id":"rts-1.0.2","pkg-name":"rts","pkg-version":"1.0.2","depends":[]}]} diff --git a/test/testdata/schema/ghc92/default-config.golden.json b/test/testdata/schema/ghc92/default-config.golden.json --- a/test/testdata/schema/ghc92/default-config.golden.json +++ b/test/testdata/schema/ghc92/default-config.golden.json @@ -1,4 +1,5 @@ { + "cabalFormattingProvider": "cabal-gild", "checkParents": "CheckOnSave", "checkProject": true, "formattingProvider": "ormolu", @@ -12,6 +13,16 @@ "completionOn": true, "diagnosticsOn": true }, + "cabal-fmt": { + "config": { + "path": "cabal-fmt" + } + }, + "cabal-gild": { + "config": { + "path": "cabal-gild" + } + }, "callHierarchy": { "globalOn": true }, @@ -137,5 +148,6 @@ "splice": { "globalOn": true } - } + }, + "sessionLoading": "singleComponent" } diff --git a/test/testdata/schema/ghc92/vscode-extension-schema.golden.json b/test/testdata/schema/ghc92/vscode-extension-schema.golden.json --- a/test/testdata/schema/ghc92/vscode-extension-schema.golden.json +++ b/test/testdata/schema/ghc92/vscode-extension-schema.golden.json @@ -5,6 +5,18 @@ "scope": "resource", "type": "boolean" }, + "haskell.plugin.cabal-fmt.config.path": { + "default": "cabal-fmt", + "markdownDescription": "Set path to 'cabal-fmt' executable", + "scope": "resource", + "type": "string" + }, + "haskell.plugin.cabal-gild.config.path": { + "default": "cabal-gild", + "markdownDescription": "Set path to 'cabal-gild' executable", + "scope": "resource", + "type": "string" + }, "haskell.plugin.cabal.codeActionsOn": { "default": true, "description": "Enables cabal code actions", diff --git a/test/testdata/schema/ghc94/default-config.golden.json b/test/testdata/schema/ghc94/default-config.golden.json --- a/test/testdata/schema/ghc94/default-config.golden.json +++ b/test/testdata/schema/ghc94/default-config.golden.json @@ -1,4 +1,5 @@ { + "cabalFormattingProvider": "cabal-gild", "checkParents": "CheckOnSave", "checkProject": true, "formattingProvider": "ormolu", @@ -12,6 +13,16 @@ "completionOn": true, "diagnosticsOn": true }, + "cabal-fmt": { + "config": { + "path": "cabal-fmt" + } + }, + "cabal-gild": { + "config": { + "path": "cabal-gild" + } + }, "callHierarchy": { "globalOn": true }, @@ -140,5 +151,6 @@ "stan": { "globalOn": false } - } + }, + "sessionLoading": "singleComponent" } diff --git a/test/testdata/schema/ghc94/vscode-extension-schema.golden.json b/test/testdata/schema/ghc94/vscode-extension-schema.golden.json --- a/test/testdata/schema/ghc94/vscode-extension-schema.golden.json +++ b/test/testdata/schema/ghc94/vscode-extension-schema.golden.json @@ -5,6 +5,18 @@ "scope": "resource", "type": "boolean" }, + "haskell.plugin.cabal-fmt.config.path": { + "default": "cabal-fmt", + "markdownDescription": "Set path to 'cabal-fmt' executable", + "scope": "resource", + "type": "string" + }, + "haskell.plugin.cabal-gild.config.path": { + "default": "cabal-gild", + "markdownDescription": "Set path to 'cabal-gild' executable", + "scope": "resource", + "type": "string" + }, "haskell.plugin.cabal.codeActionsOn": { "default": true, "description": "Enables cabal code actions", diff --git a/test/testdata/schema/ghc96/default-config.golden.json b/test/testdata/schema/ghc96/default-config.golden.json --- a/test/testdata/schema/ghc96/default-config.golden.json +++ b/test/testdata/schema/ghc96/default-config.golden.json @@ -1,4 +1,5 @@ { + "cabalFormattingProvider": "cabal-gild", "checkParents": "CheckOnSave", "checkProject": true, "formattingProvider": "ormolu", @@ -12,6 +13,16 @@ "completionOn": true, "diagnosticsOn": true }, + "cabal-fmt": { + "config": { + "path": "cabal-fmt" + } + }, + "cabal-gild": { + "config": { + "path": "cabal-gild" + } + }, "callHierarchy": { "globalOn": true }, @@ -140,5 +151,6 @@ "stan": { "globalOn": false } - } + }, + "sessionLoading": "singleComponent" } diff --git a/test/testdata/schema/ghc96/vscode-extension-schema.golden.json b/test/testdata/schema/ghc96/vscode-extension-schema.golden.json --- a/test/testdata/schema/ghc96/vscode-extension-schema.golden.json +++ b/test/testdata/schema/ghc96/vscode-extension-schema.golden.json @@ -5,6 +5,18 @@ "scope": "resource", "type": "boolean" }, + "haskell.plugin.cabal-fmt.config.path": { + "default": "cabal-fmt", + "markdownDescription": "Set path to 'cabal-fmt' executable", + "scope": "resource", + "type": "string" + }, + "haskell.plugin.cabal-gild.config.path": { + "default": "cabal-gild", + "markdownDescription": "Set path to 'cabal-gild' executable", + "scope": "resource", + "type": "string" + }, "haskell.plugin.cabal.codeActionsOn": { "default": true, "description": "Enables cabal code actions", diff --git a/test/testdata/schema/ghc98/default-config.golden.json b/test/testdata/schema/ghc98/default-config.golden.json --- a/test/testdata/schema/ghc98/default-config.golden.json +++ b/test/testdata/schema/ghc98/default-config.golden.json @@ -1,4 +1,5 @@ { + "cabalFormattingProvider": "cabal-gild", "checkParents": "CheckOnSave", "checkProject": true, "formattingProvider": "ormolu", @@ -12,6 +13,16 @@ "completionOn": true, "diagnosticsOn": true }, + "cabal-fmt": { + "config": { + "path": "cabal-fmt" + } + }, + "cabal-gild": { + "config": { + "path": "cabal-gild" + } + }, "callHierarchy": { "globalOn": true }, @@ -73,6 +84,13 @@ }, "globalOn": true }, + "hlint": { + "codeActionsOn": true, + "config": { + "flags": [] + }, + "diagnosticsOn": true + }, "importLens": { "codeActionsOn": true, "codeLensOn": true @@ -133,5 +151,6 @@ "stan": { "globalOn": false } - } + }, + "sessionLoading": "singleComponent" } diff --git a/test/testdata/schema/ghc98/vscode-extension-schema.golden.json b/test/testdata/schema/ghc98/vscode-extension-schema.golden.json --- a/test/testdata/schema/ghc98/vscode-extension-schema.golden.json +++ b/test/testdata/schema/ghc98/vscode-extension-schema.golden.json @@ -5,6 +5,18 @@ "scope": "resource", "type": "boolean" }, + "haskell.plugin.cabal-fmt.config.path": { + "default": "cabal-fmt", + "markdownDescription": "Set path to 'cabal-fmt' executable", + "scope": "resource", + "type": "string" + }, + "haskell.plugin.cabal-gild.config.path": { + "default": "cabal-gild", + "markdownDescription": "Set path to 'cabal-gild' executable", + "scope": "resource", + "type": "string" + }, "haskell.plugin.cabal.codeActionsOn": { "default": true, "description": "Enables cabal code actions", @@ -168,6 +180,24 @@ "haskell.plugin.ghcide-type-lenses.globalOn": { "default": true, "description": "Enables ghcide-type-lenses plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.hlint.codeActionsOn": { + "default": true, + "description": "Enables hlint code actions", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.hlint.config.flags": { + "default": [], + "markdownDescription": "Flags used by hlint", + "scope": "resource", + "type": "array" + }, + "haskell.plugin.hlint.diagnosticsOn": { + "default": true, + "description": "Enables hlint diagnostics", "scope": "resource", "type": "boolean" }, diff --git a/test/utils/Test/Hls/Flags.hs b/test/utils/Test/Hls/Flags.hs --- a/test/utils/Test/Hls/Flags.hs +++ b/test/utils/Test/Hls/Flags.hs @@ -10,7 +10,7 @@ -- | Disable test unless the eval flag is set requiresEvalPlugin :: TestTree -> TestTree -#if eval +#if hls_eval requiresEvalPlugin = id #else requiresEvalPlugin = ignoreTestBecause "Eval plugin disabled" @@ -19,7 +19,7 @@ -- * Formatters -- | Disable test unless the floskell flag is set requiresFloskellPlugin :: TestTree -> TestTree -#if floskell +#if hls_floskell requiresFloskellPlugin = id #else requiresFloskellPlugin = ignoreTestBecause "Floskell plugin disabled" @@ -27,7 +27,7 @@ -- | Disable test unless the fourmolu flag is set requiresFourmoluPlugin :: TestTree -> TestTree -#if fourmolu +#if hls_fourmolu requiresFourmoluPlugin = id #else requiresFourmoluPlugin = ignoreTestBecause "Fourmolu plugin disabled" @@ -35,7 +35,7 @@ -- | Disable test unless the ormolu flag is set requiresOrmoluPlugin :: TestTree -> TestTree -#if ormolu +#if hls_ormolu requiresOrmoluPlugin = id #else requiresOrmoluPlugin = ignoreTestBecause "Ormolu plugin disabled" diff --git a/test/wrapper/Main.hs b/test/wrapper/Main.hs --- a/test/wrapper/Main.hs +++ b/test/wrapper/Main.hs @@ -9,10 +9,16 @@ projectGhcVersionTests :: TestTree projectGhcVersionTests = testGroup "--project-ghc-version" - [ stackTest "9.2.8" + [ testCase "stack with global ghc" $ do + ghcVer <- ghcNumericVersion + let writeStackYaml = writeFile "stack.yaml" $ + -- Use system-ghc and install-ghc to avoid stack downloading ghc in CI + -- (and use ghcup-managed ghc instead) + "{resolver: ghc-" ++ ghcVer ++ ", system-ghc: true, install-ghc: false}" + testDir writeStackYaml "test/wrapper/testdata/stack-specific-ghc" ghcVer , testCase "cabal with global ghc" $ do - ghcVer <- trimEnd <$> readProcess "ghc" ["--numeric-version"] "" - testDir "test/wrapper/testdata/cabal-cur-ver" ghcVer + ghcVer <- ghcNumericVersion + testDir (pure ()) "test/wrapper/testdata/cabal-cur-ver" ghcVer , testCase "stack with existing cabal build artifact" $ do -- Should report cabal as existing build artifacts are more important than -- the existence of 'stack.yaml' @@ -20,12 +26,12 @@ ("cradleOptsProg = CradleAction: Cabal" `isInfixOf`) ] where - stackTest ghcVer= testCase ("stack with ghc " ++ ghcVer) $ - testDir ("test/wrapper/testdata/stack-" ++ ghcVer) ghcVer + ghcNumericVersion = trimEnd <$> readProcess "ghc" ["--numeric-version"] "" -testDir :: FilePath -> String -> Assertion -testDir dir expectedVer = +testDir :: IO () -> FilePath -> String -> Assertion +testDir extraSetup dir expectedVer = withCurrentDirectoryInTmp dir $ do + extraSetup testExe <- fromMaybe "haskell-language-server-wrapper" <$> lookupEnv "HLS_WRAPPER_TEST_EXE" actualVer <- trimEnd <$> readProcess testExe ["--project-ghc-version"] ""