haskell-language-server 2.7.0.0 → 2.8.0.0
raw patch · 130 files changed
+6519/−705 lines, 130 filesdep +QuickCheckdep +asyncdep +enummapsetdep ~basedep ~extradep ~ghcidePVP ok
version bump matches the API change (PVP)
Dependencies added: QuickCheck, async, enummapset, ghc-typelits-knownnat, list-t, monoid-subclasses, network-uri, random, tasty-rerun
Dependency ranges changed: base, extra, ghcide, hls-graph, hls-plugin-api, hls-test-utils, lsp, lsp-test, lsp-types, mtl, process-extras, regex-tdfa, stylish-haskell, tasty-hunit, unordered-containers
API changes (from Hackage documentation)
Files
- ChangeLog.md +113/−0
- bench/Main.hs +0/−2
- exe/Wrapper.hs +7/−10
- ghcide/test/exe/AsyncTests.hs +53/−0
- ghcide/test/exe/BootTests.hs +55/−0
- ghcide/test/exe/CPPTests.hs +56/−0
- ghcide/test/exe/ClientSettingsTests.hs +34/−0
- ghcide/test/exe/CodeLensTests.hs +114/−0
- ghcide/test/exe/CompletionTests.hs +574/−0
- ghcide/test/exe/Config.hs +16/−0
- ghcide/test/exe/CradleTests.hs +238/−0
- ghcide/test/exe/DependentFileTest.hs +58/−0
- ghcide/test/exe/DiagnosticTests.hs +577/−0
- ghcide/test/exe/ExceptionTests.hs +156/−0
- ghcide/test/exe/FindDefinitionAndHoverTests.hs +235/−0
- ghcide/test/exe/FuzzySearch.hs +129/−0
- ghcide/test/exe/GarbageCollectionTests.hs +94/−0
- ghcide/test/exe/HaddockTests.hs +90/−0
- ghcide/test/exe/HieDbRetry.hs +136/−0
- ghcide/test/exe/HighlightTests.hs +79/−0
- ghcide/test/exe/IfaceTests.hs +163/−0
- ghcide/test/exe/InitializeResponseTests.hs +91/−0
- ghcide/test/exe/LogType.hs +21/−0
- ghcide/test/exe/Main.hs +118/−0
- ghcide/test/exe/NonLspCommandLine.hs +27/−0
- ghcide/test/exe/OpenCloseTest.hs +18/−0
- ghcide/test/exe/OutlineTests.hs +189/−0
- ghcide/test/exe/PluginSimpleTests.hs +50/−0
- ghcide/test/exe/PositionMappingTests.hs +222/−0
- ghcide/test/exe/PreprocessorTests.hs +27/−0
- ghcide/test/exe/Progress.hs +60/−0
- ghcide/test/exe/ReferenceTests.hs +199/−0
- ghcide/test/exe/RootUriTests.hs +26/−0
- ghcide/test/exe/SafeTests.hs +38/−0
- ghcide/test/exe/SymlinkTests.hs +27/−0
- ghcide/test/exe/THTests.hs +194/−0
- ghcide/test/exe/TestUtils.hs +318/−0
- ghcide/test/exe/UnitTests.hs +110/−0
- ghcide/test/exe/WatchedFileTests.hs +83/−0
- haskell-language-server.cabal +437/−101
- plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs +1/−1
- plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/Conversion.hs +5/−4
- plugins/hls-cabal-fmt-plugin/src/Ide/Plugin/CabalFmt.hs +23/−10
- plugins/hls-cabal-fmt-plugin/test/Main.hs +3/−3
- plugins/hls-cabal-gild-plugin/src/Ide/Plugin/CabalGild.hs +92/−0
- plugins/hls-cabal-gild-plugin/test/Main.hs +58/−0
- plugins/hls-cabal-gild-plugin/test/testdata/commented_testdata.cabal +12/−0
- plugins/hls-cabal-gild-plugin/test/testdata/commented_testdata.formatted_document.cabal +15/−0
- plugins/hls-cabal-gild-plugin/test/testdata/hie.yaml +3/−0
- plugins/hls-cabal-gild-plugin/test/testdata/lib_testdata.cabal +19/−0
- plugins/hls-cabal-gild-plugin/test/testdata/lib_testdata.formatted_document.cabal +20/−0
- plugins/hls-cabal-gild-plugin/test/testdata/simple_testdata.cabal +36/−0
- plugins/hls-cabal-gild-plugin/test/testdata/simple_testdata.formatted_document.cabal +28/−0
- plugins/hls-cabal-gild-plugin/test/testdata/src/MyLib.hs +4/−0
- plugins/hls-cabal-gild-plugin/test/testdata/src/MyOtherLib.hs +3/−0
- plugins/hls-change-type-signature-plugin/test/testdata/TErrorGivenPartialSignature.hs +1/−1
- plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/ASTPreProcess.hs +1/−1
- plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs +7/−14
- plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs +1/−1
- plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +45/−60
- plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs +1/−1
- plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs +14/−35
- plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs +78/−16
- plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs +27/−26
- plugins/hls-eval-plugin/test/Main.hs +18/−28
- plugins/hls-eval-plugin/test/cabal.project +1/−1
- plugins/hls-eval-plugin/test/testdata/T10.expected.hs +1/−1
- plugins/hls-eval-plugin/test/testdata/T10.ghc92.expected +0/−11
- plugins/hls-eval-plugin/test/testdata/T10.ghc92.expected.hs +0/−11
- plugins/hls-eval-plugin/test/testdata/T11.expected.hs +1/−1
- plugins/hls-eval-plugin/test/testdata/T12.expected.hs +1/−1
- plugins/hls-eval-plugin/test/testdata/T12.ghc92.expected.hs +0/−10
- plugins/hls-eval-plugin/test/testdata/T12.ghc92_expected.hs +0/−10
- plugins/hls-eval-plugin/test/testdata/T13.expected.hs +1/−1
- plugins/hls-eval-plugin/test/testdata/T13.ghc92.expected.hs +0/−4
- plugins/hls-eval-plugin/test/testdata/T13.ghc92_expected.hs +0/−4
- plugins/hls-eval-plugin/test/testdata/T15.ghc92_expected.hs +0/−8
- plugins/hls-eval-plugin/test/testdata/T17.expected.hs +1/−1
- plugins/hls-eval-plugin/test/testdata/T17.ghc92.expected.hs +0/−4
- plugins/hls-eval-plugin/test/testdata/T17.ghc92_expected.hs +0/−4
- plugins/hls-eval-plugin/test/testdata/T20.ghc92.expected.hs +0/−7
- plugins/hls-eval-plugin/test/testdata/T20.ghc92_expected.hs +0/−7
- plugins/hls-eval-plugin/test/testdata/T28.expected.hs +7/−0
- plugins/hls-eval-plugin/test/testdata/T28.hs +6/−0
- plugins/hls-eval-plugin/test/testdata/T4139.expected.hs +7/−0
- plugins/hls-eval-plugin/test/testdata/T4139.hs +6/−0
- plugins/hls-eval-plugin/test/testdata/TFlags.expected.hs +4/−2
- plugins/hls-eval-plugin/test/testdata/TFlags.ghc92.expected.hs +0/−64
- plugins/hls-eval-plugin/test/testdata/TPropertyError.ghc98.expected.hs +3/−3
- plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +1/−1
- plugins/hls-floskell-plugin/src/Ide/Plugin/Floskell.hs +4/−2
- plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +8/−70
- plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs +7/−3
- plugins/hls-notes-plugin/src/Ide/Plugin/Notes.hs +145/−0
- plugins/hls-notes-plugin/test/NotesTest.hs +64/−0
- plugins/hls-notes-plugin/test/testdata/NoteDef.hs +28/−0
- plugins/hls-notes-plugin/test/testdata/Other.hs +6/−0
- plugins/hls-notes-plugin/test/testdata/hie.yaml +5/−0
- plugins/hls-qualify-imported-names-plugin/src/Ide/Plugin/QualifyImportedNames.hs +2/−1
- plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +27/−24
- plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs +6/−8
- plugins/hls-refactor-plugin/test/Main.hs +27/−3
- plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +72/−43
- plugins/hls-rename-plugin/test/Main.hs +78/−6
- plugins/hls-rename-plugin/test/testdata/Comment.expected.hs +1/−0
- plugins/hls-rename-plugin/test/testdata/Comment.hs +1/−0
- plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +29/−20
- plugins/hls-retrie-plugin/test/Main.hs +18/−7
- plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs +5/−6
- plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Types.hs +3/−1
- plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs +1/−1
- plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs +16/−6
- plugins/hls-stylish-haskell-plugin/test/Main.hs +2/−2
- src/HlsPlugins.hs +19/−3
- src/Ide/Main.hs +8/−9
- test/functional/Main.hs +2/−2
- test/functional/Progress.hs +3/−3
- test/testdata/hieBiosMainIs/dist-newstyle/cache/plan.json +1/−0
- test/testdata/missingModuleTest/missingModule/dist-newstyle/cache/plan.json +1/−0
- test/testdata/missingModuleTest/noPrefixMatch/dist-newstyle/cache/plan.json +1/−0
- test/testdata/schema/ghc92/default-config.golden.json +13/−1
- test/testdata/schema/ghc92/vscode-extension-schema.golden.json +12/−0
- test/testdata/schema/ghc94/default-config.golden.json +13/−1
- test/testdata/schema/ghc94/vscode-extension-schema.golden.json +12/−0
- test/testdata/schema/ghc96/default-config.golden.json +13/−1
- test/testdata/schema/ghc96/vscode-extension-schema.golden.json +12/−0
- test/testdata/schema/ghc98/default-config.golden.json +20/−1
- test/testdata/schema/ghc98/vscode-extension-schema.golden.json +30/−0
- test/utils/Test/Hls/Flags.hs +4/−4
- test/wrapper/Main.hs +13/−7
ChangeLog.md view
@@ -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
bench/Main.hs view
@@ -202,8 +202,6 @@ liftIO $ writeFile projectLocal $ unlines ["package haskell-language-server" ," ghc-options: -eventlog -rtsopts"- ,"package ghcide"- ," flags: +ekg" ] return projectLocalExists) (\projectLocalExists -> do
exe/Wrapper.hs view
@@ -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
+ ghcide/test/exe/AsyncTests.hs view
@@ -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" ]+ ]
+ ghcide/test/exe/BootTests.hs view
@@ -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+ ]
+ ghcide/test/exe/CPPTests.hs view
@@ -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
+ ghcide/test/exe/ClientSettingsTests.hs view
@@ -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
+ ghcide/test/exe/CodeLensTests.hs view
@@ -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+ ]
+ ghcide/test/exe/CompletionTests.hs view
@@ -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
+ ghcide/test/exe/Config.hs view
@@ -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"
+ ghcide/test/exe/CradleTests.hs view
@@ -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\""+ ]
+ ghcide/test/exe/DependentFileTest.hs view
@@ -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", [])]
+ ghcide/test/exe/DiagnosticTests.hs view
@@ -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
+ ghcide/test/exe/ExceptionTests.hs view
@@ -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
+ ghcide/test/exe/FindDefinitionAndHoverTests.hs view
@@ -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 <> ":<LINE>:<COL>**[...]", 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
+ ghcide/test/exe/FuzzySearch.hs view
@@ -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
+ ghcide/test/exe/GarbageCollectionTests.hs view
@@ -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
+ ghcide/test/exe/HaddockTests.hs view
@@ -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
+ ghcide/test/exe/HieDbRetry.hs view
@@ -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"+ ]
+ ghcide/test/exe/HighlightTests.hs view
@@ -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"+ ]
+ ghcide/test/exe/IfaceTests.hs view
@@ -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
+ ghcide/test/exe/InitializeResponseTests.hs view
@@ -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+
+ ghcide/test/exe/LogType.hs view
@@ -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
+ ghcide/test/exe/Main.hs view
@@ -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+ ]
+ ghcide/test/exe/NonLspCommandLine.hs view
@@ -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+ ]
+ ghcide/test/exe/OpenCloseTest.hs view
@@ -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
+ ghcide/test/exe/OutlineTests.hs view
@@ -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)
+ ghcide/test/exe/PluginSimpleTests.hs view
@@ -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")]+ )+ ]
+ ghcide/test/exe/PositionMappingTests.hs view
@@ -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
+ ghcide/test/exe/PreprocessorTests.hs view
@@ -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")]+ )+ ]
+ ghcide/test/exe/Progress.hs view
@@ -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{..}
+ ghcide/test/exe/ReferenceTests.hs view
@@ -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'
+ ghcide/test/exe/RootUriTests.hs view
@@ -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)
+ ghcide/test/exe/SafeTests.hs view
@@ -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 ]
+ ghcide/test/exe/SymlinkTests.hs view
@@ -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 ()+ ]
+ ghcide/test/exe/THTests.hs view
@@ -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"
+ ghcide/test/exe/TestUtils.hs view
@@ -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
+ ghcide/test/exe/UnitTests.hs view
@@ -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)
+ ghcide/test/exe/WatchedFileTests.hs view
@@ -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]+ ]
haskell-language-server.cabal view
@@ -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 <https://github.com/haskell/haskell-language-server#readme>@@ -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_<pkg> is CPP macro that cabal defines only when <pkg> 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
plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs view
@@ -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
plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/Conversion.hs view
@@ -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 ""
plugins/hls-cabal-fmt-plugin/src/Ide/Plugin/CabalFmt.hs view
@@ -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
plugins/hls-cabal-fmt-plugin/test/Main.hs view
@@ -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
+ plugins/hls-cabal-gild-plugin/src/Ide/Plugin/CabalGild.hs view
@@ -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
+ plugins/hls-cabal-gild-plugin/test/Main.hs view
@@ -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"
+ plugins/hls-cabal-gild-plugin/test/testdata/commented_testdata.cabal view
@@ -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
+ plugins/hls-cabal-gild-plugin/test/testdata/commented_testdata.formatted_document.cabal view
@@ -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
+ plugins/hls-cabal-gild-plugin/test/testdata/hie.yaml view
@@ -0,0 +1,3 @@+cradle:+ direct:+ arguments: []
+ plugins/hls-cabal-gild-plugin/test/testdata/lib_testdata.cabal view
@@ -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
+ plugins/hls-cabal-gild-plugin/test/testdata/lib_testdata.formatted_document.cabal view
@@ -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
+ plugins/hls-cabal-gild-plugin/test/testdata/simple_testdata.cabal view
@@ -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
+ plugins/hls-cabal-gild-plugin/test/testdata/simple_testdata.formatted_document.cabal view
@@ -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
+ plugins/hls-cabal-gild-plugin/test/testdata/src/MyLib.hs view
@@ -0,0 +1,4 @@+module MyLib (someFunc) where++someFunc :: IO ()+someFunc = putStrLn "someFunc"
+ plugins/hls-cabal-gild-plugin/test/testdata/src/MyOtherLib.hs view
@@ -0,0 +1,3 @@+module MyOtherLib where++bar = 2
plugins/hls-change-type-signature-plugin/test/testdata/TErrorGivenPartialSignature.hs view
@@ -1,4 +1,4 @@-module ErrorGivenPartialSignature where+module TErrorGivenPartialSignature where partial :: Int -> Int partial x = init x
plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/ASTPreProcess.hs view
@@ -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
plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs view
@@ -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 }
plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs view
@@ -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
plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs view
@@ -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)
plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs view
@@ -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
plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs view
@@ -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
plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs view
@@ -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}
plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs view
@@ -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
plugins/hls-eval-plugin/test/Main.hs view
@@ -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"
plugins/hls-eval-plugin/test/cabal.project view
@@ -1,3 +1,3 @@ packages: testdata/- info-util/+ testdata/info-util/
plugins/hls-eval-plugin/test/testdata/T10.expected.hs view
@@ -7,5 +7,5 @@ -- >>> type N = 1 -- >>> type M = 40 -- >>> :kind! N + M + 1--- N + M + 1 :: Nat+-- N + M + 1 :: Natural -- = 42
− plugins/hls-eval-plugin/test/testdata/T10.ghc92.expected
@@ -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
− plugins/hls-eval-plugin/test/testdata/T10.ghc92.expected.hs
@@ -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
plugins/hls-eval-plugin/test/testdata/T11.expected.hs view
@@ -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'
plugins/hls-eval-plugin/test/testdata/T12.expected.hs view
@@ -7,4 +7,4 @@ -- >>> type N = 1 -- >>> type M = 40 -- >>> :kind N + M + 1--- N + M + 1 :: Nat+-- N + M + 1 :: Natural
− plugins/hls-eval-plugin/test/testdata/T12.ghc92.expected.hs
@@ -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
− plugins/hls-eval-plugin/test/testdata/T12.ghc92_expected.hs
@@ -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
plugins/hls-eval-plugin/test/testdata/T13.expected.hs view
@@ -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'
− plugins/hls-eval-plugin/test/testdata/T13.ghc92.expected.hs
@@ -1,4 +0,0 @@-module T13 where---- >>> :kind A--- Not in scope: type constructor or class `A'
− plugins/hls-eval-plugin/test/testdata/T13.ghc92_expected.hs
@@ -1,4 +0,0 @@-module T13 where---- >>> :kind a--- Not in scope: type variable `a'
− plugins/hls-eval-plugin/test/testdata/T15.ghc92_expected.hs
@@ -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
plugins/hls-eval-plugin/test/testdata/T17.expected.hs view
@@ -1,4 +1,4 @@ module T17 where -- >>> :type +no 42--- parse error on input ‘+’+-- parse error on input `+'
− plugins/hls-eval-plugin/test/testdata/T17.ghc92.expected.hs
@@ -1,4 +0,0 @@-module T17 where---- >>> :type +no 42--- parse error on input `+'
− plugins/hls-eval-plugin/test/testdata/T17.ghc92_expected.hs
@@ -1,4 +0,0 @@-module T17 where---- >>> :type +no 42--- parse error on input ‘+’
− plugins/hls-eval-plugin/test/testdata/T20.ghc92.expected.hs
@@ -1,7 +0,0 @@-module T20 where-import Data.Word (Word)--default (Word)---- >>> :type +d 40+ 2 --- 40+ 2 :: Word
− plugins/hls-eval-plugin/test/testdata/T20.ghc92_expected.hs
@@ -1,7 +0,0 @@-module T20 where-import Data.Word (Word)--default (Word)---- >>> :type +d 40+ 2 --- 40+ 2 :: Integer
+ plugins/hls-eval-plugin/test/testdata/T28.expected.hs view
@@ -0,0 +1,7 @@+module T28 where++f True = True+f False = False++-- >>> 1+1+-- 2
+ plugins/hls-eval-plugin/test/testdata/T28.hs view
@@ -0,0 +1,6 @@+module T28 where++f True = True+f False = False++-- >>> 1+1
+ plugins/hls-eval-plugin/test/testdata/T4139.expected.hs view
@@ -0,0 +1,7 @@+module T4139 where++-- >>> 'x'+-- 'x'++main :: IO ()+main = putStrLn "Hello World!"
+ plugins/hls-eval-plugin/test/testdata/T4139.hs view
@@ -0,0 +1,6 @@+module T4139 where++-- >>> 'x'++main :: IO ()+main = putStrLn "Hello World!"
plugins/hls-eval-plugin/test/testdata/TFlags.expected.hs view
@@ -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:
− plugins/hls-eval-plugin/test/testdata/TFlags.ghc92.expected.hs
@@ -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-<interactive>: 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---}
plugins/hls-eval-plugin/test/testdata/TPropertyError.ghc98.expected.hs view
@@ -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 <interactive>:1:27 in interactive:Ghci2 -- []
plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs view
@@ -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} =
plugins/hls-floskell-plugin/src/Ide/Plugin/Floskell.hs view
@@ -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 -- ---------------------------------------------------------------------
plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs view
@@ -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
plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs view
@@ -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
+ plugins/hls-notes-plugin/src/Ide/Plugin/Notes.hs view
@@ -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
+ plugins/hls-notes-plugin/test/NotesTest.hs view
@@ -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"
+ plugins/hls-notes-plugin/test/testdata/NoteDef.hs view
@@ -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+-}
+ plugins/hls-notes-plugin/test/testdata/Other.hs view
@@ -0,0 +1,6 @@+module Other where++import NoteDef++bar :: Int+bar = 4 -- See @Note [Multiple notes in comment]@ in NoteDef
+ plugins/hls-notes-plugin/test/testdata/hie.yaml view
@@ -0,0 +1,5 @@+cradle:+ direct:+ arguments:+ - Other+ - NoteDef
plugins/hls-qualify-imported-names-plugin/src/Ide/Plugin/QualifyImportedNames.hs view
@@ -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
plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs view
@@ -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']
plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs view
@@ -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
plugins/hls-refactor-plugin/test/Main.hs view
@@ -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
plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs view
@@ -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
plugins/hls-rename-plugin/test/Main.hs view
@@ -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)
+ plugins/hls-rename-plugin/test/testdata/Comment.expected.hs view
@@ -0,0 +1,1 @@+{- IShouldNotBeRenaemable -}
+ plugins/hls-rename-plugin/test/testdata/Comment.hs view
@@ -0,0 +1,1 @@+{- IShouldNotBeRenaemable -}
plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs view
@@ -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)
plugins/hls-retrie-plugin/test/Main.hs view
@@ -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
plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs view
@@ -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
plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Types.hs view
@@ -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
plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs view
@@ -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.
plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs view
@@ -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 }
plugins/hls-stylish-haskell-plugin/test/Main.hs view
@@ -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"
src/HlsPlugins.hs view
@@ -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")
src/Ide/Main.hs view
@@ -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
test/functional/Main.hs view
@@ -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 ]
test/functional/Progress.hs view
@@ -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"] [] ]
+ test/testdata/hieBiosMainIs/dist-newstyle/cache/plan.json view
@@ -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":[]}]}
+ test/testdata/missingModuleTest/missingModule/dist-newstyle/cache/plan.json view
@@ -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":[]}]}
+ test/testdata/missingModuleTest/noPrefixMatch/dist-newstyle/cache/plan.json view
@@ -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":[]}]}
test/testdata/schema/ghc92/default-config.golden.json view
@@ -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" }
test/testdata/schema/ghc92/vscode-extension-schema.golden.json view
@@ -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",
test/testdata/schema/ghc94/default-config.golden.json view
@@ -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" }
test/testdata/schema/ghc94/vscode-extension-schema.golden.json view
@@ -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",
test/testdata/schema/ghc96/default-config.golden.json view
@@ -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" }
test/testdata/schema/ghc96/vscode-extension-schema.golden.json view
@@ -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",
test/testdata/schema/ghc98/default-config.golden.json view
@@ -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" }
test/testdata/schema/ghc98/vscode-extension-schema.golden.json view
@@ -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" },
test/utils/Test/Hls/Flags.hs view
@@ -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"
test/wrapper/Main.hs view
@@ -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"] ""