diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,159 @@ # Changelog for haskell-language-server +## 2.10.0.0 + +- Bindists for GHC 9.12.2 + - This is only basic support, many plugins are not yet compatible. +- Bindists for GHC 9.8.4 +- Bindists for GHC 9.6.7 +- `hls-cabal-plugin` features + - Support for `cabal-add` + - Goto Definition for common sections + - Outline of .cabal files +- Fix handling of LSP resolve requests +- Display Inlay Hints + - Records + - Imports + +### Pull Requests + +- Fix cabal check for Hackage release + ([#4528](https://github.com/haskell/haskell-language-server/pull/4528)) by @fendor +- GHC 9.12 support + ([#4527](https://github.com/haskell/haskell-language-server/pull/4527)) by @wz1000 +- Bump cachix/install-nix-action from 30 to 31 + ([#4525](https://github.com/haskell/haskell-language-server/pull/4525)) by @dependabot[bot] +- Bump cachix/cachix-action from 15 to 16 + ([#4523](https://github.com/haskell/haskell-language-server/pull/4523)) by @dependabot[bot] +- Bump haskell-actions/setup from 2.7.9 to 2.7.10 + ([#4522](https://github.com/haskell/haskell-language-server/pull/4522)) by @dependabot[bot] +- Bump haskell-actions/setup from 2.7.9 to 2.7.10 in /.github/actions/setup-build + ([#4521](https://github.com/haskell/haskell-language-server/pull/4521)) by @dependabot[bot] +- Move ghcide-test to stand alone dir + ([#4520](https://github.com/haskell/haskell-language-server/pull/4520)) by @soulomoon +- refactor: remove unnecessary instance and use of unsafeCoerce + ([#4518](https://github.com/haskell/haskell-language-server/pull/4518)) by @MangoIV +- convert `pre-commit-config.yaml` from JSON to YAML + ([#4513](https://github.com/haskell/haskell-language-server/pull/4513)) by @peterbecich +- Enable bench for 9.10 + ([#4512](https://github.com/haskell/haskell-language-server/pull/4512)) by @soulomoon +- Bugfix: Explicit record fields inlay hints for polymorphic records + ([#4510](https://github.com/haskell/haskell-language-server/pull/4510)) by @wczyz +- Capitalization of "Replace" + ([#4509](https://github.com/haskell/haskell-language-server/pull/4509)) by @dschrempf +- document eval plugin not supporting multiline expressions + ([#4495](https://github.com/haskell/haskell-language-server/pull/4495)) by @noughtmare +- Documentation: Imrpove "Contributing" (and amend Sphinx builders) + ([#4494](https://github.com/haskell/haskell-language-server/pull/4494)) by @dschrempf +- Documentation: HLS plugin tutorial improvements + ([#4491](https://github.com/haskell/haskell-language-server/pull/4491)) by @dschrempf +- Nix tooling (minor changes) + ([#4490](https://github.com/haskell/haskell-language-server/pull/4490)) by @dschrempf +- Bump haskell-actions/setup from 2.7.8 to 2.7.9 + ([#4483](https://github.com/haskell/haskell-language-server/pull/4483)) by @dependabot[bot] +- Bump haskell-actions/setup from 2.7.8 to 2.7.9 in /.github/actions/setup-build + ([#4482](https://github.com/haskell/haskell-language-server/pull/4482)) by @dependabot[bot] +- Rework bindist CI + ([#4481](https://github.com/haskell/haskell-language-server/pull/4481)) by @wz1000 +- Remove Unsafe Dynflags deadcode, they don't exist any more! + ([#4480](https://github.com/haskell/haskell-language-server/pull/4480)) by @fendor +- Implement fallback handler for `*/resolve` requests + ([#4478](https://github.com/haskell/haskell-language-server/pull/4478)) by @fendor +- Bump haskell-actions/setup from 2.7.7 to 2.7.8 + ([#4477](https://github.com/haskell/haskell-language-server/pull/4477)) by @dependabot[bot] +- Bump haskell-actions/setup from 2.7.7 to 2.7.8 in /.github/actions/setup-build + ([#4476](https://github.com/haskell/haskell-language-server/pull/4476)) by @dependabot[bot] +- Bump haskell-actions/setup from 2.7.6 to 2.7.7 + ([#4471](https://github.com/haskell/haskell-language-server/pull/4471)) by @dependabot[bot] +- Bump haskell-actions/setup from 2.7.6 to 2.7.7 in /.github/actions/setup-build + ([#4470](https://github.com/haskell/haskell-language-server/pull/4470)) by @dependabot[bot] +- Allow building with GHC 9.8.4 + ([#4459](https://github.com/haskell/haskell-language-server/pull/4459)) by @fendor +- Update python read-the-docs dependencies to latest + ([#4457](https://github.com/haskell/haskell-language-server/pull/4457)) by @fendor +- More tests and better docs for cabal-add + ([#4455](https://github.com/haskell/haskell-language-server/pull/4455)) by @VenInf +- ci(mergify): upgrade configuration to current format + ([#4454](https://github.com/haskell/haskell-language-server/pull/4454)) by @mergify[bot] +- Support record positional construction inlay hints + ([#4447](https://github.com/haskell/haskell-language-server/pull/4447)) by @jetjinser +- Build HLS with GHC 9.8.3 + ([#4444](https://github.com/haskell/haskell-language-server/pull/4444)) by @fendor +- Don't suggest -Wno-deferred-out-of-scope-variables + ([#4441](https://github.com/haskell/haskell-language-server/pull/4441)) by @jeukshi +- Enable hls-stan-plugin for GHC 9.10.1 + ([#4437](https://github.com/haskell/haskell-language-server/pull/4437)) by @fendor +- Enhance formatting of the `cabal-version` error message + ([#4436](https://github.com/haskell/haskell-language-server/pull/4436)) by @fendor +- Support structured diagnostics 2 + ([#4433](https://github.com/haskell/haskell-language-server/pull/4433)) by @noughtmare +- Cabal ignore if for completions (#4289) + ([#4427](https://github.com/haskell/haskell-language-server/pull/4427)) by @SamuelLess +- Fix cabal-add testdata for hls-cabal-plugin-tests + ([#4426](https://github.com/haskell/haskell-language-server/pull/4426)) by @fendor +- gracefully handle errors for unsupported cabal version + ([#4425](https://github.com/haskell/haskell-language-server/pull/4425)) by @fridewald +- Fix pre-commit in CI + ([#4424](https://github.com/haskell/haskell-language-server/pull/4424)) by @fendor +- link executables dynamically to speed up linking + ([#4423](https://github.com/haskell/haskell-language-server/pull/4423)) by @develop7 +- Cabal plugin: implement check for package.yaml in a stack project + ([#4422](https://github.com/haskell/haskell-language-server/pull/4422)) by @JMoss-dev +- Fix exporting operator pattern synonym + ([#4420](https://github.com/haskell/haskell-language-server/pull/4420)) by @pbrinkmeier +- Add docs about running tests for new contributors + ([#4418](https://github.com/haskell/haskell-language-server/pull/4418)) by @pbrinkmeier +- Bump cachix/install-nix-action from 29 to 30 + ([#4413](https://github.com/haskell/haskell-language-server/pull/4413)) by @dependabot[bot] +- Bump cachix/install-nix-action from V27 to 29 + ([#4411](https://github.com/haskell/haskell-language-server/pull/4411)) by @dependabot[bot] +- Avoid expectFail in the test suite + ([#4402](https://github.com/haskell/haskell-language-server/pull/4402)) by @sgillespie +- Fix typos in hls-cabal-fmt-plugin + ([#4399](https://github.com/haskell/haskell-language-server/pull/4399)) by @fendor +- Jump to instance definition and explain typeclass evidence + ([#4392](https://github.com/haskell/haskell-language-server/pull/4392)) by @fendor +- Update cabal-add dependency + ([#4389](https://github.com/haskell/haskell-language-server/pull/4389)) by @VenInf +- Improve error message for `--probe-tools` + ([#4387](https://github.com/haskell/haskell-language-server/pull/4387)) by @sgillespie +- Documentation for build-depends on hover + ([#4385](https://github.com/haskell/haskell-language-server/pull/4385)) by @VenInf +- Bump haskell-actions/setup from 2.7.3 to 2.7.6 + ([#4384](https://github.com/haskell/haskell-language-server/pull/4384)) by @dependabot[bot] +- Bump haskell-actions/setup from 2.7.5 to 2.7.6 in /.github/actions/setup-build + ([#4383](https://github.com/haskell/haskell-language-server/pull/4383)) by @dependabot[bot] +- Clear GHCup caches in CI to not run out of space in CI + ([#4382](https://github.com/haskell/haskell-language-server/pull/4382)) by @fendor +- Cabal go to module's definition + ([#4380](https://github.com/haskell/haskell-language-server/pull/4380)) by @VenInf +- Add Goto Definition for cabal common sections + ([#4375](https://github.com/haskell/haskell-language-server/pull/4375)) by @ChristophHochrainer +- cabal-add integration as a CodeAction + ([#4360](https://github.com/haskell/haskell-language-server/pull/4360)) by @VenInf +- Bump haskell-actions/setup from 2.7.3 to 2.7.5 in /.github/actions/setup-build + ([#4354](https://github.com/haskell/haskell-language-server/pull/4354)) by @dependabot[bot] +- Support Inlay hints for record wildcards + ([#4351](https://github.com/haskell/haskell-language-server/pull/4351)) by @jetjinser +- Remove componentInternalUnits + ([#4350](https://github.com/haskell/haskell-language-server/pull/4350)) by @soulomoon +- Fix core file location in `GetLinkable` + ([#4347](https://github.com/haskell/haskell-language-server/pull/4347)) by @soulomoon +- Release 2.9.0.1 + ([#4346](https://github.com/haskell/haskell-language-server/pull/4346)) by @wz1000 +- Using captureKicksDiagnostics to speed up multiple plugin tests + ([#4339](https://github.com/haskell/haskell-language-server/pull/4339)) by @komikat +- Get files from Shake VFS from within plugin handlers + ([#4328](https://github.com/haskell/haskell-language-server/pull/4328)) by @awjchen +- Cabal plugin outline view + ([#4323](https://github.com/haskell/haskell-language-server/pull/4323)) by @VenInf +- Add missing documentation for cabal formatters + ([#4322](https://github.com/haskell/haskell-language-server/pull/4322)) by @fendor +- Provide explicit import in inlay hints + ([#4235](https://github.com/haskell/haskell-language-server/pull/4235)) by @jetjinser +- Add codeactions for cabal field names + ([#3273](https://github.com/haskell/haskell-language-server/pull/3273)) by @dyniec + ## 2.9.0.1 - Bindists for GHC 9.6.6 diff --git a/exe/Wrapper.hs b/exe/Wrapper.hs --- a/exe/Wrapper.hs +++ b/exe/Wrapper.hs @@ -9,7 +9,6 @@ import Control.Monad.Extra import Data.Default -import Data.Either.Extra (eitherToMaybe) import Data.Foldable import Data.List import Data.List.Extra (trimEnd) @@ -76,8 +75,11 @@ putStrLn $ showProgramVersionOfInterest programsOfInterest putStrLn "Tool versions in your project" cradle <- findProjectCradle' recorder False - ghcVersion <- runExceptT $ getRuntimeGhcVersion' cradle - putStrLn $ showProgramVersion "ghc" $ mkVersion =<< eitherToMaybe ghcVersion + runExceptT (getRuntimeGhcVersion' cradle) >>= \case + Left err -> + T.hPutStrLn stderr (prettyError err NoShorten) + Right ghcVersion -> + putStrLn $ showProgramVersion "ghc" $ mkVersion ghcVersion VersionMode PrintVersion -> putStrLn hlsVer diff --git a/ghcide-bench/src/Experiments.hs b/ghcide-bench/src/Experiments.hs --- a/ghcide-bench/src/Experiments.hs +++ b/ghcide-bench/src/Experiments.hs @@ -266,7 +266,7 @@ flip allM docs $ \DocumentPositions{..} -> do bottom <- pred . length . T.lines <$> documentContents doc diags <- getCurrentDiagnostics doc - case requireDiagnostic diags (DiagnosticSeverity_Error, (fromIntegral bottom, 8), "Found hole", Nothing) of + case requireDiagnostic diags (DiagnosticSeverity_Error, (fromIntegral bottom, 8), "Found hole", Just "GHC-88464", Nothing) of Nothing -> pure True Just _err -> pure False ), @@ -857,11 +857,9 @@ getRebuildsCount :: Session (Either (TResponseError @ClientToServer (Method_CustomMethod "test")) Int) getRebuildsCount = tryCallTestPlugin GetRebuildsCount --- Copy&paste from ghcide/test/Development.IDE.Test getStoredKeys :: Session [Text] getStoredKeys = callTestPlugin GetStoredKeys --- Copy&paste from ghcide/test/Development.IDE.Test tryCallTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either (TResponseError @ClientToServer (Method_CustomMethod "test")) b) tryCallTestPlugin cmd = do let cm = SMethod_CustomMethod (Proxy @"test") @@ -873,7 +871,6 @@ A.Success a -> Right a A.Error e -> error e --- Copy&paste from ghcide/test/Development.IDE.Test callTestPlugin :: (A.FromJSON b) => TestRequest -> Session b callTestPlugin cmd = do res <- tryCallTestPlugin cmd diff --git a/ghcide-test/data/TH/THA.hs b/ghcide-test/data/TH/THA.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/TH/THA.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module THA where +import Language.Haskell.TH + +th_a :: DecsQ +th_a = [d| a = () |] diff --git a/ghcide-test/data/TH/THB.hs b/ghcide-test/data/TH/THB.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/TH/THB.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} +module THB where +import THA + +$th_a diff --git a/ghcide-test/data/TH/THC.hs b/ghcide-test/data/TH/THC.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/TH/THC.hs @@ -0,0 +1,5 @@ +module THC where +import THB + +c ::() +c = a diff --git a/ghcide-test/data/TH/hie.yaml b/ghcide-test/data/TH/hie.yaml new file mode 100644 --- /dev/null +++ b/ghcide-test/data/TH/hie.yaml @@ -0,0 +1,1 @@ +cradle: {direct: {arguments: ["-Wmissing-signatures", "-package template-haskell", "THA", "THB", "THC"]}} diff --git a/ghcide-test/data/THCoreFile/THA.hs b/ghcide-test/data/THCoreFile/THA.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/THCoreFile/THA.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE TemplateHaskell #-} +module THA where +import Language.Haskell.TH +import Control.Monad (when) + +th_a :: DecsQ +th_a = do + when (show (StrictConstructor1 123 True 4567) /= "StrictConstructor1 123 True 4567") $ error "TH validation error" + when (show (StrictConstructor2 123 True 4567) /= "StrictConstructor2 123 True 4567") $ error "TH validation error" + when (show (StrictConstructor3 123 True 4567) /= "StrictConstructor3 123 True 4567") $ error "TH validation error" + when (show (classMethod 'z') /= "True") $ error "TH validation error" + when (show (classMethod 'a') /= "False") $ error "TH validation error" + [d| a = () |] + +data StrictType1 = StrictConstructor1 !Int !Bool Int deriving Show +data StrictType2 = StrictConstructor2 !Int !Bool !Int deriving Show +data StrictType3 = StrictConstructor3 !Int !Bool !Int deriving Show + +class SingleMethodClass a where + classMethod :: a -> Bool + +instance SingleMethodClass Char where + classMethod = (== 'z') diff --git a/ghcide-test/data/THCoreFile/THB.hs b/ghcide-test/data/THCoreFile/THB.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/THCoreFile/THB.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TemplateHaskell #-} +module THB where +import THA +import Control.Monad (when) + +$(do + -- Need to verify in both defining module and usage module" + when (show (StrictConstructor1 123 True 4567) /= "StrictConstructor1 123 True 4567") $ error "TH validation error" + when (show (StrictConstructor2 123 True 4567) /= "StrictConstructor2 123 True 4567") $ error "TH validation error" + when (show (StrictConstructor3 123 True 4567) /= "StrictConstructor3 123 True 4567") $ error "TH validation error" + when (show (classMethod 'z') /= "True") $ error "TH validation error" + when (show (classMethod 'a') /= "False") $ error "TH validation error" + th_a) diff --git a/ghcide-test/data/THCoreFile/THC.hs b/ghcide-test/data/THCoreFile/THC.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/THCoreFile/THC.hs @@ -0,0 +1,5 @@ +module THC where +import THB + +c ::() +c = a diff --git a/ghcide-test/data/THCoreFile/hie.yaml b/ghcide-test/data/THCoreFile/hie.yaml new file mode 100644 --- /dev/null +++ b/ghcide-test/data/THCoreFile/hie.yaml @@ -0,0 +1,1 @@ +cradle: {direct: {arguments: ["-package template-haskell", "THA", "THB", "THC"]}} diff --git a/ghcide-test/data/THLoading/A.hs b/ghcide-test/data/THLoading/A.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/THLoading/A.hs @@ -0,0 +1,5 @@ +module A where +import B (bar) + +foo :: () +foo = bar diff --git a/ghcide-test/data/THLoading/B.hs b/ghcide-test/data/THLoading/B.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/THLoading/B.hs @@ -0,0 +1,4 @@ +module B where + +bar :: () +bar = () diff --git a/ghcide-test/data/THLoading/THA.hs b/ghcide-test/data/THLoading/THA.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/THLoading/THA.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} +module THA where +import Language.Haskell.TH +import A (foo) + +th_a :: DecsQ +th_a = [d| a = foo |] diff --git a/ghcide-test/data/THLoading/THB.hs b/ghcide-test/data/THLoading/THB.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/THLoading/THB.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} +module THB where +import THA + +$th_a diff --git a/ghcide-test/data/THLoading/hie.yaml b/ghcide-test/data/THLoading/hie.yaml new file mode 100644 --- /dev/null +++ b/ghcide-test/data/THLoading/hie.yaml @@ -0,0 +1,1 @@ +cradle: {direct: {arguments: ["-package template-haskell", "THA", "THB", "A", "B"]}} diff --git a/ghcide-test/data/THNewName/A.hs b/ghcide-test/data/THNewName/A.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/THNewName/A.hs @@ -0,0 +1,6 @@ +module A (template) where + +import Language.Haskell.TH + +template :: DecsQ +template = (\consA -> [DataD [] (mkName "A") [] Nothing [NormalC consA []] []]) <$> newName "A" diff --git a/ghcide-test/data/THNewName/B.hs b/ghcide-test/data/THNewName/B.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/THNewName/B.hs @@ -0,0 +1,5 @@ +module B(A(A)) where + +import A + +template diff --git a/ghcide-test/data/THNewName/C.hs b/ghcide-test/data/THNewName/C.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/THNewName/C.hs @@ -0,0 +1,4 @@ +module C where +import B + +a = A diff --git a/ghcide-test/data/THNewName/hie.yaml b/ghcide-test/data/THNewName/hie.yaml new file mode 100644 --- /dev/null +++ b/ghcide-test/data/THNewName/hie.yaml @@ -0,0 +1,1 @@ +cradle: {direct: {arguments: ["-XTemplateHaskell","-Wmissing-signatures","A", "B", "C"]}} diff --git a/ghcide-test/data/THUnboxed/THA.hs b/ghcide-test/data/THUnboxed/THA.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/THUnboxed/THA.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE TemplateHaskell, UnboxedTuples, BangPatterns #-} +module THA where +import Language.Haskell.TH + +data Foo = Foo !Int !Char !String + deriving Show + +newtype Bar = Bar Int + deriving Show + + +f :: Int -> (# Int, Int, Foo, Bar#) +f x = (# x , x+1 , Foo x 'a' "test", Bar 1 #) + +th_a :: DecsQ +th_a = case f 1 of (# a , b, Foo _ _ _, Bar !_ #) -> [d| a = () |] diff --git a/ghcide-test/data/THUnboxed/THB.hs b/ghcide-test/data/THUnboxed/THB.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/THUnboxed/THB.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} +module THB where +import THA + +$th_a diff --git a/ghcide-test/data/THUnboxed/THC.hs b/ghcide-test/data/THUnboxed/THC.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/THUnboxed/THC.hs @@ -0,0 +1,5 @@ +module THC where +import THB + +c ::() +c = a diff --git a/ghcide-test/data/THUnboxed/hie.yaml b/ghcide-test/data/THUnboxed/hie.yaml new file mode 100644 --- /dev/null +++ b/ghcide-test/data/THUnboxed/hie.yaml @@ -0,0 +1,1 @@ +cradle: {direct: {arguments: ["-Wmissing-signatures", "-package template-haskell", "THA", "THB", "THC"]}} diff --git a/ghcide-test/data/boot/A.hs b/ghcide-test/data/boot/A.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/boot/A.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TemplateHaskell #-} +module A where + +import B( TB(..) ) + +newtype TA = MkTA Int + deriving Eq + +f :: TB -> TA +f (MkTB x) = MkTA x diff --git a/ghcide-test/data/boot/A.hs-boot b/ghcide-test/data/boot/A.hs-boot new file mode 100644 --- /dev/null +++ b/ghcide-test/data/boot/A.hs-boot @@ -0,0 +1,3 @@ +module A where +newtype TA = MkTA Int +instance Eq TA diff --git a/ghcide-test/data/boot/B.hs b/ghcide-test/data/boot/B.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/boot/B.hs @@ -0,0 +1,7 @@ +module B(TA(..), TB(..)) where +import {-# SOURCE #-} A( TA(..) ) + +data TB = MkTB !Int + +g :: TA -> TB +g (MkTA x) = MkTB x diff --git a/ghcide-test/data/boot/C.hs b/ghcide-test/data/boot/C.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/boot/C.hs @@ -0,0 +1,8 @@ +module C where + +import B +import A hiding (MkTA(..)) + +x = MkTA +y = MkTB +z = f diff --git a/ghcide-test/data/boot/hie.yaml b/ghcide-test/data/boot/hie.yaml new file mode 100644 --- /dev/null +++ b/ghcide-test/data/boot/hie.yaml @@ -0,0 +1,1 @@ +cradle: {direct: {arguments: ["A.hs", "A.hs-boot", "B.hs", "C.hs"]}} diff --git a/ghcide-test/data/boot2/A.hs b/ghcide-test/data/boot2/A.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/boot2/A.hs @@ -0,0 +1,12 @@ +module A where + +-- E source imports B +-- In interface file see source module dependencies: B {-# SOURCE #-} +import E +-- C imports B +-- In interface file see source module dependencies: B +import C + +-- Instance for B only available from B.hi not B.hi-boot, so tests we load +-- that. +main = print B diff --git a/ghcide-test/data/boot2/B.hs b/ghcide-test/data/boot2/B.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/boot2/B.hs @@ -0,0 +1,8 @@ +module B where + +import D + +data B = B + +instance Show B where + show B = "B" diff --git a/ghcide-test/data/boot2/B.hs-boot b/ghcide-test/data/boot2/B.hs-boot new file mode 100644 --- /dev/null +++ b/ghcide-test/data/boot2/B.hs-boot @@ -0,0 +1,3 @@ +module B where + +data B = B diff --git a/ghcide-test/data/boot2/C.hs b/ghcide-test/data/boot2/C.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/boot2/C.hs @@ -0,0 +1,3 @@ +module C where + +import B diff --git a/ghcide-test/data/boot2/D.hs b/ghcide-test/data/boot2/D.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/boot2/D.hs @@ -0,0 +1,3 @@ +module D where + +import {-# SOURCE #-} B diff --git a/ghcide-test/data/boot2/E.hs b/ghcide-test/data/boot2/E.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/boot2/E.hs @@ -0,0 +1,3 @@ +module E(B(B)) where + +import {-# SOURCE #-} B diff --git a/ghcide-test/data/boot2/hie.yaml b/ghcide-test/data/boot2/hie.yaml new file mode 100644 --- /dev/null +++ b/ghcide-test/data/boot2/hie.yaml @@ -0,0 +1,1 @@ +cradle: {direct: {arguments: ["A.hs", "B.hs-boot", "B.hs", "C.hs", "D.hs", "E.hs"]}} diff --git a/ghcide-test/data/cabal-exe/a/a.cabal b/ghcide-test/data/cabal-exe/a/a.cabal new file mode 100644 --- /dev/null +++ b/ghcide-test/data/cabal-exe/a/a.cabal @@ -0,0 +1,14 @@ +cabal-version: 2.2 + +name: a +version: 0.1.0.0 +author: Fendor +maintainer: power.walross@gmail.com +build-type: Simple + +executable a + main-is: Main.hs + hs-source-dirs: src + ghc-options: -Wall + build-depends: base + default-language: Haskell2010 diff --git a/ghcide-test/data/cabal-exe/a/src/Main.hs b/ghcide-test/data/cabal-exe/a/src/Main.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/cabal-exe/a/src/Main.hs @@ -0,0 +1,3 @@ +module Main where + +main = putStrLn "Hello, Haskell!" diff --git a/ghcide-test/data/cabal-exe/cabal.project b/ghcide-test/data/cabal-exe/cabal.project new file mode 100644 --- /dev/null +++ b/ghcide-test/data/cabal-exe/cabal.project @@ -0,0 +1,1 @@ +packages: ./a diff --git a/ghcide-test/data/cabal-exe/hie.yaml b/ghcide-test/data/cabal-exe/hie.yaml new file mode 100644 --- /dev/null +++ b/ghcide-test/data/cabal-exe/hie.yaml @@ -0,0 +1,3 @@ +cradle: + cabal: + component: "exe:a" diff --git a/ghcide-test/data/hover/Bar.hs b/ghcide-test/data/hover/Bar.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/hover/Bar.hs @@ -0,0 +1,4 @@ +module Bar (Bar(..)) where + +-- | Bar Haddock +data Bar = Bar diff --git a/ghcide-test/data/hover/Foo.hs b/ghcide-test/data/hover/Foo.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/hover/Foo.hs @@ -0,0 +1,6 @@ +module Foo (Bar, foo) where + +import Bar + +-- | foo Haddock +foo = Bar diff --git a/ghcide-test/data/hover/GotoHover.hs b/ghcide-test/data/hover/GotoHover.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/hover/GotoHover.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE OverloadedStrings, TemplateHaskell #-} +{- HLINT ignore -} +module GotoHover ( module GotoHover) where +import Data.Text (Text, pack) +import Foo (Bar, foo) + + +data TypeConstructor = DataConstructor + { fff :: Text + , ggg :: Int } +aaa :: TypeConstructor +aaa = DataConstructor + { fff = "dfgy" + , ggg = 832 + } +bbb :: TypeConstructor +bbb = DataConstructor "mjgp" 2994 +ccc :: (Text, Int) +ccc = (fff bbb, ggg aaa) +ddd :: Num a => a -> a -> a +ddd vv ww = vv +! ww +a +! b = a - b +hhh (Just a) (><) = a >< a +iii a b = a `b` a +jjj s = pack $ s <> s +class MyClass a where + method :: a -> Int +instance MyClass Int where + method = succ +kkk :: MyClass a => Int -> a -> Int +kkk n c = n + method c + +doBind :: Maybe () +doBind = do unwrapped <- Just () + return unwrapped + +listCompBind :: [Char] +listCompBind = [ succ c | c <- "ptfx" ] + +multipleClause :: Bool -> Char +multipleClause True = 't' +multipleClause False = 'f' + +-- | Recognizable docs: kpqz +documented :: Monad m => Either Int (m a) +documented = Left 7518 + +listOfInt = [ 8391 :: Int, 6268 ] + +outer :: Bool +outer = undefined inner where + + inner :: Char + inner = undefined + +imported :: Bar +imported = foo + +aa2 :: Bool +aa2 = $(id [| True |]) + +hole :: Int +hole = _ + +hole2 :: a -> Maybe a +hole2 = _ + +-- A comment above a type defnition with a deriving clause +data Example = Example + deriving (Eq) diff --git a/ghcide-test/data/hover/GotoImplementation.hs b/ghcide-test/data/hover/GotoImplementation.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/hover/GotoImplementation.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE GADTs, GeneralisedNewtypeDeriving, DerivingStrategies #-} +{-# OPTIONS_GHC -Wno-missing-methods #-} +module GotoImplementation where + +data AAA = AAA +instance Num AAA where +aaa :: Num x => x +aaa = 1 +aaa1 :: AAA = aaa + +class BBB a where + bbb :: a -> a +instance BBB AAA where + bbb = const AAA +bbbb :: AAA +bbbb = bbb AAA + +ccc :: Show a => a -> String +ccc d = show d + +newtype Q k = Q k + deriving newtype (Eq, Show) +ddd :: (Show k, Eq k) => k -> String +ddd k = if Q k == Q k then show k else "" +ddd1 = ddd (Q 0) + +data GadtTest a where + GadtTest :: Int -> GadtTest Int +printUsingEvidence :: Show a => GadtTest a -> String +printUsingEvidence (GadtTest i) = show i diff --git a/ghcide-test/data/hover/RecordDotSyntax.hs b/ghcide-test/data/hover/RecordDotSyntax.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/hover/RecordDotSyntax.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE OverloadedRecordDot, DuplicateRecordFields, NoFieldSelectors #-} + +module RecordDotSyntax ( module RecordDotSyntax) where + +import qualified Data.Maybe as M + +data MyRecord = MyRecord + { a :: String + , b :: Integer + , c :: MyChild + } deriving (Eq, Show) + +newtype MyChild = MyChild + { z :: String + } deriving (Eq, Show) + +x = MyRecord { a = "Hello", b = 12, c = MyChild { z = "there" } } +y = x.a ++ show x.b ++ x.c.z diff --git a/ghcide-test/data/hover/hie.yaml b/ghcide-test/data/hover/hie.yaml new file mode 100644 --- /dev/null +++ b/ghcide-test/data/hover/hie.yaml @@ -0,0 +1,1 @@ +cradle: {direct: {arguments: ["Foo", "Bar", "GotoHover", "RecordDotSyntax", "GotoImplementation"]}} diff --git a/ghcide-test/data/ignore-fatal/IgnoreFatal.hs b/ghcide-test/data/ignore-fatal/IgnoreFatal.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/ignore-fatal/IgnoreFatal.hs @@ -0,0 +1,8 @@ +-- "missing signature" is declared a fatal warning in the cabal file, +-- but is ignored in this module. + +{-# OPTIONS_GHC -Wno-missing-signatures #-} + +module IgnoreFatal where + +a = 'a' diff --git a/ghcide-test/data/ignore-fatal/cabal.project b/ghcide-test/data/ignore-fatal/cabal.project new file mode 100644 --- /dev/null +++ b/ghcide-test/data/ignore-fatal/cabal.project @@ -0,0 +1,1 @@ +packages: ignore-fatal.cabal diff --git a/ghcide-test/data/ignore-fatal/hie.yaml b/ghcide-test/data/ignore-fatal/hie.yaml new file mode 100644 --- /dev/null +++ b/ghcide-test/data/ignore-fatal/hie.yaml @@ -0,0 +1,4 @@ +cradle: + cabal: + - path: "." + component: "lib:ignore-fatal" diff --git a/ghcide-test/data/ignore-fatal/ignore-fatal.cabal b/ghcide-test/data/ignore-fatal/ignore-fatal.cabal new file mode 100644 --- /dev/null +++ b/ghcide-test/data/ignore-fatal/ignore-fatal.cabal @@ -0,0 +1,10 @@ +name: ignore-fatal +version: 1.0.0 +build-type: Simple +cabal-version: >= 1.2 + +library + build-depends: base + exposed-modules: IgnoreFatal + hs-source-dirs: . + ghc-options: -Werror=missing-signatures diff --git a/ghcide-test/data/multi-unit-reexport/a/A.hs b/ghcide-test/data/multi-unit-reexport/a/A.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/multi-unit-reexport/a/A.hs @@ -0,0 +1,3 @@ +module A(foo) where +import Data.Text +foo = () diff --git a/ghcide-test/data/multi-unit-reexport/b/B.hs b/ghcide-test/data/multi-unit-reexport/b/B.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/multi-unit-reexport/b/B.hs @@ -0,0 +1,3 @@ +module B(module B) where +import A +qux = foo diff --git a/ghcide-test/data/multi-unit-reexport/c/C.hs b/ghcide-test/data/multi-unit-reexport/c/C.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/multi-unit-reexport/c/C.hs @@ -0,0 +1,4 @@ +module C(module C) where +import A +import B +cux = foo `seq` qux diff --git a/ghcide-test/data/multi-unit-reexport/cabal.project b/ghcide-test/data/multi-unit-reexport/cabal.project new file mode 100644 --- /dev/null +++ b/ghcide-test/data/multi-unit-reexport/cabal.project @@ -0,0 +1,2 @@ +packages: a b c +multi-repl: True diff --git a/ghcide-test/data/multi-unit-reexport/hie.yaml b/ghcide-test/data/multi-unit-reexport/hie.yaml new file mode 100644 --- /dev/null +++ b/ghcide-test/data/multi-unit-reexport/hie.yaml @@ -0,0 +1,6 @@ +cradle: + direct: + arguments: ["-unit" ,"@a-1.0.0-inplace" + ,"-unit" ,"@b-1.0.0-inplace" + ,"-unit" ,"@c-1.0.0-inplace" + ] diff --git a/ghcide-test/data/multi-unit/a/A.hs b/ghcide-test/data/multi-unit/a/A.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/multi-unit/a/A.hs @@ -0,0 +1,3 @@ +module A(foo) where +import Data.Text +foo = () diff --git a/ghcide-test/data/multi-unit/b/B.hs b/ghcide-test/data/multi-unit/b/B.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/multi-unit/b/B.hs @@ -0,0 +1,3 @@ +module B(module B) where +import "a" A +qux = foo diff --git a/ghcide-test/data/multi-unit/c/C.hs b/ghcide-test/data/multi-unit/c/C.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/multi-unit/c/C.hs @@ -0,0 +1,3 @@ +module C(module C) where +import A +cux = foo diff --git a/ghcide-test/data/multi-unit/cabal.project b/ghcide-test/data/multi-unit/cabal.project new file mode 100644 --- /dev/null +++ b/ghcide-test/data/multi-unit/cabal.project @@ -0,0 +1,2 @@ +packages: a b c +multi-repl: True diff --git a/ghcide-test/data/multi-unit/hie.yaml b/ghcide-test/data/multi-unit/hie.yaml new file mode 100644 --- /dev/null +++ b/ghcide-test/data/multi-unit/hie.yaml @@ -0,0 +1,6 @@ +cradle: + direct: + arguments: ["-unit" ,"@a-1.0.0-inplace" + ,"-unit" ,"@b-1.0.0-inplace" + ,"-unit" ,"@c-1.0.0-inplace" + ] diff --git a/ghcide-test/data/multi/a/A.hs b/ghcide-test/data/multi/a/A.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/multi/a/A.hs @@ -0,0 +1,3 @@ +module A(foo) where +import Control.Concurrent.Async +foo = () diff --git a/ghcide-test/data/multi/a/a.cabal b/ghcide-test/data/multi/a/a.cabal new file mode 100644 --- /dev/null +++ b/ghcide-test/data/multi/a/a.cabal @@ -0,0 +1,9 @@ +name: a +version: 1.0.0 +build-type: Simple +cabal-version: >= 1.2 + +library + build-depends: base, async >= 2.0 + exposed-modules: A + hs-source-dirs: . diff --git a/ghcide-test/data/multi/b/B.hs b/ghcide-test/data/multi/b/B.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/multi/b/B.hs @@ -0,0 +1,3 @@ +module B(module B) where +import A +qux = foo diff --git a/ghcide-test/data/multi/b/b.cabal b/ghcide-test/data/multi/b/b.cabal new file mode 100644 --- /dev/null +++ b/ghcide-test/data/multi/b/b.cabal @@ -0,0 +1,9 @@ +name: b +version: 1.0.0 +build-type: Simple +cabal-version: >= 1.2 + +library + build-depends: base, a + exposed-modules: B + hs-source-dirs: . diff --git a/ghcide-test/data/multi/c/C.hs b/ghcide-test/data/multi/c/C.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/multi/c/C.hs @@ -0,0 +1,3 @@ +module C(module C) where +import A +cux = foo diff --git a/ghcide-test/data/multi/c/c.cabal b/ghcide-test/data/multi/c/c.cabal new file mode 100644 --- /dev/null +++ b/ghcide-test/data/multi/c/c.cabal @@ -0,0 +1,9 @@ +name: c +version: 1.0.0 +build-type: Simple +cabal-version: >= 1.2 + +library + build-depends: base, a + exposed-modules: C + hs-source-dirs: . diff --git a/ghcide-test/data/multi/cabal.project b/ghcide-test/data/multi/cabal.project new file mode 100644 --- /dev/null +++ b/ghcide-test/data/multi/cabal.project @@ -0,0 +1,3 @@ +packages: a b c + +allow-newer: base diff --git a/ghcide-test/data/multi/hie.yaml b/ghcide-test/data/multi/hie.yaml new file mode 100644 --- /dev/null +++ b/ghcide-test/data/multi/hie.yaml @@ -0,0 +1,8 @@ +cradle: + cabal: + - path: "./a" + component: "lib:a" + - path: "./b" + component: "lib:b" + - path: "./c" + component: "lib:c" diff --git a/ghcide-test/data/plugin-knownnat/KnownNat.hs b/ghcide-test/data/plugin-knownnat/KnownNat.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/plugin-knownnat/KnownNat.hs @@ -0,0 +1,10 @@ +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} +{-# LANGUAGE DataKinds, ScopedTypeVariables, TypeOperators #-} +module KnownNat where +import Data.Proxy +import GHC.TypeLits + +f :: forall n. KnownNat n => Proxy n -> Integer +f _ = natVal (Proxy :: Proxy n) + natVal (Proxy :: Proxy (n+2)) +foo :: Int -> Int -> Int +foo a _b = a + c diff --git a/ghcide-test/data/plugin-knownnat/cabal.project b/ghcide-test/data/plugin-knownnat/cabal.project new file mode 100644 --- /dev/null +++ b/ghcide-test/data/plugin-knownnat/cabal.project @@ -0,0 +1,4 @@ +packages: . + +-- Needed for ghc >= 9.0.2 and ghc-typelits-natnormalise == 0.7.6 +allow-newer: ghc-typelits-natnormalise:ghc-bignum diff --git a/ghcide-test/data/plugin-knownnat/plugin.cabal b/ghcide-test/data/plugin-knownnat/plugin.cabal new file mode 100644 --- /dev/null +++ b/ghcide-test/data/plugin-knownnat/plugin.cabal @@ -0,0 +1,9 @@ +cabal-version: 1.18 +name: plugin +version: 1.0.0 +build-type: Simple + +library + build-depends: base, ghc-typelits-knownnat + exposed-modules: KnownNat + hs-source-dirs: . diff --git a/ghcide-test/data/recomp/A.hs b/ghcide-test/data/recomp/A.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/recomp/A.hs @@ -0,0 +1,6 @@ +module A(x) where + +import B + +x :: Int +x = y diff --git a/ghcide-test/data/recomp/B.hs b/ghcide-test/data/recomp/B.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/recomp/B.hs @@ -0,0 +1,4 @@ +module B(y) where + +y :: Int +y = undefined diff --git a/ghcide-test/data/recomp/P.hs b/ghcide-test/data/recomp/P.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/recomp/P.hs @@ -0,0 +1,5 @@ +module P() where +import A +import B + +bar = x :: Int diff --git a/ghcide-test/data/recomp/hie.yaml b/ghcide-test/data/recomp/hie.yaml new file mode 100644 --- /dev/null +++ b/ghcide-test/data/recomp/hie.yaml @@ -0,0 +1,1 @@ +cradle: {direct: {arguments: ["-Wmissing-signatures","B", "A", "P"]}} diff --git a/ghcide-test/data/references/Main.hs b/ghcide-test/data/references/Main.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/references/Main.hs @@ -0,0 +1,14 @@ +module Main where + +import References + +main :: IO () +main = return () + + + +a = 2 :: Int +b = a + 1 + +acc :: Account +acc = Savings diff --git a/ghcide-test/data/references/OtherModule.hs b/ghcide-test/data/references/OtherModule.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/references/OtherModule.hs @@ -0,0 +1,9 @@ +module OtherModule (symbolDefinedInOtherModule, symbolDefinedInOtherOtherModule) where + +import OtherOtherModule + +symbolDefinedInOtherModule = 1 + +symbolLocalToOtherModule = 2 + +someFxn x = x + symbolLocalToOtherModule diff --git a/ghcide-test/data/references/OtherOtherModule.hs b/ghcide-test/data/references/OtherOtherModule.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/references/OtherOtherModule.hs @@ -0,0 +1,3 @@ +module OtherOtherModule where + +symbolDefinedInOtherOtherModule = "asdf" diff --git a/ghcide-test/data/references/References.hs b/ghcide-test/data/references/References.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/references/References.hs @@ -0,0 +1,25 @@ +module References where + +import OtherModule + +foo = bar + +bar = let x = bar 42 in const "hello" + +baz = do + x <- bar 23 + return $ bar 14 + +data Account = + Checking + | Savings + +bobsAccount = Checking + +bobHasChecking = case bobsAccount of + Checking -> True + Savings -> False + +x = symbolDefinedInOtherModule + +y = symbolDefinedInOtherOtherModule diff --git a/ghcide-test/data/references/hie.yaml b/ghcide-test/data/references/hie.yaml new file mode 100644 --- /dev/null +++ b/ghcide-test/data/references/hie.yaml @@ -0,0 +1,1 @@ +cradle: {direct: {arguments: ["Main","OtherModule","OtherOtherModule","References"]}} diff --git a/ghcide-test/data/rootUri/dirA/Foo.hs b/ghcide-test/data/rootUri/dirA/Foo.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/rootUri/dirA/Foo.hs @@ -0,0 +1,3 @@ +module Foo () where + +foo = () diff --git a/ghcide-test/data/rootUri/dirA/foo.cabal b/ghcide-test/data/rootUri/dirA/foo.cabal new file mode 100644 --- /dev/null +++ b/ghcide-test/data/rootUri/dirA/foo.cabal @@ -0,0 +1,9 @@ +name: foo +version: 1.0.0 +build-type: Simple +cabal-version: >= 1.2 + +library + build-depends: base + exposed-modules: Foo + hs-source-dirs: . diff --git a/ghcide-test/data/rootUri/dirB/Foo.hs b/ghcide-test/data/rootUri/dirB/Foo.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/rootUri/dirB/Foo.hs @@ -0,0 +1,3 @@ +module Foo () where + +foo = () diff --git a/ghcide-test/data/rootUri/dirB/foo.cabal b/ghcide-test/data/rootUri/dirB/foo.cabal new file mode 100644 --- /dev/null +++ b/ghcide-test/data/rootUri/dirB/foo.cabal @@ -0,0 +1,9 @@ +name: foo +version: 1.0.0 +build-type: Simple +cabal-version: >= 1.2 + +library + build-depends: base + exposed-modules: Foo + hs-source-dirs: . diff --git a/ghcide-test/data/symlink/hie.yaml b/ghcide-test/data/symlink/hie.yaml new file mode 100644 --- /dev/null +++ b/ghcide-test/data/symlink/hie.yaml @@ -0,0 +1,10 @@ + +cradle: + direct: + arguments: + - -i + - -isrc + - -iother_loc/ + - other_loc/Sym.hs + - src/Foo.hs + - -Wall diff --git a/ghcide-test/data/symlink/some_loc/Sym.hs b/ghcide-test/data/symlink/some_loc/Sym.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/symlink/some_loc/Sym.hs @@ -0,0 +1,4 @@ +module Sym where + +foo :: String +foo = "" diff --git a/ghcide-test/data/symlink/src/Foo.hs b/ghcide-test/data/symlink/src/Foo.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/symlink/src/Foo.hs @@ -0,0 +1,4 @@ +module Foo where + +import Sym + diff --git a/ghcide-test/data/working-dir/a/A.hs b/ghcide-test/data/working-dir/a/A.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/working-dir/a/A.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell #-} +module A(th_a) where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import Control.Monad.IO.Class + +th_a :: DecsQ +th_a = do + str <- makeRelativeToProject "wdtest" >>= liftIO . readFile + [d| a = $(lift str) |] diff --git a/ghcide-test/data/working-dir/a/B.hs b/ghcide-test/data/working-dir/a/B.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/data/working-dir/a/B.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module B() where + +import A + +$th_a diff --git a/ghcide-test/data/working-dir/a/a.cabal b/ghcide-test/data/working-dir/a/a.cabal new file mode 100644 --- /dev/null +++ b/ghcide-test/data/working-dir/a/a.cabal @@ -0,0 +1,11 @@ +name: a +version: 1.0.0 +build-type: Simple +cabal-version: >= 1.2 +extra-source-files: wdtest + +library + build-depends: base, template-haskell + exposed-modules: A B + ghc-options: -Wmissing-signatures + hs-source-dirs: . diff --git a/ghcide-test/data/working-dir/cabal.project b/ghcide-test/data/working-dir/cabal.project new file mode 100644 --- /dev/null +++ b/ghcide-test/data/working-dir/cabal.project @@ -0,0 +1,1 @@ +packages: a diff --git a/ghcide-test/data/working-dir/hie.yaml b/ghcide-test/data/working-dir/hie.yaml new file mode 100644 --- /dev/null +++ b/ghcide-test/data/working-dir/hie.yaml @@ -0,0 +1,2 @@ +cradle: + cabal: diff --git a/ghcide-test/exe/AsyncTests.hs b/ghcide-test/exe/AsyncTests.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/exe/AsyncTests.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE DataKinds #-} + +module AsyncTests (tests) where + +import Control.Monad +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (toJSON) +import Data.Proxy +import qualified Data.Text as T +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +-- import Test.QuickCheck.Instances () +import Config +import Development.IDE.Plugin.Test (TestRequest (BlockSeconds), + blockCommandId) +import Test.Tasty +import Test.Tasty.HUnit + +-- | Test if ghcide asynchronously handles Commands and user Requests +tests :: TestTree +tests = testGroup "async" + [ + testWithDummyPluginEmpty "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" ] + , testWithDummyPluginEmpty "request" $ do + -- Execute a custom request that will block for 1000 seconds + void $ sendRequest (SMethod_CustomMethod (Proxy @"test")) $ toJSON $ BlockSeconds 1000 + -- Load a file and check for code actions. Will only work if the request is run asynchronously + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# OPTIONS -Wmissing-signatures #-}" + , "foo = id" + ] + void waitForDiagnostics + codeLenses <- getAndResolveCodeLenses doc + liftIO $ [ _title | CodeLens{_command = Just Command{_title}} <- codeLenses] @=? + [ "foo :: a -> a" ] + ] diff --git a/ghcide-test/exe/BootTests.hs b/ghcide-test/exe/BootTests.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/exe/BootTests.hs @@ -0,0 +1,56 @@ +module BootTests (tests) where + +import Config (checkDefs, mkR, runInDir, + runWithExtraFiles) +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 + + +tests :: TestTree +tests = testGroup "boot" + [ testCase "boot-def-test" $ runWithExtraFiles "boot" $ \dir -> do + let cPath = dir "C.hs" + cSource <- liftIO $ readFileUtf8 cPath + -- Dirty the cache + liftIO $ runInDir dir $ do + cDoc <- createDoc cPath "haskell" cSource + -- We send a hover request then wait for either the hover response or + -- `ghcide/reference/ready` notification. + -- Once we receive one of the above, we wait for the other that we + -- haven't received yet. + -- If we don't wait for the `ready` notification it is possible + -- that the `getDefinitions` request/response in the outer ghcide + -- session will find no definitions. + let hoverParams = HoverParams cDoc (Position 4 3) Nothing + hoverRequestId <- sendRequest SMethod_TextDocumentHover hoverParams + let parseReadyMessage = isReferenceReady cPath + let parseHoverResponse = responseForId SMethod_TextDocumentHover hoverRequestId + hoverResponseOrReadyMessage <- skipManyTill anyMessage ((Left <$> parseHoverResponse) <|> (Right <$> parseReadyMessage)) + _ <- skipManyTill anyMessage $ + case hoverResponseOrReadyMessage of + Left _ -> void parseReadyMessage + Right _ -> void parseHoverResponse + closeDoc cDoc + cdoc <- createDoc cPath "haskell" cSource + locs <- getDefinitions cdoc (Position 7 4) + let floc = mkR 9 0 9 1 + checkDefs locs (pure [floc]) + , testCase "graph with boot modules" $ runWithExtraFiles "boot2" $ \dir -> do + _ <- openDoc (dir "A.hs") "haskell" + expectNoMoreDiagnostics 2 + ] diff --git a/ghcide-test/exe/CPPTests.hs b/ghcide-test/exe/CPPTests.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/exe/CPPTests.hs @@ -0,0 +1,56 @@ +module CPPTests (tests) where + +import Control.Exception (catch) +import qualified Data.Text as T +import Development.IDE.Test (Cursor, expectDiagnostics, + expectNoMoreDiagnostics) +import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), mkRange) +import Language.LSP.Test +-- import Test.QuickCheck.Instances () +import Config +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = + testGroup "cpp" + [ 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) + ) + , testWithDummyPluginEmpty "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", Just "GHC-88464")])] + ] + where + expectError :: T.Text -> Cursor -> Session () + expectError content cursor = do + _ <- createDoc "Testing.hs" "haskell" content + expectDiagnostics + [ ( "Testing.hs", + [(DiagnosticSeverity_Error, cursor, "error: unterminated", Nothing)] + ) + ] + expectNoMoreDiagnostics 0.5 diff --git a/ghcide-test/exe/ClientSettingsTests.hs b/ghcide-test/exe/ClientSettingsTests.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/exe/ClientSettingsTests.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE GADTs #-} +module ClientSettingsTests (tests) where + +import Config (testWithDummyPluginEmpty) +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.Hls (waitForProgressDone) +import Test.Tasty + +tests :: TestTree +tests = testGroup "client settings handling" + [ testWithDummyPluginEmpty "ghcide restarts shake session on config changes" $ do + setIgnoringLogNotifications False + void $ createDoc "A.hs" "haskell" "module A where" + waitForProgressDone + setConfigSection "haskell" $ toJSON (def :: Config) + skipManyTill anyMessage restartingBuildSession + + ] + where + restartingBuildSession :: Session () + restartingBuildSession = do + FromServerMess SMethod_WindowLogMessage TNotificationMessage{_params = LogMessageParams{..}} <- loggingNotification + guard $ "Restarting build session" `T.isInfixOf` _message diff --git a/ghcide-test/exe/CodeLensTests.hs b/ghcide-test/exe/CodeLensTests.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/exe/CodeLensTests.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE GADTs #-} + +module CodeLensTests (tests) where + +import Config +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.Hls (mkRange, waitForProgressDone) +import Test.Tasty +import Test.Tasty.HUnit + +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 = testWithDummyPluginEmpty 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" + , if ghcVersion < GHC910 + then "notInScopeTest :: String -> Data.Data.DataType" + else "notInScopeTest :: String -> GHC.Internal.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) [] + ] + , testWithDummyPluginEmpty "keep stale lens" $ do + let content = T.unlines + [ "module Stale where" + , "f = _" + ] + doc <- createDoc "Stale.hs" "haskell" content + oldLens <- getCodeLenses doc + liftIO $ length oldLens @?= 1 + let edit = TextEdit (mkRange 0 4 0 5) "" -- Remove the `_` + _ <- applyEdit doc edit + newLens <- getCodeLenses doc + liftIO $ newLens @?= oldLens + ] diff --git a/ghcide-test/exe/CompletionTests.hs b/ghcide-test/exe/CompletionTests.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/exe/CompletionTests.hs @@ -0,0 +1,578 @@ + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module CompletionTests (tests) where + +import Config +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 qualified Data.Text as T +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 Test.Hls (waitForTypecheck) +import qualified Test.Hls.FileSystem as FS +import Test.Hls.FileSystem (file, text) +import Test.Hls.Util +import Test.Tasty +import Test.Tasty.HUnit + + +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 + ] + +testSessionEmpty :: TestName -> Session () -> TestTree +testSessionEmpty name = testWithDummyPlugin name (mkIdeTestFs [FS.directCradle ["A.hs"]]) + +testSessionEmptyWithCradle :: TestName -> T.Text -> Session () -> TestTree +testSessionEmptyWithCradle name cradle = testWithDummyPlugin name (mkIdeTestFs [file "hie.yaml" (text cradle)]) + +testSessionSingleFile :: TestName -> FilePath -> T.Text -> Session () -> TestTree +testSessionSingleFile testName fp txt session = + testWithDummyPlugin testName (mkIdeTestFs [FS.directCradle [T.pack fp] , file fp (text txt)]) session + +completionTest :: HasCallStack => String -> [T.Text] -> Position -> [(T.Text, CompletionItemKind, T.Text, Bool, Bool, Maybe [TextEdit])] -> TestTree +completionTest name src pos expected = testSessionSingleFile name "A.hs" (T.unlines src) $ do + docId <- openDoc "A.hs" "haskell" + _ <- waitForDiagnostics + compls <- getAndResolveCompletions docId pos + let compls' = [ (_label, _kind, _insertText, _additionalTextEdits) | CompletionItem{..} <- compls] + let emptyToMaybe x = if T.null x then Nothing else Just x + liftIO $ sortOn (Lens.view Lens._1) (take (length expected) compls') @?= + sortOn (Lens.view Lens._1) + [ (l, Just k, emptyToMaybe t, at) | (l,k,t,_,_,at) <- expected] + forM_ (zip compls expected) $ \(CompletionItem{..}, (_,_,_,expectedSig, expectedDocs, _)) -> do + when expectedSig $ + liftIO $ assertBool ("Missing type signature: " <> T.unpack _label) (isJust _detail) + when expectedDocs $ + liftIO $ assertBool ("Missing docs: " <> T.unpack _label) (isJust _documentation) + + +topLevelCompletionTests :: [TestTree] +topLevelCompletionTests = [ + completionTest + "variable" + ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"] + (Position 0 8) + [("xxx", CompletionItemKind_Function, "xxx", True, True, Nothing) + ], + completionTest + "constructor" + ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"] + (Position 0 8) + [("xxx", CompletionItemKind_Function, "xxx", True, True, Nothing) + ], + completionTest + "class method" + ["bar = xx", "class Xxx a where", "-- | haddock", "xxx :: ()", "xxx = ()"] + (Position 0 8) + [("xxx", CompletionItemKind_Function, "xxx", True, True, Nothing)], + completionTest + "type" + ["bar :: Xz", "zzz = ()", "-- | haddock", "data Xzz = XzzCon"] + (Position 0 9) + [("Xzz", CompletionItemKind_Struct, "Xzz", False, True, Nothing)], + completionTest + "class" + ["bar :: Xz", "zzz = ()", "-- | haddock", "class Xzz a"] + (Position 0 9) + [("Xzz", CompletionItemKind_Interface, "Xzz", False, True, Nothing)], + completionTest + "records" + ["data Person = Person { _personName:: String, _personAge:: Int}", "bar = Person { _pers }" ] + (Position 1 19) + [("_personName", CompletionItemKind_Function, "_personName", False, True, Nothing), + ("_personAge", CompletionItemKind_Function, "_personAge", False, True, Nothing)], + completionTest + "recordsConstructor" + ["data XxRecord = XyRecord { x:: String, y:: Int}", "bar = Xy" ] + (Position 1 19) + [("XyRecord", CompletionItemKind_Constructor, "XyRecord", False, True, Nothing), + ("XyRecord", CompletionItemKind_Snippet, "XyRecord {x=${1:_x}, y=${2:_y}}", False, True, Nothing)] + ] + +localCompletionTests :: [TestTree] +localCompletionTests = [ + completionTest + "argument" + ["bar (Just abcdef) abcdefg = abcd"] + (Position 0 32) + [("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing), + ("abcdefg", CompletionItemKind_Function , "abcdefg", True, False, Nothing) + ], + completionTest + "let" + ["bar = let (Just abcdef) = undefined" + ," abcdefg = let abcd = undefined in undefined" + ," in abcd" + ] + (Position 2 15) + [("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing), + ("abcdefg", CompletionItemKind_Function , "abcdefg", True, False, Nothing) + ], + completionTest + "where" + ["bar = abcd" + ," where (Just abcdef) = undefined" + ," abcdefg = let abcd = undefined in undefined" + ] + (Position 0 10) + [("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing), + ("abcdefg", CompletionItemKind_Function , "abcdefg", True, False, Nothing) + ], + completionTest + "do/1" + ["bar = do" + ," Just abcdef <- undefined" + ," abcd" + ," abcdefg <- undefined" + ," pure ()" + ] + (Position 2 6) + [("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing) + ], + completionTest + "do/2" + ["bar abcde = do" + ," Just [(abcdef,_)] <- undefined" + ," abcdefg <- undefined" + ," let abcdefgh = undefined" + ," (Just [abcdefghi]) = undefined" + ," abcd" + ," where" + ," abcdefghij = undefined" + ] + (Position 5 8) + [("abcde", CompletionItemKind_Function, "abcde", True, False, Nothing) + ,("abcdefghij", CompletionItemKind_Function, "abcdefghij", True, False, Nothing) + ,("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing) + ,("abcdefg", CompletionItemKind_Function, "abcdefg", True, False, Nothing) + ,("abcdefgh", CompletionItemKind_Function, "abcdefgh", True, False, Nothing) + ,("abcdefghi", CompletionItemKind_Function, "abcdefghi", True, False, Nothing) + ], + completionTest + "type family" + ["{-# LANGUAGE DataKinds, TypeFamilies #-}" + ,"type family Bar a" + ,"a :: Ba" + ] + (Position 2 7) + [("Bar", CompletionItemKind_Struct, "Bar", True, False, Nothing) + ], + completionTest + "class method" + [ + "class Test a where" + , " abcd :: a -> ()" + , " abcde :: a -> Int" + , "instance Test Int where" + , " abcd = abc" + ] + (Position 4 14) + [("abcd", CompletionItemKind_Function, "abcd", True, False, Nothing) + ,("abcde", CompletionItemKind_Function, "abcde", True, False, Nothing) + ], + testSessionEmpty "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 . TextDocumentContentChangeWholeDocument $ 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 = + [ brokenForWinOldGhc $ completionTest + "variable" + ["module A where", "f = hea"] + (Position 1 7) + [("head", CompletionItemKind_Function, "head", True, True, Nothing)], + completionTest + "constructor" + ["{-# OPTIONS_GHC -Wall #-}", "module A where", "f = True"] + (Position 2 8) + [ ("True", CompletionItemKind_Constructor, "True", True, True, Nothing) + ], + brokenForWinGhc $ completionTest + "type" + ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Boo", "f = True"] + (Position 2 8) + [ ("Bool", CompletionItemKind_Struct, "Bool", True, True, Nothing) + ], + completionTest + "qualified" + ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"] + (Position 2 15) + [ ("head", CompletionItemKind_Function, "head", True, True, Nothing) + ], + completionTest + "duplicate import" + ["module A where", "import Data.List", "import Data.List", "f = permu"] + (Position 3 9) + [ ("permutations", CompletionItemKind_Function, "permutations", False, False, Nothing) + ], + completionTest + "dont show hidden items" + [ "{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", + "import Control.Monad hiding (join)", + "f = joi" + ] + (Position 3 6) + [], + testGroup "ordering" + [completionTest "qualified has priority" + ["module A where" + ,"import qualified Data.ByteString as BS" + ,"f = BS.read" + ] + (Position 2 10) + [("readFile", CompletionItemKind_Function, "readFile", True, True, Nothing)] + ], + -- we need this test to make sure the ghcide completions module does not return completions for language pragmas. this functionality is turned on in hls + completionTest + "do not show pragma completions" + [ "{-# LANGUAGE ", + "{module A where}", + "main = return ()" + ] + (Position 0 13) + [] + ] + where + brokenForWinGhc = knownBrokenOnWindows "Windows has strange things in scope for some reason" + brokenForWinOldGhc = + knownBrokenInSpecificEnv [HostOS Windows, GhcVer GHC94] "Windows (GHC == 9.4) has strange things in scope for some reason" + . knownBrokenInSpecificEnv [HostOS Windows, GhcVer GHC96] "Windows (GHC == 9.6) has strange things in scope for some reason" + . knownBrokenInSpecificEnv [HostOS Windows, GhcVer GHC98] "Windows (GHC == 9.8) 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)], + + testSessionEmpty "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"], + + testSessionEmpty "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 = + [ testSessionEmptyWithCradle "fromList" "cradle: {direct: {arguments: [-hide-all-packages, -package, base, A]}}" $ do + + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-binds #-}", + "module A () where", + "a = fromList" + ] + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 2 12) + let compls' = + [T.drop 1 $ T.dropEnd 3 d + | CompletionItem {_documentation = Just (InR (MarkupContent MarkupKind_Markdown d)), _label} + <- compls + , _label == "fromList" + ] + liftIO $ take 3 (sort compls') @?= + map ("Defined in "<>) ( + [ "'Data.List.NonEmpty" + , "'GHC.Exts" + ] ++ (["'GHC.IsList" | ghcVersion >= GHC94])) + + , testSessionEmptyWithCradle "Map" "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, containers, A]}}" $ 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" + ] + , testSessionEmpty "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 + + , testSessionEmpty "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 = + [ testSessionEmptyWithCradle "from hiedb" "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}" $ do + _ <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A (anidentifier) where", + "anidentifier = ()" + ] + _ <- waitForDiagnostics + -- Note that B does not import A + doc <- createDoc "B.hs" "haskell" $ T.unlines + [ "module B where", + "b = anidenti" + ] + compls <- getCompletions doc (Position 1 10) + let compls' = + [T.drop 1 $ T.dropEnd 3 d + | CompletionItem {_documentation = Just (InR (MarkupContent MarkupKind_Markdown d)), _label} + <- compls + , _label == "anidentifier" + ] + liftIO $ compls' @?= ["Defined in 'A"], + testSessionEmptyWithCradle "auto complete project imports" "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"ALocalModule\", \"B\"]}}" $ do + _ <- createDoc "ALocalModule.hs" "haskell" $ T.unlines + [ "module ALocalModule (anidentifier) where", + "anidentifier = ()" + ] + _ <- waitForDiagnostics + -- Note that B does not import A + doc <- createDoc "B.hs" "haskell" $ T.unlines + [ "module B where", + "import ALocal" + ] + compls <- getCompletions doc (Position 1 13) + let item = head $ filter ((== "ALocalModule") . (^. L.label)) compls + liftIO $ do + item ^. L.label @?= "ALocalModule", + testSessionEmptyWithCradle "auto complete functions from qualified imports without alias" "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}" $ do + _ <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A (anidentifier) where", + "anidentifier = ()" + ] + _ <- waitForDiagnostics + doc <- createDoc "B.hs" "haskell" $ T.unlines + [ "module B where", + "import qualified A", + "A." + ] + compls <- getCompletions doc (Position 2 2) + let item = head compls + liftIO $ do + item ^. L.label @?= "anidentifier", + testSessionEmptyWithCradle "auto complete functions from qualified imports with alias" + "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}" $ do + _ <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A (anidentifier) where", + "anidentifier = ()" + ] + _ <- waitForDiagnostics + doc <- createDoc "B.hs" "haskell" $ T.unlines + [ "module B where", + "import qualified A as Alias", + "foo = Alias." + ] + compls <- getCompletions doc (Position 2 12) + let item = head compls + liftIO $ do + item ^. L.label @?= "anidentifier" + ] + +completionDocTests :: [TestTree] +completionDocTests = + [ testSessionEmpty "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] + , testSessionEmpty "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"] + , testSessionEmpty "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"] + , testSessionEmpty "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"] + , testSessionEmpty "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"] + , testSessionEmpty "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] + , testSessionEmpty "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] + , testSessionEmpty "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] + , testSessionEmpty "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 + test doc pos label mn expected = do + _ <- waitForDiagnostics + compls <- getCompletions doc pos + rcompls <- forM compls $ \item -> 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 + let compls' = [ + -- We ignore doc uris since it points to the local path which determined by specific machines + case mn of + Nothing -> txt + Just n -> T.take n txt + | CompletionItem {_documentation = Just (InR (MarkupContent MarkupKind_Markdown txt)), ..} <- rcompls + , _label == label + ] + liftIO $ compls' @?= expected diff --git a/ghcide-test/exe/Config.hs b/ghcide-test/exe/Config.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/exe/Config.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE PatternSynonyms #-} + +module Config( + -- * basic config for ghcIde testing + mkIdeTestFs + , dummyPlugin + + -- * runners for testing specific plugins + , testSessionWithPlugin + -- * runners for testing with dummy plugin + , runWithDummyPlugin + , testWithDummyPlugin + , testWithDummyPluginEmpty + , testWithDummyPlugin' + , testWithDummyPluginEmpty' + , testWithConfig + , testWithExtraFiles + , runWithExtraFiles + , runInDir + , run + + -- * utilities for testing + , Expect(..) + , pattern R + , mkR + , checkDefs + , mkL + , withLongTimeout + , lspTestCaps + , lspTestCapsNoFileWatches + , testDataDir + ) where + +import Control.Exception (bracket_) +import Control.Lens.Setter ((.~)) +import Control.Monad (unless) +import Data.Foldable (traverse_) +import Data.Function ((&)) +import qualified Data.Text as T +import Development.IDE (Pretty) +import Development.IDE.Test (canonicalizeUri) +import Ide.Types (defaultPluginDescriptor) +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Types (Null (..)) +import System.Environment.Blank (setEnv, unsetEnv) +import System.FilePath (()) +import Test.Hls +import qualified Test.Hls.FileSystem as FS + +testDataDir :: FilePath +testDataDir = "ghcide-test" "data" + +mkIdeTestFs :: [FS.FileTree] -> FS.VirtualFileTree +mkIdeTestFs = FS.mkVirtualFileTree testDataDir + +-- * Run with some injected plugin +-- testSessionWithPlugin :: FS.VirtualFileTree -> (FilePath -> Session a) -> IO a +testSessionWithPlugin :: Pretty b => FS.VirtualFileTree -> PluginTestDescriptor b -> (FilePath -> Session a) -> IO a +testSessionWithPlugin fs plugin = runSessionWithTestConfig def + { testPluginDescriptor = plugin + , testDirLocation = Right fs + , testConfigCaps = lspTestCaps + , testShiftRoot = True + } + +-- * A dummy plugin for testing ghcIde +dummyPlugin :: PluginTestDescriptor () +dummyPlugin = mkPluginTestDescriptor (\_ pid -> defaultPluginDescriptor pid "dummyTestPlugin") "core" + +runWithDummyPlugin :: FS.VirtualFileTree -> Session a -> IO a +runWithDummyPlugin = runSessionWithServerInTmpDir def dummyPlugin + +testWithConfig :: String -> TestConfig () -> Session () -> TestTree +testWithConfig name conf s = testCase name $ runSessionWithTestConfig conf $ const s + +runWithDummyPlugin' :: FS.VirtualFileTree -> (FilePath -> Session a) -> IO a +runWithDummyPlugin' fs = runSessionWithTestConfig def + { testPluginDescriptor = dummyPlugin + , testDirLocation = Right fs + , testConfigCaps = lspTestCaps + , testShiftRoot = True + } + +testWithDummyPlugin :: String -> FS.VirtualFileTree -> Session () -> TestTree +testWithDummyPlugin caseName vfs = testWithDummyPlugin' caseName vfs . const + +testWithDummyPlugin' :: String -> FS.VirtualFileTree -> (FilePath -> Session ()) -> TestTree +testWithDummyPlugin' caseName vfs = testCase caseName . runWithDummyPlugin' vfs + +testWithDummyPluginEmpty :: String -> Session () -> TestTree +testWithDummyPluginEmpty caseName = testWithDummyPlugin caseName $ mkIdeTestFs [] + +testWithDummyPluginEmpty' :: String -> (FilePath -> Session ()) -> TestTree +testWithDummyPluginEmpty' caseName = testWithDummyPlugin' caseName $ mkIdeTestFs [] + +runWithExtraFiles :: String -> (FilePath -> Session a) -> IO a +runWithExtraFiles dirName action = do + let vfs = mkIdeTestFs [FS.copyDir dirName] + runWithDummyPlugin' vfs action + +testWithExtraFiles :: String -> String -> (FilePath -> Session ()) -> TestTree +testWithExtraFiles testName dirName action = testCase testName $ runWithExtraFiles dirName action + +runInDir :: FilePath -> Session a -> IO a +runInDir fs = runSessionWithServer def dummyPlugin fs + +run :: Session a -> IO a +run = runSessionWithTestConfig def + { testDirLocation = Right (mkIdeTestFs []) + , testPluginDescriptor = dummyPlugin } + . const + +pattern R :: UInt -> UInt -> UInt -> UInt -> Range +pattern R x y x' y' = Range (Position x y) (Position x' y') + +data Expect + = ExpectRange Range -- Both gotoDef and hover should report this range + | ExpectRanges [Range] -- definition lookup with multiple results + | 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 + | ExpectNoImplementations + | 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 + + +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 (ExpectRanges ranges) = + traverse_ (assertHasRange defs) ranges + check (ExpectLocation expectedLocation) = do + def <- assertOneDefinitionFound defs + liftIO $ do + canonActualLoc <- canonicalizeLocation def + canonExpectedLoc <- canonicalizeLocation expectedLocation + canonActualLoc @?= canonExpectedLoc + check ExpectNoImplementations = do + liftIO $ assertBool "Expecting no implementations" $ null defs + 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 + + assertHasRange actualRanges expectedRange = do + let hasRange = any (\Location{_range=foundRange} -> foundRange == expectedRange) actualRanges + unless hasRange $ liftIO $ assertFailure $ + "expected range: " <> show expectedRange <> "\nbut got ranges: " <> show defs + +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)) = [] + +lspTestCaps :: ClientCapabilities +lspTestCaps = fullLatestClientCaps { _window = Just $ WindowClientCapabilities (Just True) Nothing Nothing } + +lspTestCapsNoFileWatches :: ClientCapabilities +lspTestCapsNoFileWatches = lspTestCaps & L.workspace . traverse . L.didChangeWatchedFiles .~ Nothing + +withLongTimeout :: IO a -> IO a +withLongTimeout = bracket_ (setEnv "LSP_TIMEOUT" "120" True) (unsetEnv "LSP_TIMEOUT") diff --git a/ghcide-test/exe/CradleTests.hs b/ghcide-test/exe/CradleTests.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/exe/CradleTests.hs @@ -0,0 +1,244 @@ + +{-# LANGUAGE GADTs #-} + +module CradleTests (tests) where + +import Config (checkDefs, mkL, runInDir, + runWithExtraFiles, + testWithDummyPluginEmpty') +import Control.Applicative.Combinators +import Control.Lens ((^.)) +import Control.Monad.IO.Class (liftIO) +import qualified Data.Text as T +import Development.IDE.GHC.Util +import Development.IDE.Plugin.Test (WaitForIdeRuleResult (..)) +import Development.IDE.Test (expectDiagnostics, + expectDiagnosticsWithTags, + expectNoMoreDiagnostics, + isReferenceReady, + waitForAction) +import Development.IDE.Types.Location +import GHC.TypeLits (symbolVal) +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.Hls.Util (EnvSpec (..), OS (..), + ignoreInEnv) +import Test.Tasty +import Test.Tasty.HUnit + + +tests :: TestTree +tests = testGroup "cradle" + [testGroup "dependencies" [sessionDepsArePickedUp] + ,testGroup "ignore-fatal" [ignoreFatalWarning] + ,testGroup "loading" [loadCradleOnlyonce, retryFailedCradle] + ,testGroup "multi" (multiTests "multi") + ,testGroup "multi-unit" (multiTests "multi-unit") + ,testGroup "sub-directory" [simpleSubDirectoryTest] + ,testGroup "multi-unit-rexport" [multiRexportTest] + ] + +loadCradleOnlyonce :: TestTree +loadCradleOnlyonce = testGroup "load cradle only once" + [ testWithDummyPluginEmpty' "implicit" implicit + , testWithDummyPluginEmpty' "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 . TextDocumentContentChangeWholeDocument $ "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 = testWithDummyPluginEmpty' "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", Just "GHC-38417", 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") $ 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 = ignoreForWindows $ testCase testName $ + 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 + where + testName = multiTestName variant "def-test" + ignoreForWindows + | testName == "simple-multi-def-test" = ignoreInEnv [HostOS Windows] "Test is flaky on Windows, see #4270" + | otherwise = id + +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 = testWithDummyPluginEmpty' + "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", Just "GHC-83865")])] + + -- 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 TextDocumentContentChangePartial + { _range = Range (Position 4 0) (Position 4 0) + , _rangeLength = Nothing + , _text = "\n" + } + changeDoc doc [change] + -- Now no errors. + expectDiagnostics [("Foo.hs", [])] + where + fooContent = + T.unlines + [ "module Foo where", + "import Data.Text", + "foo :: Text", + "foo = \"hello\"" + ] diff --git a/ghcide-test/exe/DependentFileTest.hs b/ghcide-test/exe/DependentFileTest.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/exe/DependentFileTest.hs @@ -0,0 +1,62 @@ + +{-# LANGUAGE GADTs #-} + +module DependentFileTest (tests) where + +import Config +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 Test.Hls + + +tests :: TestTree +tests = testGroup "addDependentFile" + [testGroup "file-changed" [testCase "test" $ runSessionWithTestConfig def + { testShiftRoot = True + , testDirLocation = Right (mkIdeTestFs []) + , testPluginDescriptor = dummyPlugin + } test] + ] + where + test :: FilePath -> Session () + test _ = do + -- If the file contains B then no type error + -- otherwise type error + let depFilePath = "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 \"" <> T.pack depFilePath <> "\"" + , " f <- qRunIO (readFile \"" <> T.pack depFilePath <> "\")" + , " if f == \"B\" then [| 1 |] else lift f)" + ] + let bazContent = T.unlines ["module Baz where", "import Foo ()"] + _fooDoc <- createDoc "Foo.hs" "haskell" fooContent + doc <- createDoc "Baz.hs" "haskell" bazContent + expectDiagnostics + [("Foo.hs", [(DiagnosticSeverity_Error, (4,11), "Couldn't match type", Just "GHC-83865")])] + -- Now modify the dependent file + liftIO $ writeFile depFilePath "B" + sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams + [FileEvent (filePathToUri depFilePath) FileChangeType_Changed ] + + -- Modifying Baz will now trigger Foo to be rebuilt as well + let change = TextDocumentContentChangeEvent $ InL TextDocumentContentChangePartial + { _range = Range (Position 2 0) (Position 2 6) + , _rangeLength = Nothing + , _text = "f = ()" + } + changeDoc doc [change] + expectDiagnostics [("Foo.hs", [])] diff --git a/ghcide-test/exe/DiagnosticTests.hs b/ghcide-test/exe/DiagnosticTests.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/exe/DiagnosticTests.hs @@ -0,0 +1,596 @@ + +{-# LANGUAGE GADTs #-} + +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 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 Config +import Control.Lens ((^.)) +import Control.Monad.Extra (whenJust) +import Data.Default (def) +import Development.IDE.Plugin.Test (WaitForIdeRuleResult (..)) +import System.Time.Extra +import Test.Hls (TestConfig (testConfigCaps, testDirLocation, testDisableKick, testPluginDescriptor), + runSessionWithTestConfig, + waitForProgressBegin) +import Test.Hls.FileSystem (directCradle, file, text) +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = testGroup "diagnostics" + [ testWithDummyPluginEmpty "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", Just "GHC-58481")])] + let change = TextDocumentContentChangeEvent $ InL TextDocumentContentChangePartial + { _range = Range (Position 0 15) (Position 0 19) + , _rangeLength = Nothing + , _text = "where" + } + changeDoc doc [change] + expectDiagnostics [("Testing.hs", [])] + , testWithDummyPluginEmpty "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 TextDocumentContentChangePartial + { _range = Range (Position 0 15) (Position 0 18) + , _rangeLength = Nothing + , _text = "wher" + } + changeDoc doc [change] + expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "parse error", Just "GHC-58481")])] + , testWithDummyPluginEmpty "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'", Just "GHC-76037")])] + let change = TextDocumentContentChangeEvent $ InL TextDocumentContentChangePartial + { _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'", Just "GHC-76037")])] + , testWithDummyPluginEmpty "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", Just "GHC-88464") + , (DiagnosticSeverity_Error, (4, 11), "Variable not in scope: cd", Just "GHC-88464") + ] + ) + ] + , testWithDummyPluginEmpty "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'", Just "GHC-83865")] + ) + ] + , testWithDummyPluginEmpty "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", Just "GHC-88464")] + ) + ] + + , 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 aCode = + [ ("A.hs", [(DiagnosticSeverity_Error, (2,4), aMessage, aCode)]) + , ("B.hs", [(DiagnosticSeverity_Error, (3,4), bMessage, Just "GHC-83865")])] + deferralTest title binding msg code = testWithDummyPluginEmpty title $ do + _ <- createDoc "A.hs" "haskell" $ sourceA binding + _ <- createDoc "B.hs" "haskell" sourceB + expectDiagnostics $ expectedDs msg code + in + [ deferralTest "type error" "True" "Couldn't match expected type" (Just "GHC-83865") + , deferralTest "typed hole" "_" "Found hole" (Just "GHC-88464") + , deferralTest "out of scope var" "unbound" "Variable not in scope" (Just "GHC-88464") + ] + + , testWithDummyPluginEmpty "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 TextDocumentContentChangePartial + { _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", Nothing)])] + , testWithDummyPluginEmpty "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", Nothing)])] + let contentA = T.unlines [ "module ModuleA where" ] + _ <- createDoc "ModuleA.hs" "haskell" contentA + expectDiagnostics [("ModuleB.hs", [])] + , testCase "add missing module (non workspace)" $ + runSessionWithTestConfig def + { testPluginDescriptor = dummyPlugin + , testConfigCaps = lspTestCapsNoFileWatches + , testDirLocation = Right (mkIdeTestFs []) + } + $ \tmpDir -> do + -- 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 + 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", Nothing)])] + let contentA = T.unlines [ "module ModuleA where" ] + _ <- createDoc (tmpDir "ModuleA.hs") "haskell" contentA + expectDiagnostics [(tmpDir "ModuleB.hs", [])] + , testWithDummyPluginEmpty "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", Nothing)] + ) + , ( "ModuleB.hs" + , [(DiagnosticSeverity_Error, (1, 7), "Cyclic module dependency between ModuleA, ModuleB", Nothing)] + ) + ] + , let contentA = T.unlines [ "module ModuleA where" , "import ModuleB" ] + contentB = T.unlines [ "module ModuleB where" , "import ModuleA" ] + contentC = T.unlines [ "module ModuleC where" , "import ModuleB" ] + contentD = T.unlines [ "module ModuleD where" , "import ModuleC" ] + cradle = directCradle ["ModuleA", "ModuleB", "ModuleC", "ModuleD"] + in testWithDummyPlugin "deeply nested cyclic module dependency" + (mkIdeTestFs [ + file "ModuleA.hs" (text contentA) + ,file "ModuleB.hs" (text contentB) + ,file "ModuleC.hs" (text contentC) + ,cradle + ]) $ do + _ <- createDoc "ModuleD.hs" "haskell" contentD + expectDiagnostics + [ ( "ModuleB.hs" , [(DiagnosticSeverity_Error, (1, 7), "Cyclic module dependency between ModuleA, ModuleB", Nothing)]) + , ( "ModuleA.hs" , [(DiagnosticSeverity_Error, (1, 7), "Cyclic module dependency between ModuleA, ModuleB", Nothing)]) + ] + , testWithDummyPluginEmpty "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", Just "GHC-38417")])] + , testWithDummyPlugin "bidirectional module dependency with hs-boot" + (mkIdeTestFs [directCradle ["ModuleA", "ModuleB"]]) + $ do + 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" + ] + _ <- 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", Just "GHC-38417")])] + , testWithDummyPluginEmpty "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", Just "GHC-38417")])] + , testWithDummyPluginEmpty "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", Nothing, Just DiagnosticTag_Unnecessary)] + ) + ] + , testWithDummyPluginEmpty "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", Just "GHC-38417")])] + , testWithDummyPluginEmpty "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", Just "GHC-88464") + ,(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", Just "GHC-88464") + ] + ) + ] + , testWithDummyPluginEmpty "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", Just "GHC-30606") + ] + ) + ] + , testWithDummyPluginEmpty "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 + , testWithDummyPluginEmpty "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 + , testWithDummyPlugin "-Werror in cradle is ignored" + (mkIdeTestFs [directCradle ["-Wall", "-Werror"]]) + $ do + 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:", Nothing) + ] + ) + ] + , testWithDummyPluginEmpty "-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:", Nothing) + ] + ) + ] + , 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", Just "GHC-38417")])] -- 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 . TextDocumentContentChangeWholeDocument $ + 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'", Just "GHC-83865")]) + ] + + -- Open A and edit to fix the type error + adoc <- createDoc aPath "haskell" aSource + changeDoc adoc [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ + 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'", Just "GHC-83865"), + (DiagnosticSeverity_Warning, (4, 0), "Top-level binding", Just "GHC-38417") + ] + ), + ("A.hs", []) + ] + expectNoMoreDiagnostics 1 + + , testWithDummyPluginEmpty "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'", Nothing)])] + + changeDoc doc [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ "module Foo() where" ] + expectDiagnostics [] + + changeDoc doc [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ T.unlines + [ "module Foo() where" , "import MissingModule" ] ] + expectDiagnostics [("Foo.hs", [(DiagnosticSeverity_Error, (1,7), "Could not find module 'MissingModule'", Nothing)])] + + , 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 TextDocumentContentChangePartial + { _range = Range p p + , _rangeLength = Nothing + , _text = "fd" + } + + ,TextDocumentContentChangeEvent $ InL TextDocumentContentChangePartial + { _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", Just "GHC-38417") ] + 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 + runTestNoKick s = + runSessionWithTestConfig def + { testPluginDescriptor = dummyPlugin + , testDirLocation = Right (mkIdeTestFs []) + , testDisableKick = True + } $ const s + + typeCheck doc = do + WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc + liftIO $ assertBool "The file should typecheck" ideResultSuccess + -- wait for the debouncer to publish diagnostics if the rule runs + liftIO $ sleep 0.2 + -- flush messages to ensure current diagnostics state is updated + flushMessages diff --git a/ghcide-test/exe/ExceptionTests.hs b/ghcide-test/exe/ExceptionTests.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/exe/ExceptionTests.hs @@ -0,0 +1,140 @@ + +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.Default (Default (..)) +import qualified Data.Text as T +import Development.IDE.Core.Shake (IdeState (..)) +import qualified Development.IDE.LSP.Notifications as Notifications +import Development.IDE.Plugin.HLS (toResponseError) +import GHC.Base (coerce) +import Ide.Logger (Recorder, WithPriority, + cmapWithPrio) +import Ide.Plugin.Error +import Ide.Plugin.HandleRequestTypes (RejectionReason (DisabledGlobally)) +import Ide.PluginUtils (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.Hls (TestConfig (testDisableDefaultPlugin, testPluginDescriptor), + runSessionWithTestConfig, + testCheckProject, + waitForProgressDone) +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = do + testGroup "Exceptions and PluginError" [ + testGroup "Testing that IO Exceptions are caught in..." + [ testCase "PluginHandlers" $ do + let pluginId = "plugin-handler-exception" + plugins :: Recorder (WithPriority Log) -> IdePlugins IdeState + plugins r = pluginDescToIdePlugins $ + [ (defaultPluginDescriptor pluginId "") + { pluginHandlers = mconcat + [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do + _ <- liftIO $ throwIO DivideByZero + pure (InL []) + ] + }] ++ [Notifications.descriptor (cmapWithPrio LogNotifications r) "ghcide-core"] + runSessionWithTestConfig def {testPluginDescriptor = plugins, testDisableDefaultPlugin=True, testCheckProject=False + } $ const $ do + doc <- createDoc "A.hs" "haskell" "module A where" + (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) + case lens of + Left (TResponseError {_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 :: Recorder (WithPriority Log) -> IdePlugins IdeState + plugins r = pluginDescToIdePlugins $ + [ (defaultPluginDescriptor pluginId "") + { pluginCommands = + [ PluginCommand commandId "Causes an exception" $ \_ _ (_::Int) -> do + _ <- liftIO $ throwIO DivideByZero + pure (InR Null) + ] + }] ++ [Notifications.descriptor (cmapWithPrio LogNotifications r) "ghcide-core"] + runSessionWithTestConfig def {testPluginDescriptor = plugins, testDisableDefaultPlugin=True, testCheckProject=False} $ const $ 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 (TResponseError {_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 :: Recorder (WithPriority Log) -> IdePlugins IdeState + plugins r = pluginDescToIdePlugins $ + [ (defaultPluginDescriptor pluginId "") + { pluginNotificationHandlers = mconcat + [ mkPluginNotificationHandler SMethod_TextDocumentDidOpen $ \_ _ _ _ -> + liftIO $ throwIO DivideByZero + ] + , pluginHandlers = mconcat + [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do + pure (InL []) + ] + }] ++ [Notifications.descriptor (cmapWithPrio LogNotifications r) "ghcide-core"] + runSessionWithTestConfig def {testPluginDescriptor = plugins, testDisableDefaultPlugin=True, testCheckProject=False} $ const $ 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 "InternalError over InvalidParams" (PluginInternalError "error test") (PluginInvalidParams "error test") + , pluginOrderTestCase "InvalidParams over InvalidUserState" (PluginInvalidParams "error test") (PluginInvalidUserState "error test") + , pluginOrderTestCase "InvalidUserState over RequestRefused" (PluginInvalidUserState "error test") (PluginRequestRefused DisabledGlobally) + ] + ] + +pluginOrderTestCase :: TestName -> PluginError -> PluginError -> TestTree +pluginOrderTestCase msg err1 err2 = + testCase msg $ do + let pluginId = "error-order-test" + plugins :: Recorder (WithPriority Log) -> IdePlugins IdeState + plugins r = pluginDescToIdePlugins $ + [ (defaultPluginDescriptor pluginId "") + { pluginHandlers = mconcat + [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do + throwError err1 + ,mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do + throwError err2 + ] + }] ++ [Notifications.descriptor (cmapWithPrio LogNotifications r) "ghcide-core"] + runSessionWithTestConfig def {testPluginDescriptor = plugins, testDisableDefaultPlugin=True, testCheckProject=False} $ const $ do + doc <- createDoc "A.hs" "haskell" "module A where" + waitForProgressDone + (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) + case lens of + Left re | toResponseError (pluginId, err1) == re -> pure () + | otherwise -> liftIO $ assertFailure "We caught an error, but it wasn't ours!" + _ -> liftIO $ assertFailure $ show lens diff --git a/ghcide-test/exe/FindDefinitionAndHoverTests.hs b/ghcide-test/exe/FindDefinitionAndHoverTests.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/exe/FindDefinitionAndHoverTests.hs @@ -0,0 +1,257 @@ +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +module FindDefinitionAndHoverTests (tests) where + +import Control.Monad +import Data.Foldable +import Data.Maybe +import qualified Data.Text as T +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Test +import System.Info.Extra (isWindows) + +import Config +import Control.Category ((>>>)) +import Control.Lens ((^.)) +import Development.IDE.Test (expectDiagnostics, + standardizeQuotes) +import Test.Hls +import Test.Hls.FileSystem (copyDir) +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 = + testWithDummyPlugin title (mkIdeTestFs [copyDir "hover"]) $ do + doc <- openDoc sfp "haskell" + waitForProgressDone + _x <- waitForTypecheck doc + found <- get doc pos + check found targetRange + + + + checkHover :: (HasCallStack) => Maybe Hover -> Session [Expect] -> Session () + checkHover hover expectations = traverse_ check =<< expectations where + + check :: (HasCallStack) => Expect -> Session () + check expected = + case hover of + Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found" + Just Hover{_contents = (InL MarkupContent{_value = standardizeQuotes -> msg}) + ,_range = rangeInHover } -> + case expected of + ExpectRange expectedRange -> checkHoverRange expectedRange rangeInHover msg + ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg + ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets + ExpectHoverExcludeText snippets -> liftIO $ traverse_ (`assertNotFoundIn` msg) snippets + ExpectHoverTextRegex re -> liftIO $ assertBool ("Regex not found in " <> T.unpack msg) (msg =~ re :: Bool) + ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover + _ -> pure () -- all other expectations not relevant to hover + _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover + + extractLineColFromHoverMsg :: T.Text -> [T.Text] + extractLineColFromHoverMsg = + -- Hover messages contain multiple lines, and we are looking for the definition + -- site + T.lines + -- The line we are looking for looks like: "*Defined at /tmp/GotoHover.hs:22:3*" + -- So filter by the start of the line + >>> mapMaybe (T.stripPrefix "*Defined at") + -- There can be multiple definitions per hover message! + -- See the test "field in record definition" for example. + -- The tests check against the last line that contains the above line. + >>> last + -- [" /tmp/", "22:3*"] + >>> T.splitOn (sourceFileName <> ":") + -- "22:3*" + >>> last + -- ["22:3", ""] + >>> T.splitOn "*" + -- "22:3" + >>> head + -- ["22", "3"] + >>> T.splitOn ":" + + checkHoverRange :: Range -> Maybe Range -> T.Text -> Session () + checkHoverRange expectedRange rangeInHover msg = + let + lineCol = extractLineColFromHoverMsg msg + -- looks like hovers use 1-based numbering while definitions use 0-based + -- turns out that they are stored 1-based in RealSrcLoc by GHC itself. + adjust Position{_line = l, _character = c} = + Position{_line = l + 1, _character = c + 1} + in + case map (read . T.unpack) lineCol of + [l,c] -> liftIO $ adjust (expectedRange ^. L.start) @=? Position l c + _ -> liftIO $ assertFailure $ + "expected: " <> show ("[...]" <> sourceFileName <> "::**[...]", Just expectedRange) <> + "\n but got: " <> show (msg, rangeInHover) + + assertFoundIn :: T.Text -> T.Text -> Assertion + assertFoundIn part whole = assertBool + (T.unpack $ "failed to find: `" <> part <> "` in hover message:\n" <> whole) + (part `T.isInfixOf` whole) + + assertNotFoundIn :: T.Text -> T.Text -> Assertion + assertNotFoundIn part whole = assertBool + (T.unpack $ "found unexpected: `" <> part <> "` in hover message:\n" <> whole) + (not . T.isInfixOf part $ whole) + + sourceFilePath = T.unpack sourceFileName + sourceFileName = "GotoHover.hs" + + mkFindTests tests = testGroup "get" + [ testGroup "definition" $ mapMaybe fst tests + , testGroup "hover" $ mapMaybe snd tests + , testGroup "hover compile" [checkFileCompiles sourceFilePath $ + expectDiagnostics + [ ( "GotoHover.hs", [(DiagnosticSeverity_Error, (62, 7), "Found hole: _", Just "GHC-88464")]) + , ( "GotoHover.hs", [(DiagnosticSeverity_Error, (65, 8), "Found hole: _", Just "GHC-88464")]) + ]] + , testGroup "type-definition" typeDefinitionTests + , testGroup "hover-record-dot-syntax" recordDotSyntaxTests ] + + typeDefinitionTests = [ tst (getTypeDefinitions, checkDefs) aaaL14 sourceFilePath (pure tcData) "Saturated data con" + , tst (getTypeDefinitions, checkDefs) aL20 sourceFilePath (pure [ExpectNoDefinitions]) "Polymorphic variable"] + + recordDotSyntaxTests = + [ tst (getHover, checkHover) (Position 17 24) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["x :: MyRecord"]]) "hover over parent" + , tst (getHover, checkHover) (Position 17 25) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over dot shows child" + , tst (getHover, checkHover) (Position 17 26) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over child" + ] + + test :: (HasCallStack) => (TestTree -> a) -> (TestTree -> b) -> Position -> [Expect] -> String -> (a, b) + test runDef runHover look expect = testM runDef runHover look (return expect) + + testM :: (HasCallStack) => (TestTree -> a) + -> (TestTree -> b) + -> Position + -> Session [Expect] + -> String + -> (a, b) + testM runDef runHover look expect title = + ( runDef $ tst def look sourceFilePath expect title + , runHover $ tst hover look sourceFilePath expect title ) where + def = (getDefinitions, checkDefs) + hover = (getHover , checkHover) + + -- search locations expectations on results + -- TODO: Lookup of record field should return exactly one result + fffL4 = fffR ^. L.start; fffR = mkRange 8 4 8 7; fff = [ExpectRanges [fffR, mkRange 7 23 9 16]] + fffL8 = Position 12 4 ; fff' = [ExpectRange fffR] + 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 = [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 = [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 = [ExpectHoverText ["Num", "Defined in ", if ghcVersion < GHC910 then "GHC.Num" else "GHC.Internal.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"]] + -- TODO: Kind signature of type variables should be `Type -> Type` + tvrL40 = Position 44 37 ; kindV = [ExpectHoverText ["m"]]; kindV' = [ExpectHoverText [":: * -> *\n"]] + -- TODO: Hover of integer literal should be `7518` + intL41 = Position 45 20 ; litI = [ExpectHoverText ["_ :: Int"]]; litI' = [ExpectHoverText ["7518"]] + -- TODO: Hover info of char literal should be `'f'` + chrL36 = Position 41 24 ; litC = [ExpectHoverText ["_ :: Char"]]; litC' = [ExpectHoverText ["'f'"]] + -- TODO: Hover info of Text literal should be `"dfgy"` + txtL8 = Position 12 14 ; litT = [ExpectHoverText ["_ :: Text"]]; litT' = [ExpectHoverText ["\"dfgy\""]] + -- TODO: Hover info of List literal should be `[8391 :: Int, 6268]` + lstL43 = Position 47 12 ; litL = [ExpectHoverText ["[Int]"]]; litL' = [ExpectHoverText ["[8391 :: Int, 6268]"]] + outL45 = Position 49 3 ; outSig = [ExpectHoverText ["outer", "Bool"], mkR 50 0 50 5] + -- TODO: Hover info of local function signature should be `inner :: Bool` + innL48 = Position 52 5 ; innSig = [ExpectHoverText ["inner"], mkR 53 2 53 7]; 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"], if ghcVersion >= GHC94 && ghcVersion < GHC910 then mkL bar 3 5 3 8 else mkL bar 3 0 3 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 fff') 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 yes yes xtcL5 xtc "type constructor external #717,1028" + , test yes 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 yes 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 kindV') tvrL40 kindV "kind of (* -> *) type variable #1017" + , test no (broken litI') intL41 litI "literal Int in hover info #1016" + , test no (broken litC') chrL36 litC "literal Char in hover info #1016" + , test no (broken litT') txtL8 litT "literal Text in hover info #1016" + , test no (broken litL') 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 yes (broken innSig') 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 :: (TestTree -> Maybe TestTree) + yes = Just -- test should run and pass + no = const Nothing -- don't run this test at all + --skip = const Nothing -- unreliable, don't run + broken :: [Expect] -> TestTree -> Maybe TestTree + broken _ = yes + +checkFileCompiles :: FilePath -> Session () -> TestTree +checkFileCompiles fp diag = + testWithDummyPlugin ("hover: Does " ++ fp ++ " compile") (mkIdeTestFs [copyDir "hover"]) $ do + _ <- openDoc fp "haskell" + diag diff --git a/ghcide-test/exe/FindImplementationAndHoverTests.hs b/ghcide-test/exe/FindImplementationAndHoverTests.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/exe/FindImplementationAndHoverTests.hs @@ -0,0 +1,228 @@ +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +module FindImplementationAndHoverTests (tests) where + +import Control.Monad +import Data.Foldable +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Language.LSP.Test +import Text.Regex.TDFA ((=~)) + +import Config +import Development.IDE.Test (standardizeQuotes) +import Test.Hls +import Test.Hls.FileSystem (copyDir) + +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 = + testWithDummyPlugin title (mkIdeTestFs [copyDir "hover"]) $ do + doc <- openDoc sfp "haskell" + waitForProgressDone + _x <- waitForTypecheck doc + found <- get doc pos + check found targetRange + + checkHover :: (HasCallStack) => Maybe Hover -> Session [Expect] -> Session () + checkHover hover expectations = traverse_ check =<< expectations where + + check :: (HasCallStack) => Expect -> Session () + check expected = + case hover of + Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found" + Just Hover{_contents = (InL MarkupContent{_value = standardizeQuotes -> msg}) + ,_range = _rangeInHover } -> + case expected of + ExpectRange _expectedRange -> liftIO $ assertFailure $ "ExpectRange assertion not implemented, yet." + ExpectHoverRange _expectedRange -> liftIO $ assertFailure $ "ExpectHoverRange assertion not implemented, yet." + 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 + + 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 = "GotoImplementation.hs" + + mkFindTests tests = testGroup "goto implementation" + [ testGroup "implementation" $ mapMaybe fst allTests + , testGroup "hover" $ mapMaybe snd allTests + ] + where + allTests = tests ++ recordDotSyntaxTests + + recordDotSyntaxTests = + -- We get neither new hover information nor 'Goto Implementation' locations for record-dot-syntax + [ test' "RecordDotSyntax.hs" yes yes (Position 17 6) [ExpectNoImplementations, ExpectHoverText ["_ :: [Char]"]] "hover over parent" + , test' "RecordDotSyntax.hs" yes yes (Position 17 18) [ExpectNoImplementations, ExpectHoverText ["_ :: Integer"]] "hover over dot shows child" + , test' "RecordDotSyntax.hs" yes yes (Position 17 25) [ExpectNoImplementations, ExpectHoverText ["_ :: MyChild"]] "hover over child" + , test' "RecordDotSyntax.hs" yes yes (Position 17 27) [ExpectNoImplementations, ExpectHoverText ["_ :: [Char]"]] "hover over grandchild" + ] + + test :: (HasCallStack) => (TestTree -> a) -> (TestTree -> b) -> Position -> [Expect] -> String -> (a, b) + test runImpl runHover look expect = testM runImpl runHover look (return expect) + + testM :: (HasCallStack) => (TestTree -> a) + -> (TestTree -> b) + -> Position + -> Session [Expect] + -> String + -> (a, b) + testM = testM' sourceFilePath + + test' :: (HasCallStack) => FilePath -> (TestTree -> a) -> (TestTree -> b) -> Position -> [Expect] -> String -> (a, b) + test' sourceFile runImpl runHover look expect = testM' sourceFile runImpl runHover look (return expect) + + testM' :: (HasCallStack) + => FilePath + -> (TestTree -> a) + -> (TestTree -> b) + -> Position + -> Session [Expect] + -> String + -> (a, b) + testM' sourceFile runImpl runHover look expect title = + ( runImpl $ tst impl look sourceFile expect title + , runHover $ tst hover look sourceFile expect title ) where + impl = (getImplementations, checkDefs) + hover = (getHover , checkHover) + + aaaL = Position 8 15; aaaR = mkRange 5 9 5 16; + aaa = + [ ExpectRanges [aaaR] + , ExpectHoverText (evidenceBoundByConstraint "Num" "AAA") + ] + + bbbL = Position 15 8; bbbR = mkRange 12 9 12 16; + bbb = + [ ExpectRanges [bbbR] + , ExpectHoverText (evidenceBoundByConstraint "BBB" "AAA") + ] + cccL = Position 18 11; + ccc = + [ ExpectNoImplementations + , ExpectHoverText (evidenceBySignatureOrPattern "Show" "a") + ] + dddShowR = mkRange 21 26 21 30; dddEqR = mkRange 21 22 21 24 + dddL1 = Position 23 16; + ddd1 = + [ ExpectRanges [dddEqR] + , ExpectHoverText + [ constraintEvidence "Eq" "(Q k)" + , evidenceGoal' "'forall k. Eq k => Eq (Q k)'" + , boundByInstanceOf "Eq" + , evidenceGoal "Eq" "k" + , boundByTypeSigOrPattern + ] + ] + dddL2 = Position 23 29; + ddd2 = + [ ExpectNoImplementations + , ExpectHoverText (evidenceBySignatureOrPattern "Show" "k") + ] + dddL3 = Position 24 8; + ddd3 = + [ ExpectRanges [dddEqR, dddShowR] + , ExpectHoverText + [ constraintEvidence "Show" "(Q Integer)" + , evidenceGoal' "'forall k. Show k => Show (Q k)'" + , boundByInstance + , evidenceGoal "Show" "Integer" + , usingExternalInstance + , constraintEvidence "Eq" "(Q Integer)" + , evidenceGoal' "'forall k. Eq k => Eq (Q k)'" + , boundByInstance + , evidenceGoal "Eq" "Integer" + , usingExternalInstance + ] + ] + gadtL = Position 29 35; + gadt = + [ ExpectNoImplementations + , ExpectHoverText + [ constraintEvidence "Show" "Int" + , evidenceGoal "Show" "a" + , boundByTypeSigOrPattern + , evidenceGoal' "'a ~ Int'" + , boundByPattern + ] + ] + in + mkFindTests + -- impl hover look expect + [ + test yes yes aaaL aaa "locally defined class instance" + , test yes yes bbbL bbb "locally defined class and instance" + , test yes yes cccL ccc "bound by type signature" + , test yes yes dddL1 ddd1 "newtype Eq evidence" + , test yes yes dddL2 ddd2 "Show evidence" + , test yes yes dddL3 ddd3 "evidence construction" + , test yes yes gadtL gadt "GADT evidence" + ] + where yes :: (TestTree -> Maybe TestTree) + yes = Just -- test should run and pass + no = const Nothing -- don't run this test at all + +-- ---------------------------------------------------------------------------- +-- Helper functions for creating hover message verification +-- ---------------------------------------------------------------------------- + +evidenceBySignatureOrPattern :: Text -> Text -> [Text] +evidenceBySignatureOrPattern tyclass varname = + [ constraintEvidence tyclass varname + , boundByTypeSigOrPattern + ] + +evidenceBoundByConstraint :: Text -> Text -> [Text] +evidenceBoundByConstraint tyclass varname = + [ constraintEvidence tyclass varname + , boundByInstanceOf tyclass + ] + +boundByTypeSigOrPattern :: Text +boundByTypeSigOrPattern = "bound by type signature or pattern" + +boundByInstance :: Text +boundByInstance = + "bound by an instance of" + +boundByInstanceOf :: Text -> Text +boundByInstanceOf tyvar = + "bound by an instance of class " <> tyvar + +boundByPattern :: Text +boundByPattern = + "bound by a pattern" + +usingExternalInstance :: Text +usingExternalInstance = + "using an external instance" + +constraintEvidence :: Text -> Text -> Text +constraintEvidence tyclass varname = "Evidence of constraint " <> quotedName tyclass varname + +-- | A goal in the evidence tree. +evidenceGoal :: Text -> Text -> Text +evidenceGoal tyclass varname = "- " <> quotedName tyclass varname + +evidenceGoal' :: Text -> Text +evidenceGoal' t = "- " <> t + +quotedName :: Text -> Text -> Text +quotedName tyclass varname = "'" <> tyclass <> " " <> varname <> "'" diff --git a/ghcide-test/exe/FuzzySearch.hs b/ghcide-test/exe/FuzzySearch.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/exe/FuzzySearch.hs @@ -0,0 +1,130 @@ +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" + +{-# ANN dictionary ("HLint: ignore Avoid restricted function" :: String) #-} +{-# NOINLINE dictionary #-} +dictionary :: [Text] +dictionary = unsafePerformIO $ do + existsDictionary <- doesFileExist dictionaryPath + if existsDictionary + then map pack . words <$> readFile dictionaryPath + else pure [] + +referenceImplementation :: forall s t. + (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 pat' 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, + pat', + True + ) + s + +needDictionary :: TestTree -> TestTree +needDictionary + | null dictionary = ignoreTestBecause ("not found: " <> dictionaryPath) + | otherwise = id diff --git a/ghcide-test/exe/GarbageCollectionTests.hs b/ghcide-test/exe/GarbageCollectionTests.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/exe/GarbageCollectionTests.hs @@ -0,0 +1,89 @@ +module GarbageCollectionTests (tests) where + +import Config (testWithDummyPluginEmpty') +import Control.Monad.IO.Class (liftIO) +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.Tasty +import Test.Tasty.HUnit +import Text.Printf (printf) + +tests :: TestTree +tests = testGroup "garbage collection" + [ testGroup "dirty keys" + [ testWithDummyPluginEmpty' "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 + + , testWithDummyPluginEmpty' "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) + + , testWithDummyPluginEmpty' "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 + + , testWithDummyPluginEmpty' "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 $ TextDocumentContentChangeWholeDocument edit] + builds <- waitForTypecheck doc + liftIO $ assertBool "it still builds" builds + expectCurrentDiagnostics doc [(DiagnosticSeverity_Error, (2,4), "Couldn't match expected type", Just "GHC-83865")] + ] + ] + where + isExpected k = "GhcSessionIO" `T.isPrefixOf` k + + generateGarbage :: String -> FilePath -> Session TextDocumentIdentifier + generateGarbage modName dir = do + let fp = modName <> ".hs" + body = printf "module %s where" modName + doc <- createDoc fp "haskell" (T.pack body) + liftIO $ writeFile (dir fp) body + builds <- waitForTypecheck doc + liftIO $ assertBool "something is wrong with this test" builds + return doc diff --git a/ghcide-test/exe/HaddockTests.hs b/ghcide-test/exe/HaddockTests.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/exe/HaddockTests.hs @@ -0,0 +1,90 @@ + +module HaddockTests (tests) where + +import Development.IDE.Spans.Common +-- import Test.QuickCheck.Instances () +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests + = testGroup "haddock" + [ testCase "Num" $ checkHaddock + (unlines + [ "However, '(+)' and '(*)' are" + , "customarily expected to define a ring and have the following properties:" + , "" + , "[__Associativity of (+)__]: @(x + y) + z@ = @x + (y + z)@" + , "[__Commutativity of (+)__]: @x + y@ = @y + x@" + , "[__@fromInteger 0@ is the additive identity__]: @x + fromInteger 0@ = @x@" + ] + ) + (unlines + [ "" + , "" + , "However, `(+)` and `(*)` are" + , "customarily expected to define a ring and have the following properties: " + , "+ ****Associativity of (+)****: `(x + y) + z` = `x + (y + z)`" + , "+ ****Commutativity of (+)****: `x + y` = `y + x`" + , "+ ****`fromInteger 0` is the additive identity****: `x + fromInteger 0` = `x`" + ] + ) + , testCase "unsafePerformIO" $ checkHaddock + (unlines + [ "may require" + , "different precautions:" + , "" + , " * Use @{\\-\\# NOINLINE foo \\#-\\}@ as a pragma on any function @foo@" + , " that calls 'unsafePerformIO'. If the call is inlined," + , " the I\\/O may be performed more than once." + , "" + , " * Use the compiler flag @-fno-cse@ to prevent common sub-expression" + , " elimination being performed on the module." + , "" + ] + ) + (unlines + [ "" + , "" + , "may require" + , "different precautions: " + , "+ Use `{-# NOINLINE foo #-}` as a pragma on any function `foo` " + , " that calls `unsafePerformIO` . If the call is inlined," + , " the I/O may be performed more than once." + , "" + , "+ Use the compiler flag `-fno-cse` to prevent common sub-expression" + , " elimination being performed on the module." + , "" + ] + ) + , testCase "ordered list" $ checkHaddock + (unlines + [ "may require" + , "different precautions:" + , "" + , " 1. Use @{\\-\\# NOINLINE foo \\#-\\}@ as a pragma on any function @foo@" + , " that calls 'unsafePerformIO'. If the call is inlined," + , " the I\\/O may be performed more than once." + , "" + , " 2. Use the compiler flag @-fno-cse@ to prevent common sub-expression" + , " elimination being performed on the module." + , "" + ] + ) + (unlines + [ "" + , "" + , "may require" + , "different precautions: " + , "1. Use `{-# NOINLINE foo #-}` as a pragma on any function `foo` " + , " that calls `unsafePerformIO` . If the call is inlined," + , " the I/O may be performed more than once." + , "" + , "2. Use the compiler flag `-fno-cse` to prevent common sub-expression" + , " elimination being performed on the module." + , "" + ] + ) + ] + where + checkHaddock s txt = spanDocToMarkdownForTest s @?= txt diff --git a/ghcide-test/exe/HieDbRetry.hs b/ghcide-test/exe/HieDbRetry.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/exe/HieDbRetry.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE MultiWayIf #-} +module HieDbRetry (tests) where + +import Control.Concurrent.Extra (Var, modifyVar, newVar, readVar, + withVar) +import Control.Exception (ErrorCall (ErrorCall), evaluate, + throwIO, tryJust) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Tuple.Extra (dupe) +import qualified Database.SQLite.Simple as SQLite +import Development.IDE.Session (retryOnException, retryOnSqliteBusy) +import qualified Development.IDE.Session as Session +import Ide.Logger (Recorder (Recorder, logger_), + WithPriority (WithPriority, payload), + cmapWithPrio) +import qualified System.Random as Random +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) + +data Log + = LogSession Session.Log + deriving Show + +makeLogger :: Var [Log] -> Recorder (WithPriority Log) +makeLogger msgsVar = + Recorder { + logger_ = \WithPriority{ payload = msg } -> liftIO $ modifyVar msgsVar (\msgs -> pure (msg : msgs, ())) + } + +rng :: Random.StdGen +rng = Random.mkStdGen 0 + +retryOnSqliteBusyForTest :: Recorder (WithPriority Log) -> Int -> IO a -> IO a +retryOnSqliteBusyForTest recorder maxRetryCount = retryOnException isErrorBusy (cmapWithPrio LogSession recorder) 1 1 maxRetryCount rng + +isErrorBusy :: SQLite.SQLError -> Maybe SQLite.SQLError +isErrorBusy e + | SQLite.SQLError { sqlError = SQLite.ErrorBusy } <- e = Just e + | otherwise = Nothing + +errorBusy :: SQLite.SQLError +errorBusy = SQLite.SQLError{ sqlError = SQLite.ErrorBusy, sqlErrorDetails = "", sqlErrorContext = "" } + +isErrorCall :: ErrorCall -> Maybe ErrorCall +isErrorCall e + | ErrorCall _ <- e = Just e + +tests :: TestTree +tests = testGroup "RetryHieDb" + [ testCase "retryOnException throws exception after max retries" $ do + logMsgsVar <- newVar [] + let logger = makeLogger logMsgsVar + let maxRetryCount = 1 + + result <- tryJust isErrorBusy (retryOnSqliteBusyForTest logger maxRetryCount (throwIO errorBusy)) + + case result of + Left exception -> do + exception @?= errorBusy + withVar logMsgsVar $ \logMsgs -> + length logMsgs @?= 2 + -- uncomment if want to compare log msgs + -- logMsgs @?= [] + Right _ -> assertFailure "Expected ErrorBusy exception" + + , testCase "retryOnException doesn't throw if given function doesn't throw" $ do + let expected = 1 :: Int + let maxRetryCount = 0 + + actual <- retryOnSqliteBusyForTest mempty maxRetryCount (pure expected) + + actual @?= expected + + , testCase "retryOnException retries the number of times it should" $ do + countVar <- newVar 0 + let maxRetryCount = 3 + let incrementThenThrow = modifyVar countVar (\count -> pure (dupe (count + 1))) >> throwIO errorBusy + + _ <- tryJust isErrorBusy (retryOnSqliteBusyForTest mempty maxRetryCount incrementThenThrow) + + withVar countVar $ \count -> + count @?= maxRetryCount + 1 + + , testCase "retryOnException doesn't retry if exception is not ErrorBusy" $ do + countVar <- newVar (0 :: Int) + let maxRetryCount = 1 + + let throwThenIncrement = do + count <- readVar countVar + if count == 0 then + evaluate (error "dummy exception") + else + modifyVar countVar (\count -> pure (dupe (count + 1))) + + + _ <- tryJust isErrorCall (retryOnSqliteBusyForTest mempty maxRetryCount throwThenIncrement) + + withVar countVar $ \count -> + count @?= 0 + + , testCase "retryOnSqliteBusy retries on ErrorBusy" $ do + countVar <- newVar (0 :: Int) + + let incrementThenThrowThenIncrement = do + count <- readVar countVar + if count == 0 then + modifyVar countVar (\count -> pure (dupe (count + 1))) >> throwIO errorBusy + else + modifyVar countVar (\count -> pure (dupe (count + 1))) + + _ <- retryOnSqliteBusy mempty rng incrementThenThrowThenIncrement + + withVar countVar $ \count -> + count @?= 2 + + , testCase "retryOnException exponentially backs off" $ do + logMsgsVar <- newVar ([] :: [Log]) + + let maxDelay = 100 + let baseDelay = 1 + let maxRetryCount = 6 + let logger = makeLogger logMsgsVar + + result <- tryJust isErrorBusy (retryOnException isErrorBusy (cmapWithPrio LogSession logger) maxDelay baseDelay maxRetryCount rng (throwIO errorBusy)) + + case result of + Left _ -> do + withVar logMsgsVar $ \logMsgs -> + -- uses log messages to check backoff... + if | (LogSession (Session.LogHieDbRetriesExhausted baseDelay maximumDelay maxRetryCount _) : _) <- logMsgs -> do + baseDelay @?= 64 + maximumDelay @?= 100 + maxRetryCount @?= 0 + | otherwise -> assertFailure "Expected more than 0 log messages" + Right _ -> assertFailure "Expected ErrorBusy exception" + ] diff --git a/ghcide-test/exe/HighlightTests.hs b/ghcide-test/exe/HighlightTests.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/exe/HighlightTests.hs @@ -0,0 +1,78 @@ + +module HighlightTests (tests) where + +import Config +import Control.Monad.IO.Class (liftIO) +import qualified Data.Text as T +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 + +tests :: TestTree +tests = testGroup "highlight" + [ testWithDummyPluginEmpty "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) + ] + , testWithDummyPluginEmpty "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) + ] + , testWithDummyPluginEmpty "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) + ] + , + testWithDummyPluginEmpty "record" $ do + doc <- createDoc "A.hs" "haskell" recsource + _ <- waitForDiagnostics + highlights <- getHighlights doc (Position 4 15) + liftIO $ highlights @?= + [ DocumentHighlight (R 4 8 4 10) (Just DocumentHighlightKind_Write) + , DocumentHighlight (R 4 14 4 20) (Just DocumentHighlightKind_Read) + ] + highlights <- getHighlights doc (Position 3 17) + liftIO $ highlights @?= + [ DocumentHighlight (R 3 17 3 23) (Just DocumentHighlightKind_Write) + , DocumentHighlight (R 4 8 4 10) (Just DocumentHighlightKind_Read) + ] + ] + where + source = T.unlines + ["{-# OPTIONS_GHC -Wunused-binds #-}" + ,"module Highlight () where" + ,"foo :: Int" + ,"foo = 3 :: Int" + ,"bar = foo" + ," where baz = let x = foo in x" + ,"baz arg = arg + x" + ," where x = arg" + ] + recsource = T.unlines + ["{-# LANGUAGE RecordWildCards #-}" + ,"{-# OPTIONS_GHC -Wunused-binds #-}" + ,"module Highlight () where" + ,"data Rec = Rec { field1 :: Int, field2 :: Char }" + ,"foo Rec{..} = field2 + field1" + ] diff --git a/ghcide-test/exe/IfaceTests.hs b/ghcide-test/exe/IfaceTests.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/exe/IfaceTests.hs @@ -0,0 +1,162 @@ +module IfaceTests (tests) where + +import Config +import Control.Monad.IO.Class (liftIO) +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 + +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 = testWithExtraFiles "iface-th-test" "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 $ TextDocumentContentChangeWholeDocument cSource] + expectDiagnostics + [("THC.hs", [(DiagnosticSeverity_Error, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'", Just "GHC-83865")]) + ,("THB.hs", [(DiagnosticSeverity_Warning, (4,1), "Top-level binding", Just "GHC-38417")])] + closeDoc cdoc + +ifaceErrorTest :: TestTree +ifaceErrorTest = testWithExtraFiles "iface-error-test-1" "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", Just "GHC-38417")])] -- So what we know P has been loaded + + -- Change y from Int to B + changeDoc bdoc [ TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ + 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'", Just "GHC-83865")])] + + -- 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", Just "GHC-38417")]) + ] + changeDoc pdoc [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ 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", Just "GHC-38417")]) + ,("P.hs", [(DiagnosticSeverity_Warning,(6,0), "Top-level binding", Just "GHC-38417")]) + ] + expectNoMoreDiagnostics 2 + +ifaceErrorTest2 :: TestTree +ifaceErrorTest2 = testWithExtraFiles "iface-error-test-2" "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", Just "GHC-38417")])] -- So that we know P has been loaded + + -- Change y from Int to B + changeDoc bdoc [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ + T.unlines ["module B where", "y :: Bool", "y = undefined"]] + + -- Add a new definition to P + changeDoc pdoc [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ 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'", Just "GHC-83865")]) + ,("P.hs", [(DiagnosticSeverity_Warning, (4, 0), "Top-level binding", Just "GHC-38417")]) + ,("P.hs", [(DiagnosticSeverity_Warning, (6, 0), "Top-level binding", Just "GHC-38417")]) + ] + + expectNoMoreDiagnostics 2 + +ifaceErrorTest3 :: TestTree +ifaceErrorTest3 = testWithExtraFiles "iface-error-test-3" "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 . TextDocumentContentChangeWholeDocument $ 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'", Just "GHC-83865")]) + ,("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding", Just "GHC-38417")]) + ] + expectNoMoreDiagnostics 2 diff --git a/ghcide-test/exe/InitializeResponseTests.hs b/ghcide-test/exe/InitializeResponseTests.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/exe/InitializeResponseTests.hs @@ -0,0 +1,92 @@ + +{-# LANGUAGE DataKinds #-} + +module InitializeResponseTests (tests) where + +import Control.Monad +import Data.List.Extra +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 +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)))) + , chk " goto implementation" _implementationProvider (Just $ InR (InL (ImplementationOptions (Just False)))) + , 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 $ WorkspaceOptions + { _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 = run initializeResponse + + release :: TResponseMessage Method_Initialize -> IO () + release = mempty + diff --git a/ghcide-test/exe/LogType.hs b/ghcide-test/exe/LogType.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/exe/LogType.hs @@ -0,0 +1,21 @@ +module LogType (Log(..)) where + +import qualified Development.IDE.LSP.Notifications as Notifications +import qualified Development.IDE.Main as IDE +import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide + +import Ide.Logger (Pretty (pretty)) +import Language.LSP.VFS (VfsLog) + +data Log + = LogGhcIde Ghcide.Log + | LogIDEMain IDE.Log + | LogVfs VfsLog + | LogNotifications Notifications.Log + +instance Pretty Log where + pretty = \case + LogGhcIde log -> pretty log + LogIDEMain log -> pretty log + LogVfs log -> pretty log + LogNotifications log -> pretty log diff --git a/ghcide-test/exe/Main.hs b/ghcide-test/exe/Main.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/exe/Main.hs @@ -0,0 +1,106 @@ +-- 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 qualified HieDbRetry +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 FindImplementationAndHoverTests +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 ResolveTests +import RootUriTests +import SafeTests +import SymlinkTests +import THTests +import UnitTests +import WatchedFileTests + +main :: IO () +main = do + -- 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 + , FindImplementationAndHoverTests.tests + , PluginSimpleTests.tests + , PreprocessorTests.tests + , THTests.tests + , SymlinkTests.tests + , SafeTests.tests + , UnitTests.tests + , HaddockTests.tests + , PositionMappingTests.tests + , WatchedFileTests.tests + , CradleTests.tests + , DependentFileTest.tests + , NonLspCommandLine.tests + , IfaceTests.tests + , BootTests.tests + , RootUriTests.tests + , AsyncTests.tests + , ClientSettingsTests.tests + , ReferenceTests.tests + , ResolveTests.tests + , GarbageCollectionTests.tests + , HieDbRetry.tests + , ExceptionTests.tests + ] diff --git a/ghcide-test/exe/NonLspCommandLine.hs b/ghcide-test/exe/NonLspCommandLine.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/exe/NonLspCommandLine.hs @@ -0,0 +1,51 @@ + +module NonLspCommandLine (tests) where + +import Control.Monad ((>=>)) +import Data.Foldable (for_) +import Development.Shake (getDirectoryFilesIO) +import System.Directory (copyFile, createDirectoryIfMissing) +import System.Directory.Extra (canonicalizePath) +import System.Environment.Blank (setEnv) +import System.Exit (ExitCode (ExitSuccess)) +import System.FilePath (takeDirectory, ()) +import qualified System.IO.Extra +import System.Process.Extra (CreateProcess (cwd), proc, + readCreateProcessWithExitCode) +import Test.Tasty +import Test.Tasty.HUnit +import Config (testDataDir) + + +-- 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 + ] + +locateGhcideExecutable :: IO FilePath +locateGhcideExecutable = pure "ghcide" + +-- | 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 $ canonicalizePath >=> f + + +copyTestDataFiles :: FilePath -> FilePath -> IO () +copyTestDataFiles dir prefix = do + -- Copy all the test data files to the temporary workspace + testDataFiles <- getDirectoryFilesIO (testDataDir prefix) ["//*"] + for_ testDataFiles $ \f -> do + createDirectoryIfMissing True $ dir takeDirectory f + copyFile (testDataDir prefix f) (dir f) diff --git a/ghcide-test/exe/OpenCloseTest.hs b/ghcide-test/exe/OpenCloseTest.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/exe/OpenCloseTest.hs @@ -0,0 +1,20 @@ + +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 Config (testWithDummyPluginEmpty) +import Test.Hls (waitForProgressBegin, + waitForProgressDone) +import Test.Tasty + +tests :: TestTree +tests = testWithDummyPluginEmpty "open close" $ do + doc <- createDoc "Testing.hs" "haskell" "" + void (skipManyTill anyMessage $ message SMethod_WindowWorkDoneProgressCreate) + waitForProgressBegin + closeDoc doc + waitForProgressDone diff --git a/ghcide-test/exe/OutlineTests.hs b/ghcide-test/exe/OutlineTests.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/exe/OutlineTests.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +module OutlineTests (tests) where + +import Config +import Control.Monad.IO.Class (liftIO) +import Data.Text (Text) +import qualified Data.Text as T +import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) +import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), mkRange) +import Language.LSP.Test +import Test.Hls.FileSystem (file, text) +import Test.Tasty +import Test.Tasty.HUnit + +testSymbols :: (HasCallStack) => TestName -> FilePath -> [Text] -> [DocumentSymbol] -> TestTree +testSymbols testName path content expectedSymbols = + testCase testName $ runWithDummyPlugin (mkIdeTestFs [file path (text $ T.unlines content)]) $ do + docId <- openDoc path "haskell" + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right expectedSymbols + +testSymbolsA :: (HasCallStack) => TestName -> [Text] -> [DocumentSymbol] -> TestTree +testSymbolsA testName content expectedSymbols = + testSymbols testName "A.hs" content expectedSymbols + +tests :: TestTree +tests = + testGroup + "outline" + [ testSymbolsA + "type class:" + ["module A where", "class A a where a :: a -> Bool"] + [ moduleSymbol + "A" + (R 0 7 0 8) + [ classSymbol + "A a" + (R 1 0 1 30) + [docSymbol' "a" SymbolKind_Method (R 1 16 1 30) (R 1 16 1 17)] + ] + ], + testSymbolsA + "type class instance " + ["class A a where", "instance A () where"] + [ classSymbol "A a" (R 0 0 0 15) [], + docSymbol "A ()" SymbolKind_Interface (R 1 0 1 19) + ], + testSymbolsA "type family" ["{-# language TypeFamilies #-}", "type family A"] [docSymbolD "A" "type family" SymbolKind_Function (R 1 0 1 13)], + testSymbolsA + "type family instance " + ["{-# language TypeFamilies #-}", "type family A a", "type instance A () = ()"] + [ docSymbolD "A a" "type family" SymbolKind_Function (R 1 0 1 15), + docSymbol "A ()" SymbolKind_Interface (R 2 0 2 23) + ], + testSymbolsA "data family" ["{-# language TypeFamilies #-}", "data family A"] [docSymbolD "A" "data family" SymbolKind_Function (R 1 0 1 (if ghcVersion >= GHC910 then 13 else 11))], + testSymbolsA + "data family instance " + ["{-# language TypeFamilies #-}", "data family A a", "data instance A () = A ()"] + [ docSymbolD "A a" "data family" SymbolKind_Function (R 1 0 1 (if ghcVersion >= GHC910 then 15 else 11)), + docSymbol "A ()" SymbolKind_Interface (R 2 0 2 25) + ], + testSymbolsA "constant" ["a = ()"] [docSymbol "a" SymbolKind_Function (R 0 0 0 6)], + testSymbolsA "pattern" ["Just foo = Just 21"] [docSymbol "Just foo" SymbolKind_Function (R 0 0 0 18)], + testSymbolsA "pattern with type signature" ["{-# language ScopedTypeVariables #-}", "a :: () = ()"] [docSymbol "a :: ()" SymbolKind_Function (R 1 0 1 12)], + testSymbolsA "function" ["a _x = ()"] [docSymbol "a" SymbolKind_Function (R 0 0 0 9)], + testSymbolsA "type synonym" ["type A = Bool"] [docSymbol' "A" SymbolKind_TypeParameter (R 0 0 0 13) (R 0 5 0 6)], + testSymbolsA "datatype" ["data A = C"] [docSymbolWithChildren "A" SymbolKind_Struct (R 0 0 0 10) [docSymbol "C" SymbolKind_Constructor (R 0 9 0 10)]], + testSymbolsA + "record fields" + ["data A = B {", " x :: Int", " , y :: Int}"] + [ docSymbolWithChildren + "A" + SymbolKind_Struct + (R 0 0 2 13) + [ docSymbolWithChildren' + "B" + SymbolKind_Constructor + (R 0 9 2 13) + (R 0 9 0 10) + [ docSymbol "x" SymbolKind_Field (R 1 2 1 3), + docSymbol "y" SymbolKind_Field (R 2 4 2 5) + ] + ] + ], + testSymbolsA + "import" + ["import Data.Maybe ()"] + [ docSymbolWithChildren + "imports" + SymbolKind_Module + (R 0 0 0 20) + [ docSymbol "import Data.Maybe" SymbolKind_Module (R 0 0 0 20) + ] + ], + testSymbolsA + "multiple import" + ["", "import Data.Maybe ()", "", "import Control.Exception ()", ""] + [ docSymbolWithChildren + "imports" + SymbolKind_Module + (R 1 0 3 27) + [ docSymbol "import Data.Maybe" SymbolKind_Module (R 1 0 1 20), + docSymbol "import Control.Exception" SymbolKind_Module (R 3 0 3 27) + ] + ], + testSymbolsA + "foreign import" + [ "{-# language ForeignFunctionInterface #-}", + "foreign import ccall \"a\" a :: Int" + ] + [docSymbolD "a" "import" SymbolKind_Object (R 1 0 1 33)], + testSymbolsA + "foreign export" + [ "{-# language ForeignFunctionInterface #-}", + "foreign export ccall odd :: Int -> Bool" + ] + [docSymbolD "odd" "export" SymbolKind_Object (R 1 0 1 39)] + ] + where + docSymbol name kind loc = + DocumentSymbol name Nothing kind Nothing Nothing loc loc Nothing + docSymbol' name kind loc selectionLoc = + DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc Nothing + docSymbolD name detail kind loc = + DocumentSymbol name (Just detail) kind Nothing Nothing loc loc Nothing + docSymbolWithChildren name kind loc cc = + DocumentSymbol name Nothing kind Nothing Nothing loc loc (Just cc) + docSymbolWithChildren' name kind loc selectionLoc cc = + DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc (Just cc) + moduleSymbol name loc cc = + DocumentSymbol + name + Nothing + SymbolKind_File + Nothing + Nothing + (R 0 0 maxBound 0) + loc + (Just cc) + classSymbol name loc cc = + DocumentSymbol + name + (Just "class") + SymbolKind_Interface + Nothing + Nothing + loc + loc + (Just cc) diff --git a/ghcide-test/exe/PluginSimpleTests.hs b/ghcide-test/exe/PluginSimpleTests.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/exe/PluginSimpleTests.hs @@ -0,0 +1,46 @@ + +module PluginSimpleTests (tests) where + +import Config +import Control.Monad.IO.Class (liftIO) +import Development.IDE.Test (expectDiagnostics) +import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), mkRange) +import Language.LSP.Test +import System.FilePath +import Test.Tasty + +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. + testWithExtraFiles "simple plugin" "plugin-knownnat" $ \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", Just "GHC-88464")] + ) + ] diff --git a/ghcide-test/exe/PositionMappingTests.hs b/ghcide-test/exe/PositionMappingTests.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/exe/PositionMappingTests.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +module PositionMappingTests (tests) where + +import qualified Data.EnumMap.Strict as EM +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 + 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) + +mkChangeEvent :: Range -> Text -> TextDocumentContentChangeEvent +mkChangeEvent r t = TextDocumentContentChangeEvent $ InL + TextDocumentContentChangePartial {_range = r, _rangeLength = Nothing, _text = t} + +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 $ mkChangeEvent range replacement + newPos <- genPosition newRope + pure (range, replacement, newPos) + forAll + (suchThatMap gen + (\(range, replacement, newPos) -> positionResultToMaybe $ (range, replacement, newPos,) <$> fromCurrent range replacement newPos)) $ + \(range, replacement, newPos, oldPos) -> + toCurrent range replacement oldPos === PositionExact newPos + ] + ] + +newtype PrintableText = PrintableText { getPrintableText :: T.Text } + deriving Show + +instance Arbitrary PrintableText where + arbitrary = PrintableText . T.pack . getPrintableString <$> arbitrary + +genRope :: Gen Rope +genRope = Rope.fromText . getPrintableText <$> arbitrary + +genPosition :: Rope -> Gen Position +genPosition r = do + let rows :: Int = fromIntegral $ Rope.lengthInLines r + row <- choose (0, max 0 $ rows - 1) `suchThat` inBounds @UInt + let columns = T.length (nthLine (fromIntegral row) r) + column <- choose (0, max 0 $ columns - 1) `suchThat` inBounds @UInt + pure $ Position (fromIntegral row) (fromIntegral column) + +genRange :: Rope -> Gen Range +genRange r = do + let rows :: Int = fromIntegral $ Rope.lengthInLines r + startPos@(Position startLine startColumn) <- genPosition r + let maxLineDiff = max 0 $ rows - 1 - fromIntegral startLine + endLine <- choose (fromIntegral startLine, fromIntegral startLine + maxLineDiff) `suchThat` inBounds @UInt + let columns = T.length (nthLine (fromIntegral endLine) r) + endColumn <- + if fromIntegral startLine == endLine + then choose (fromIntegral startColumn, columns) + else choose (0, max 0 $ columns - 1) + `suchThat` inBounds @UInt + pure $ Range startPos (Position (fromIntegral endLine) (fromIntegral endColumn)) + +inBounds :: forall b a . (Integral a, Integral b, Bounded b) => a -> Bool +inBounds a = let i = toInteger a in i <= toInteger (maxBound @b) && i >= toInteger (minBound @b) + +-- | Get the ith line of a rope, starting from 0. Trailing newline not included. +nthLine :: Int -> Rope -> T.Text +nthLine i r + | Rope.null r = "" + | otherwise = Rope.lines r !! i diff --git a/ghcide-test/exe/PreprocessorTests.hs b/ghcide-test/exe/PreprocessorTests.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/exe/PreprocessorTests.hs @@ -0,0 +1,27 @@ + +module PreprocessorTests (tests) where + +import qualified Data.Text as T +import Development.IDE.Test (expectDiagnostics) +import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), mkRange) +import Language.LSP.Test +-- import Test.QuickCheck.Instances () +import Config +import Test.Tasty + +tests :: TestTree +tests = testWithDummyPluginEmpty "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", Nothing)] -- TODO: Why doesn't this work with expected code "GHC-88464"? + ) + ] diff --git a/ghcide-test/exe/Progress.hs b/ghcide-test/exe/Progress.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/exe/Progress.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE PackageImports #-} +module Progress (tests) where + +import Control.Concurrent.STM +import Data.Foldable (for_) +import qualified Data.HashMap.Strict as Map +import Development.IDE (NormalizedFilePath) +import Development.IDE.Core.ProgressReporting +import qualified "list-t" ListT +import qualified StmContainers.Map as STM +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = testGroup "Progress" + [ reportProgressTests + ] + +data InProgressModel = InProgressModel { + done, todo :: Int, + current :: Map.HashMap NormalizedFilePath Int +} + +reportProgressTests :: TestTree +reportProgressTests = testGroup "recordProgress" + [ test "addNew" addNew + , test "increase" increase + , test "decrease" decrease + , test "done" done + ] + where + p0 = pure $ InProgressModel 0 0 mempty + addNew = recordProgressModel "A" succ p0 + increase = recordProgressModel "A" succ addNew + decrease = recordProgressModel "A" succ increase + done = recordProgressModel "A" pred decrease + recordProgressModel key change state = + model state $ \st -> recordProgress st key change + model stateModelIO k = do + state <- fromModel =<< stateModelIO + _ <- k state + toModel state + test name p = testCase name $ do + InProgressModel{..} <- p + (done, todo) @?= (length (filter (==0) (Map.elems current)), Map.size current) + +fromModel :: InProgressModel -> IO InProgressState +fromModel InProgressModel{..} = do + doneVar <- newTVarIO done + todoVar <- newTVarIO todo + currentVar <- STM.newIO + atomically $ for_ (Map.toList current) $ \(k,v) -> STM.insert v k currentVar + return InProgressState{..} + +toModel :: InProgressState -> IO InProgressModel +toModel InProgressState{..} = atomically $ do + done <- readTVar doneVar + todo <- readTVar todoVar + current <- Map.fromList <$> ListT.toList (STM.listT currentVar) + return InProgressModel{..} diff --git a/ghcide-test/exe/ReferenceTests.hs b/ghcide-test/exe/ReferenceTests.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/exe/ReferenceTests.hs @@ -0,0 +1,247 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} + + +module ReferenceTests (tests) where + +import Control.Applicative.Combinators +import qualified Control.Lens as Lens +import Control.Monad +import Control.Monad.IO.Class (liftIO) +import Data.List.Extra +import qualified Data.Set as Set +import Development.IDE.Types.Location +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +import System.Directory +-- import Test.QuickCheck.Instances () +import Config +import Control.Lens ((^.)) +import qualified Data.Aeson as A +import Data.Default (def) +import Data.Tuple.Extra +import GHC.TypeLits (symbolVal) +import Ide.PluginUtils (toAbsolute) +import Ide.Types +import System.FilePath (addTrailingPathSeparator, + ()) +import Test.Hls (BrokenBehavior (..), + ExpectBroken (..), + FromServerMessage' (..), + SMethod (..), + TCustomMessage (..), + TNotificationMessage (..), + unCurrent) +import Test.Hls.FileSystem (copyDir) +import Test.Tasty +import Test.Tasty.HUnit + + +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) + ] + + -- TODO: references provider does not respect includeDeclaration parameter + , referenceTestExpectFail "works when we ask to exclude declarations" + ("References.hs", 4, 7) + NoExcludeDeclaration + (BrokenIdeal + [ ("References.hs", 6, 0) + , ("References.hs", 6, 14) + , ("References.hs", 9, 7) + , ("References.hs", 10, 11) + ] + ) + (BrokenCurrent + [ ("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 = do + testWithDummyPlugin' name (mkIdeTestFs [copyDir "references"]) $ \fs -> do + let rootDir = addTrailingPathSeparator fs + -- needed to build whole project indexing + configureCheckProject True + -- need to get the real paths through links + docs <- mapM (liftIO . canonicalizePath . (fs )) $ delete thisDoc $ nubOrd docs' + -- Initial Index + docid <- openDoc thisDoc "haskell" + + liftIO $ putStrLn $ "docs:" <> show docs + let + -- todo wait for docs + loop :: [FilePath] -> Session () + loop [] = pure () + loop docs = do + + doc <- skipManyTill anyMessage $ referenceReady (`elem` docs) + loop (delete doc docs) + loop docs + f rootDir + closeDoc docid + +-- | Given a location, lookup the symbol and all references to it. Make sure +-- they are the ones we expect. +referenceTest :: (HasCallStack) => String -> SymbolLocation -> IncludeDeclaration -> [SymbolLocation] -> TestTree +referenceTest name loc includeDeclaration expected = + referenceTestSession name (fst3 loc) docs $ \rootDir -> do + actual <- getReferences' loc includeDeclaration + liftIO $ expectSameLocations rootDir actual expected + where + docs = map fst3 expected + +referenceTestExpectFail + :: (HasCallStack) + => String + -> SymbolLocation + -> IncludeDeclaration + -> ExpectBroken 'Ideal [SymbolLocation] + -> ExpectBroken 'Current [SymbolLocation] + -> TestTree +referenceTestExpectFail name loc includeDeclaration _ = + referenceTest name loc includeDeclaration . unCurrent + +type SymbolLocation = (FilePath, UInt, UInt) + +expectSameLocations :: (HasCallStack) => FilePath -> [Location] -> [SymbolLocation] -> Assertion +expectSameLocations rootDir 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 $ toAbsolute rootDir file + return (filePathToUri fp, l, c)) + actual' @?= expected' + + +-- todo find where to put this in hls +configureCheckProject :: Bool -> Session () +configureCheckProject overrideCheckProject = setConfigSection "haskell" (A.toJSON $ def{checkProject = overrideCheckProject}) +referenceReady :: (FilePath -> Bool) -> Session FilePath +referenceReady pred = satisfyMaybe $ \case + FromServerMess (SMethod_CustomMethod p) (NotMess TNotificationMessage{_params}) + | A.Success fp <- A.fromJSON _params + , pred fp + , symbolVal p == "ghcide/reference/ready" + -> Just fp + _ -> Nothing diff --git a/ghcide-test/exe/ResolveTests.hs b/ghcide-test/exe/ResolveTests.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/exe/ResolveTests.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +module ResolveTests (tests) where + +import Config +import Control.Lens +import Data.Aeson +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Generics +import Ide.Logger +import Ide.Types (PluginDescriptor (..), PluginId, + defaultPluginDescriptor, + mkPluginHandler, + mkResolveHandler) +import qualified Language.LSP.Protocol.Lens as J +import qualified Language.LSP.Protocol.Lens as JL +import Language.LSP.Protocol.Message (SomeMethod (..)) +import qualified Language.LSP.Protocol.Message as LSP +import Language.LSP.Protocol.Types +import Language.LSP.Test hiding (resolveCompletion) +import Test.Hls (IdeState, SMethod (..), liftIO, + mkPluginTestDescriptor, + someMethodToMethodString, + waitForAllProgressDone) +import qualified Test.Hls.FileSystem as FS +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = testGroup "resolve" + [ testGroup "with and without data" resolveRequests + ] + +removeData :: JL.HasData_ s (Maybe a) => s -> s +removeData param = param & JL.data_ .~ Nothing + +simpleTestSession :: TestName -> Session () -> TestTree +simpleTestSession name act = + testCase name $ runWithResolvePlugin (mkIdeTestFs [FS.directCradle ["A.hs"]]) (const act) + +runWithResolvePlugin :: FS.VirtualFileTree -> (FilePath -> Session a) -> IO a +runWithResolvePlugin fs = + testSessionWithPlugin fs + (mkPluginTestDescriptor resolvePluginDescriptor "resolve-plugin") + +data CompletionItemResolveData = CompletionItemResolveData + { completionItemResolve_number :: Int + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (ToJSON, FromJSON) + +data CodeActionResolve = CodeActionResolve + { codeActionResolve_number :: Int + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (ToJSON, FromJSON) + +data CodeLensResolve = CodeLensResolve + { codeLensResolve_number :: Int + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (ToJSON, FromJSON) + +resolvePluginDescriptor :: Recorder (WithPriority Text) -> PluginId -> PluginDescriptor IdeState +resolvePluginDescriptor recorder pid = (defaultPluginDescriptor pid "Test Plugin for Resolve Requests") + { pluginHandlers = mconcat + [ mkResolveHandler LSP.SMethod_CompletionItemResolve $ \_ _ param _ CompletionItemResolveData{} -> pure param + , mkPluginHandler LSP.SMethod_TextDocumentCompletion $ \_ _ _ -> do + pure $ InL + [ defCompletionItem "test item without data" + , defCompletionItem "test item with data" + & J.data_ .~ Just (toJSON $ CompletionItemResolveData 100) + ] + , mkResolveHandler LSP.SMethod_CodeActionResolve $ \_ _ param _ CodeActionResolve{} -> pure param + , mkPluginHandler LSP.SMethod_TextDocumentCodeAction $ \_ _ _ -> do + logWith recorder Debug "Why is the handler not called?" + pure $ InL + [ InR $ defCodeAction "test item without data" + , InR $ defCodeAction "test item with data" + & J.data_ .~ Just (toJSON $ CodeActionResolve 70) + ] + , mkResolveHandler LSP.SMethod_CodeLensResolve $ \_ _ param _ CodeLensResolve{} -> pure param + , mkPluginHandler LSP.SMethod_TextDocumentCodeLens $ \_ _ _ -> do + pure $ InL + [ defCodeLens "test item without data" + , defCodeLens "test item with data" + & J.data_ .~ Just (toJSON $ CodeLensResolve 50) + ] + ] + } + +resolveRequests :: [TestTree] +resolveRequests = + [ simpleTestSession "completion resolve" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "data Foo = Foo { foo :: Int }" + , "bar = Foo 4" + ] + waitForAllProgressDone + items <- getCompletions doc (Position 2 7) + let resolveCompItems = filter (\i -> "test item" `T.isPrefixOf` (i ^. J.label)) items + liftIO $ assertEqual "There must be exactly two results" 2 (length resolveCompItems) + -- This must not throw an error. + _ <- traverse (resolveCompletion . removeData) resolveCompItems + pure () + , simpleTestSession "codeAction resolve" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "data Foo = Foo { foo :: Int }" + , "bar = Foo 4" + ] + waitForAllProgressDone + -- Cant use 'getAllCodeActions', as this lsp-test function queries the diagnostic + -- locations and we don't have diagnostics in these tests. + cas <- Maybe.mapMaybe (preview _R) <$> getCodeActions doc (Range (Position 0 0) (Position 1 0)) + let resolveCas = filter (\i -> "test item" `T.isPrefixOf` (i ^. J.title)) cas + liftIO $ assertEqual "There must be exactly two results" 2 (length resolveCas) + -- This must not throw an error. + _ <- traverse (resolveCodeAction . removeData) resolveCas + pure () + , simpleTestSession "codelens resolve" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "data Foo = Foo { foo :: Int }" + , "bar = Foo 4" + ] + waitForAllProgressDone + cd <- getCodeLenses doc + let resolveCodeLenses = filter (\i -> case i ^. J.command of + Just cmd -> "test item" `T.isPrefixOf` (cmd ^. J.title) + Nothing -> False + ) cd + liftIO $ assertEqual "There must be exactly two results" 2 (length resolveCodeLenses) + -- This must not throw an error. + _ <- traverse (resolveCodeLens . removeData) resolveCodeLenses + pure () + ] + +defCompletionItem :: T.Text -> CompletionItem +defCompletionItem lbl = CompletionItem + { _label = lbl + , _labelDetails = Nothing + , _kind = Nothing + , _tags = Nothing + , _detail = Nothing + , _documentation = Nothing + , _deprecated = Nothing + , _preselect = Nothing + , _sortText = Nothing + , _filterText = Nothing + , _insertText = Just "insertion" + , _insertTextFormat = Nothing + , _insertTextMode = Nothing + , _textEdit = Nothing + , _textEditText = Nothing + , _additionalTextEdits = Nothing + , _commitCharacters = Nothing + , _command = Nothing + , _data_ = Nothing + } + +defCodeAction :: T.Text -> CodeAction +defCodeAction lbl = CodeAction + { _title = lbl + , _kind = Just CodeActionKind_Refactor + , _diagnostics = Nothing + , _isPreferred = Nothing + , _disabled = Nothing + , _edit = Nothing + , _command = Just $ Command + { _title = lbl + , _command = lbl + , _arguments = Nothing + } + , _data_ = Nothing + } + +defCodeLens :: T.Text -> CodeLens +defCodeLens lbl = CodeLens + { _range = mkRange 0 0 1 0 + , _command = Just $ Command + { _title = lbl + , _command = lbl + , _arguments = Nothing + } + , _data_ = Nothing + } + +-- TODO: expose this from lsp-test +resolveCompletion :: CompletionItem -> Session CompletionItem +resolveCompletion item = do + rsp <- request SMethod_CompletionItemResolve item + case rsp ^. JL.result of + Left err -> liftIO $ assertFailure (someMethodToMethodString (SomeMethod SMethod_CompletionItemResolve) <> " failed with: " <> show err) + Right x -> pure x diff --git a/ghcide-test/exe/RootUriTests.hs b/ghcide-test/exe/RootUriTests.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/exe/RootUriTests.hs @@ -0,0 +1,39 @@ + +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 Config +import Data.Default (def) +import Test.Hls (TestConfig (..), + runSessionWithTestConfig) +import Test.Hls.FileSystem (copyDir) +import Test.Tasty +import Test.Tasty.HUnit + + +-- | 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" + 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 = runSessionWithTestConfig + def + { + testPluginDescriptor = dummyPlugin + , testDirLocation = Right $ mkIdeTestFs [copyDir "rootUri"] + , testServerRoot = Just dir1 + , testClientRoot = Just dir2 + , testShiftRoot = True + } + + diff --git a/ghcide-test/exe/SafeTests.hs b/ghcide-test/exe/SafeTests.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/exe/SafeTests.hs @@ -0,0 +1,38 @@ + +module SafeTests (tests) where + +import qualified Data.Text as T +import Development.IDE.Test (expectNoMoreDiagnostics) +import Language.LSP.Test + +import Config +import Test.Tasty + +tests :: TestTree +tests = + testGroup + "SafeHaskell" + [ -- Test for https://github.com/haskell/ghcide/issues/424 + testWithDummyPluginEmpty "load" $ do + let sourceA = + T.unlines + ["{-# LANGUAGE Trustworthy #-}" + ,"module A where" + ,"import System.IO.Unsafe" + ,"import System.IO ()" + ,"trustWorthyId :: a -> a" + ,"trustWorthyId i = unsafePerformIO $ do" + ," putStrLn \"I'm safe\"" + ," return i"] + sourceB = + T.unlines + ["{-# LANGUAGE Safe #-}" + ,"module B where" + ,"import A" + ,"safeId :: a -> a" + ,"safeId = trustWorthyId" + ] + + _ <- createDoc "A.hs" "haskell" sourceA + _ <- createDoc "B.hs" "haskell" sourceB + expectNoMoreDiagnostics 1 ] diff --git a/ghcide-test/exe/SymlinkTests.hs b/ghcide-test/exe/SymlinkTests.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/exe/SymlinkTests.hs @@ -0,0 +1,27 @@ + +module SymlinkTests (tests) where + +import Control.Monad.IO.Class (liftIO) +import Development.IDE.Test (expectDiagnosticsWithTags) +import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), mkRange) +import Language.LSP.Test +import System.Directory +import System.FilePath + +import Config +import Test.Tasty +import Test.Tasty.HUnit + +-- | 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", Nothing, Just DiagnosticTag_Unnecessary)])] + pure () + ] diff --git a/ghcide-test/exe/THTests.hs b/ghcide-test/exe/THTests.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/exe/THTests.hs @@ -0,0 +1,190 @@ + +module THTests (tests) where + +import Config +import Control.Monad.IO.Class (liftIO) +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 + +tests :: TestTree +tests = + testGroup + "TemplateHaskell" + [ -- Test for https://github.com/haskell/ghcide/pull/212 + testWithDummyPluginEmpty "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", Just "GHC-88464")] ) ] + , testWithDummyPluginEmpty "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 + , thReloadingTest True + -- Regression test for https://github.com/haskell/haskell-language-server/issues/891 + , thLinkingTest False + , thLinkingTest True + , testWithDummyPluginEmpty "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 ()", Just "GHC-38417")] ) ] + , 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", Just "GHC-38417")] ) ] + ] + + +-- | 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", Just "GHC-38417")])] + + -- Change th from () to Bool + let aSource' = T.unlines $ init (T.lines aSource) ++ ["th_a = [d| a = False|]"] + changeDoc adoc [TextDocumentContentChangeEvent . InR $ TextDocumentContentChangeWholeDocument aSource'] + -- generate an artificial warning to avoid timing out if the TH change does not propagate + changeDoc cdoc [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ 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'", Just "GHC-83865")]) + ,("THC.hs", [(DiagnosticSeverity_Warning, (6,0), "Top-level binding", Just "GHC-38417")]) + ,("THB.hs", [(DiagnosticSeverity_Warning, (4,1), "Top-level bindin", Just "GHC-38417")]) + ] + + 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", Just "GHC-38417")])] + + let aSource' = T.unlines $ init (init (T.lines aSource)) ++ ["th :: DecsQ", "th = [d| a = False|]"] + changeDoc adoc [TextDocumentContentChangeEvent . InR $ TextDocumentContentChangeWholeDocument aSource'] + + -- modify b too + let bSource' = T.unlines $ init (T.lines bSource) ++ ["$th"] + changeDoc bdoc [TextDocumentContentChangeEvent . InR $ TextDocumentContentChangeWholeDocument bSource'] + _ <- waitForDiagnostics + + expectCurrentDiagnostics bdoc [(DiagnosticSeverity_Warning, (4,1), "Top-level binding", Just "GHC-38417")] + + closeDoc adoc + closeDoc bdoc + where + name = "th-linking-test" <> if unboxed then "-unboxed" else "" + dir | unboxed = "THUnboxed" + | otherwise = "TH" diff --git a/ghcide-test/exe/UnitTests.hs b/ghcide-test/exe/UnitTests.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/exe/UnitTests.hs @@ -0,0 +1,114 @@ + +module UnitTests (tests) where + +import Config (mkIdeTestFs) +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.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) +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 Network.URI +import qualified Progress +import System.IO.Extra hiding (withTempDir) +import System.Mem (performGC) +import Test.Hls (IdeState, def, + ignoreForGhcVersions, + GhcVersion(..), + runSessionWithServerInTmpDir, + waitForProgressDone) +import Test.Tasty +import Test.Tasty.ExpectedFailure +import Test.Tasty.HUnit +import Text.Printf (printf) + +tests :: TestTree +tests = 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.FileDiagnostic "" 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 + } Diagnostics.NoStructuredMessage + 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 ::Recorder (WithPriority Ghcide.Log) -> IdePlugins IdeState + plugins recorder = pluginDescToIdePlugins $ + [ (priorityPluginDescriptor i) + { pluginNotificationHandlers = mconcat + [ mkPluginNotificationHandler SMethod_TextDocumentDidOpen $ \_ _ _ _ -> + liftIO $ atomicModifyIORef_ orderRef (i:) + ] + } + | i <- [1..20] + ] ++ Ghcide.descriptors recorder + priorityPluginDescriptor i = (defaultPluginDescriptor (fromString $ show i) ""){pluginPriority = i} + + runSessionWithServerInTmpDir def plugins (mkIdeTestFs []) $ do + _ <- createDoc "A.hs" "haskell" "module A where" + waitForProgressDone + actualOrder <- liftIO $ reverse <$> readIORef orderRef + + -- Handlers are run in priority descending order + liftIO $ actualOrder @?= [20, 19 .. 1] + , ignoreTestBecause "The test fails sometimes showing 10000us" $ + testCase "timestamps have millisecond resolution" $ do + resolution_us <- findResolution_us 1 + let msg = printf "Timestamps do not have millisecond resolution: %dus" resolution_us + assertBool msg (resolution_us <= 1000) + , Progress.tests + , FuzzySearch.tests + ] + +findResolution_us :: Int -> IO Int +findResolution_us delay_us | delay_us >= 1000000 = error "Unable to compute timestamp resolution" +findResolution_us delay_us = withTempFile $ \f -> withTempFile $ \f' -> do + performGC + writeFile f "" + threadDelay delay_us + writeFile f' "" + t <- getModTime f + t' <- getModTime f' + if t /= t' then return delay_us else findResolution_us (delay_us * 10) diff --git a/ghcide-test/exe/WatchedFileTests.hs b/ghcide-test/exe/WatchedFileTests.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/exe/WatchedFileTests.hs @@ -0,0 +1,83 @@ + +{-# LANGUAGE GADTs #-} + +module WatchedFileTests (tests) where + +import Config (testWithDummyPluginEmpty') +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 + +tests :: TestTree +tests = testGroup "watched files" + [ testGroup "Subscriptions" + [ testWithDummyPluginEmpty' "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 + + , testWithDummyPluginEmpty' "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" + [ + testWithDummyPluginEmpty' "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'", Just "GHC-83865")])] + -- 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'", Just "GHC-83865")])] + ] + ] + +getWatchedFilesSubscriptionsUntil :: forall m. SServerMethod m -> Session [DidChangeWatchedFilesRegistrationOptions] +getWatchedFilesSubscriptionsUntil m = do + msgs <- manyTill (Just <$> message SMethod_ClientRegisterCapability <|> Nothing <$ anyMessage) (message m) + return + [ x + | Just TRequestMessage{_params = RegistrationParams regs} <- msgs + , Registration _id "workspace/didChangeWatchedFiles" (Just args) <- regs + , Just x@(DidChangeWatchedFilesRegistrationOptions _) <- [A.decode . A.encode $ args] + ] diff --git a/ghcide-test/preprocessor/Main.hs b/ghcide-test/preprocessor/Main.hs new file mode 100644 --- /dev/null +++ b/ghcide-test/preprocessor/Main.hs @@ -0,0 +1,10 @@ + +module Main(main) where + +import System.Environment + +main :: IO () +main = do + _:input:output:_ <- getArgs + let f = map (\x -> if x == 'x' then 'y' else x) + writeFile output . f =<< readFile input diff --git a/ghcide/test/exe/AsyncTests.hs b/ghcide/test/exe/AsyncTests.hs deleted file mode 100644 --- a/ghcide/test/exe/AsyncTests.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# 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 Config -import Development.IDE.Plugin.Test (TestRequest (BlockSeconds), - blockCommandId) -import Test.Tasty -import Test.Tasty.HUnit - --- | Test if ghcide asynchronously handles Commands and user Requests -tests :: TestTree -tests = testGroup "async" - [ - testWithDummyPluginEmpty "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" ] - , testWithDummyPluginEmpty "request" $ do - -- Execute a custom request that will block for 1000 seconds - void $ sendRequest (SMethod_CustomMethod (Proxy @"test")) $ toJSON $ BlockSeconds 1000 - -- Load a file and check for code actions. Will only work if the request is run asynchronously - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "{-# OPTIONS -Wmissing-signatures #-}" - , "foo = id" - ] - void waitForDiagnostics - codeLenses <- getAndResolveCodeLenses doc - liftIO $ [ _title | CodeLens{_command = Just Command{_title}} <- codeLenses] @=? - [ "foo :: a -> a" ] - ] diff --git a/ghcide/test/exe/BootTests.hs b/ghcide/test/exe/BootTests.hs deleted file mode 100644 --- a/ghcide/test/exe/BootTests.hs +++ /dev/null @@ -1,56 +0,0 @@ -module BootTests (tests) where - -import Config (checkDefs, mkR, runInDir, - runWithExtraFiles) -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 - - -tests :: TestTree -tests = testGroup "boot" - [ testCase "boot-def-test" $ runWithExtraFiles "boot" $ \dir -> do - let cPath = dir "C.hs" - cSource <- liftIO $ readFileUtf8 cPath - -- Dirty the cache - liftIO $ runInDir dir $ do - cDoc <- createDoc cPath "haskell" cSource - -- We send a hover request then wait for either the hover response or - -- `ghcide/reference/ready` notification. - -- Once we receive one of the above, we wait for the other that we - -- haven't received yet. - -- If we don't wait for the `ready` notification it is possible - -- that the `getDefinitions` request/response in the outer ghcide - -- session will find no definitions. - let hoverParams = HoverParams cDoc (Position 4 3) Nothing - hoverRequestId <- sendRequest SMethod_TextDocumentHover hoverParams - let parseReadyMessage = isReferenceReady cPath - let parseHoverResponse = responseForId SMethod_TextDocumentHover hoverRequestId - hoverResponseOrReadyMessage <- skipManyTill anyMessage ((Left <$> parseHoverResponse) <|> (Right <$> parseReadyMessage)) - _ <- skipManyTill anyMessage $ - case hoverResponseOrReadyMessage of - Left _ -> void parseReadyMessage - Right _ -> void parseHoverResponse - closeDoc cDoc - cdoc <- createDoc cPath "haskell" cSource - locs <- getDefinitions cdoc (Position 7 4) - let floc = mkR 9 0 9 1 - checkDefs locs (pure [floc]) - , testCase "graph with boot modules" $ runWithExtraFiles "boot2" $ \dir -> do - _ <- openDoc (dir "A.hs") "haskell" - expectNoMoreDiagnostics 2 - ] diff --git a/ghcide/test/exe/CPPTests.hs b/ghcide/test/exe/CPPTests.hs deleted file mode 100644 --- a/ghcide/test/exe/CPPTests.hs +++ /dev/null @@ -1,56 +0,0 @@ -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 Config -import Test.Tasty -import Test.Tasty.HUnit - -tests :: TestTree -tests = - testGroup "cpp" - [ 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) - ) - , testWithDummyPluginEmpty "cpp-ghcide" $ do - _ <- createDoc "A.hs" "haskell" $ T.unlines - ["{-# LANGUAGE CPP #-}" - ,"main =" - ,"#ifdef __GHCIDE__" - ," worked" - ,"#else" - ," failed" - ,"#endif" - ] - expectDiagnostics [("A.hs", [(DiagnosticSeverity_Error, (3, 2), "Variable not in scope: worked")])] - ] - where - expectError :: T.Text -> Cursor -> Session () - expectError content cursor = do - _ <- createDoc "Testing.hs" "haskell" content - expectDiagnostics - [ ( "Testing.hs", - [(DiagnosticSeverity_Error, cursor, "error: unterminated")] - ) - ] - expectNoMoreDiagnostics 0.5 diff --git a/ghcide/test/exe/ClientSettingsTests.hs b/ghcide/test/exe/ClientSettingsTests.hs deleted file mode 100644 --- a/ghcide/test/exe/ClientSettingsTests.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE GADTs #-} -module ClientSettingsTests (tests) where - -import Config (testWithDummyPluginEmpty) -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.Hls (waitForProgressDone) -import Test.Tasty - -tests :: TestTree -tests = testGroup "client settings handling" - [ testWithDummyPluginEmpty "ghcide restarts shake session on config changes" $ do - setIgnoringLogNotifications False - void $ createDoc "A.hs" "haskell" "module A where" - waitForProgressDone - setConfigSection "haskell" $ toJSON (def :: Config) - skipManyTill anyMessage restartingBuildSession - - ] - where - restartingBuildSession :: Session () - restartingBuildSession = do - FromServerMess SMethod_WindowLogMessage TNotificationMessage{_params = LogMessageParams{..}} <- loggingNotification - guard $ "Restarting build session" `T.isInfixOf` _message diff --git a/ghcide/test/exe/CodeLensTests.hs b/ghcide/test/exe/CodeLensTests.hs deleted file mode 100644 --- a/ghcide/test/exe/CodeLensTests.hs +++ /dev/null @@ -1,119 +0,0 @@ -{-# LANGUAGE GADTs #-} - -module CodeLensTests (tests) where - -import Config -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.Hls (mkRange, waitForProgressDone) -import Test.Tasty -import Test.Tasty.HUnit - -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 = testWithDummyPluginEmpty 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" - , if ghcVersion < GHC910 - then "notInScopeTest :: String -> Data.Data.DataType" - else "notInScopeTest :: String -> GHC.Internal.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) [] - ] - , testWithDummyPluginEmpty "keep stale lens" $ do - let content = T.unlines - [ "module Stale where" - , "f = _" - ] - doc <- createDoc "Stale.hs" "haskell" content - oldLens <- getCodeLenses doc - liftIO $ length oldLens @?= 1 - let edit = TextEdit (mkRange 0 4 0 5) "" -- Remove the `_` - _ <- applyEdit doc edit - newLens <- getCodeLenses doc - liftIO $ newLens @?= oldLens - ] diff --git a/ghcide/test/exe/CompletionTests.hs b/ghcide/test/exe/CompletionTests.hs deleted file mode 100644 --- a/ghcide/test/exe/CompletionTests.hs +++ /dev/null @@ -1,582 +0,0 @@ - -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -module CompletionTests (tests) where - -import Config -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 qualified Data.Text as T -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 Test.Hls (waitForTypecheck) -import qualified Test.Hls.FileSystem as FS -import Test.Hls.FileSystem (file, text) -import Test.Hls.Util -import Test.Tasty -import Test.Tasty.HUnit - - -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 - ] - -testSessionEmpty :: TestName -> Session () -> TestTree -testSessionEmpty name = testWithDummyPlugin name (mkIdeTestFs [FS.directCradle ["A.hs"]]) - -testSessionEmptyWithCradle :: TestName -> T.Text -> Session () -> TestTree -testSessionEmptyWithCradle name cradle = testWithDummyPlugin name (mkIdeTestFs [file "hie.yaml" (text cradle)]) - -testSessionSingleFile :: TestName -> FilePath -> T.Text -> Session () -> TestTree -testSessionSingleFile testName fp txt session = - testWithDummyPlugin testName (mkIdeTestFs [FS.directCradle [T.pack fp] , file fp (text txt)]) session - -completionTest :: HasCallStack => String -> [T.Text] -> Position -> [(T.Text, CompletionItemKind, T.Text, Bool, Bool, Maybe [TextEdit])] -> TestTree -completionTest name src pos expected = testSessionSingleFile name "A.hs" (T.unlines src) $ do - docId <- openDoc "A.hs" "haskell" - _ <- waitForDiagnostics - compls <- getAndResolveCompletions docId pos - let compls' = [ (_label, _kind, _insertText, _additionalTextEdits) | CompletionItem{..} <- compls] - let emptyToMaybe x = if T.null x then Nothing else Just x - liftIO $ sortOn (Lens.view Lens._1) (take (length expected) compls') @?= - sortOn (Lens.view Lens._1) - [ (l, Just k, emptyToMaybe t, at) | (l,k,t,_,_,at) <- expected] - forM_ (zip compls expected) $ \(CompletionItem{..}, (_,_,_,expectedSig, expectedDocs, _)) -> do - when expectedSig $ - liftIO $ assertBool ("Missing type signature: " <> T.unpack _label) (isJust _detail) - when expectedDocs $ - liftIO $ assertBool ("Missing docs: " <> T.unpack _label) (isJust _documentation) - - -topLevelCompletionTests :: [TestTree] -topLevelCompletionTests = [ - completionTest - "variable" - ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"] - (Position 0 8) - [("xxx", CompletionItemKind_Function, "xxx", True, True, Nothing) - ], - completionTest - "constructor" - ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"] - (Position 0 8) - [("xxx", CompletionItemKind_Function, "xxx", True, True, Nothing) - ], - completionTest - "class method" - ["bar = xx", "class Xxx a where", "-- | haddock", "xxx :: ()", "xxx = ()"] - (Position 0 8) - [("xxx", CompletionItemKind_Function, "xxx", True, True, Nothing)], - completionTest - "type" - ["bar :: Xz", "zzz = ()", "-- | haddock", "data Xzz = XzzCon"] - (Position 0 9) - [("Xzz", CompletionItemKind_Struct, "Xzz", False, True, Nothing)], - completionTest - "class" - ["bar :: Xz", "zzz = ()", "-- | haddock", "class Xzz a"] - (Position 0 9) - [("Xzz", CompletionItemKind_Interface, "Xzz", False, True, Nothing)], - completionTest - "records" - ["data Person = Person { _personName:: String, _personAge:: Int}", "bar = Person { _pers }" ] - (Position 1 19) - [("_personName", CompletionItemKind_Function, "_personName", False, True, Nothing), - ("_personAge", CompletionItemKind_Function, "_personAge", False, True, Nothing)], - completionTest - "recordsConstructor" - ["data XxRecord = XyRecord { x:: String, y:: Int}", "bar = Xy" ] - (Position 1 19) - [("XyRecord", CompletionItemKind_Constructor, "XyRecord", False, True, Nothing), - ("XyRecord", CompletionItemKind_Snippet, "XyRecord {x=${1:_x}, y=${2:_y}}", False, True, Nothing)] - ] - -localCompletionTests :: [TestTree] -localCompletionTests = [ - completionTest - "argument" - ["bar (Just abcdef) abcdefg = abcd"] - (Position 0 32) - [("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing), - ("abcdefg", CompletionItemKind_Function , "abcdefg", True, False, Nothing) - ], - completionTest - "let" - ["bar = let (Just abcdef) = undefined" - ," abcdefg = let abcd = undefined in undefined" - ," in abcd" - ] - (Position 2 15) - [("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing), - ("abcdefg", CompletionItemKind_Function , "abcdefg", True, False, Nothing) - ], - completionTest - "where" - ["bar = abcd" - ," where (Just abcdef) = undefined" - ," abcdefg = let abcd = undefined in undefined" - ] - (Position 0 10) - [("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing), - ("abcdefg", CompletionItemKind_Function , "abcdefg", True, False, Nothing) - ], - completionTest - "do/1" - ["bar = do" - ," Just abcdef <- undefined" - ," abcd" - ," abcdefg <- undefined" - ," pure ()" - ] - (Position 2 6) - [("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing) - ], - completionTest - "do/2" - ["bar abcde = do" - ," Just [(abcdef,_)] <- undefined" - ," abcdefg <- undefined" - ," let abcdefgh = undefined" - ," (Just [abcdefghi]) = undefined" - ," abcd" - ," where" - ," abcdefghij = undefined" - ] - (Position 5 8) - [("abcde", CompletionItemKind_Function, "abcde", True, False, Nothing) - ,("abcdefghij", CompletionItemKind_Function, "abcdefghij", True, False, Nothing) - ,("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing) - ,("abcdefg", CompletionItemKind_Function, "abcdefg", True, False, Nothing) - ,("abcdefgh", CompletionItemKind_Function, "abcdefgh", True, False, Nothing) - ,("abcdefghi", CompletionItemKind_Function, "abcdefghi", True, False, Nothing) - ], - completionTest - "type family" - ["{-# LANGUAGE DataKinds, TypeFamilies #-}" - ,"type family Bar a" - ,"a :: Ba" - ] - (Position 2 7) - [("Bar", CompletionItemKind_Struct, "Bar", True, False, Nothing) - ], - completionTest - "class method" - [ - "class Test a where" - , " abcd :: a -> ()" - , " abcde :: a -> Int" - , "instance Test Int where" - , " abcd = abc" - ] - (Position 4 14) - [("abcd", CompletionItemKind_Function, "abcd", True, False, Nothing) - ,("abcde", CompletionItemKind_Function, "abcde", True, False, Nothing) - ], - testSessionEmpty "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 . TextDocumentContentChangeWholeDocument $ 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 = - [ brokenForWinOldGhc $ completionTest - "variable" - ["module A where", "f = hea"] - (Position 1 7) - [("head", CompletionItemKind_Function, "head", True, True, Nothing)], - completionTest - "constructor" - ["{-# OPTIONS_GHC -Wall #-}", "module A where", "f = True"] - (Position 2 8) - [ ("True", CompletionItemKind_Constructor, "True", True, True, Nothing) - ], - brokenForWinGhc $ completionTest - "type" - ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Boo", "f = True"] - (Position 2 8) - [ ("Bool", CompletionItemKind_Struct, "Bool", True, True, Nothing) - ], - completionTest - "qualified" - ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"] - (Position 2 15) - [ ("head", CompletionItemKind_Function, "head", True, True, Nothing) - ], - completionTest - "duplicate import" - ["module A where", "import Data.List", "import Data.List", "f = permu"] - (Position 3 9) - [ ("permutations", CompletionItemKind_Function, "permutations", False, False, Nothing) - ], - completionTest - "dont show hidden items" - [ "{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", - "import Control.Monad hiding (join)", - "f = joi" - ] - (Position 3 6) - [], - testGroup "ordering" - [completionTest "qualified has priority" - ["module A where" - ,"import qualified Data.ByteString as BS" - ,"f = BS.read" - ] - (Position 2 10) - [("readFile", CompletionItemKind_Function, "readFile", True, True, Nothing)] - ], - -- we need this test to make sure the ghcide completions module does not return completions for language pragmas. this functionality is turned on in hls - completionTest - "do not show pragma completions" - [ "{-# LANGUAGE ", - "{module A where}", - "main = return ()" - ] - (Position 0 13) - [] - ] - where - brokenForWinGhc = knownBrokenOnWindows "Windows has strange things in scope for some reason" - brokenForWinOldGhc = - knownBrokenInSpecificEnv [HostOS Windows, GhcVer GHC92] "Windows (GHC == 9.2) has strange things in scope for some reason" - . knownBrokenInSpecificEnv [HostOS Windows, GhcVer GHC94] "Windows (GHC == 9.4) has strange things in scope for some reason" - . knownBrokenInSpecificEnv [HostOS Windows, GhcVer GHC96] "Windows (GHC == 9.6) has strange things in scope for some reason" - . knownBrokenInSpecificEnv [HostOS Windows, GhcVer GHC98] "Windows (GHC == 9.8) 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)], - - testSessionEmpty "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"], - - testSessionEmpty "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 = - [ testSessionEmptyWithCradle "fromList" "cradle: {direct: {arguments: [-hide-all-packages, -package, base, A]}}" $ do - - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-binds #-}", - "module A () where", - "a = fromList" - ] - _ <- waitForDiagnostics - compls <- getCompletions doc (Position 2 12) - let compls' = - [T.drop 1 $ T.dropEnd 3 d - | CompletionItem {_documentation = Just (InR (MarkupContent MarkupKind_Markdown d)), _label} - <- compls - , _label == "fromList" - ] - liftIO $ take 3 (sort compls') @?= - map ("Defined in "<>) ( - [ "'Data.List.NonEmpty" - , "'GHC.Exts" - ] ++ (["'GHC.IsList" | ghcVersion >= GHC94])) - - , testSessionEmptyWithCradle "Map" "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, containers, A]}}" $ 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" - ] - , testSessionEmpty "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 - - , testSessionEmpty "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 = - [ testSessionEmptyWithCradle "from hiedb" "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}" $ do - _ <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A (anidentifier) where", - "anidentifier = ()" - ] - _ <- waitForDiagnostics - -- Note that B does not import A - doc <- createDoc "B.hs" "haskell" $ T.unlines - [ "module B where", - "b = anidenti" - ] - compls <- getCompletions doc (Position 1 10) - let compls' = - [T.drop 1 $ T.dropEnd 3 d - | CompletionItem {_documentation = Just (InR (MarkupContent MarkupKind_Markdown d)), _label} - <- compls - , _label == "anidentifier" - ] - liftIO $ compls' @?= ["Defined in 'A"], - testSessionEmptyWithCradle "auto complete project imports" "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"ALocalModule\", \"B\"]}}" $ do - _ <- createDoc "ALocalModule.hs" "haskell" $ T.unlines - [ "module ALocalModule (anidentifier) where", - "anidentifier = ()" - ] - _ <- waitForDiagnostics - -- Note that B does not import A - doc <- createDoc "B.hs" "haskell" $ T.unlines - [ "module B where", - "import ALocal" - ] - compls <- getCompletions doc (Position 1 13) - let item = head $ filter ((== "ALocalModule") . (^. L.label)) compls - liftIO $ do - item ^. L.label @?= "ALocalModule", - testSessionEmptyWithCradle "auto complete functions from qualified imports without alias" "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}" $ do - _ <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A (anidentifier) where", - "anidentifier = ()" - ] - _ <- waitForDiagnostics - doc <- createDoc "B.hs" "haskell" $ T.unlines - [ "module B where", - "import qualified A", - "A." - ] - compls <- getCompletions doc (Position 2 2) - let item = head compls - liftIO $ do - item ^. L.label @?= "anidentifier", - testSessionEmptyWithCradle "auto complete functions from qualified imports with alias" - "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}" $ do - _ <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A (anidentifier) where", - "anidentifier = ()" - ] - _ <- waitForDiagnostics - doc <- createDoc "B.hs" "haskell" $ T.unlines - [ "module B where", - "import qualified A as Alias", - "foo = Alias." - ] - compls <- getCompletions doc (Position 2 12) - let item = head compls - liftIO $ do - item ^. L.label @?= "anidentifier" - ] - -completionDocTests :: [TestTree] -completionDocTests = - [ testSessionEmpty "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] - , testSessionEmpty "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"] - , testSessionEmpty "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"] - , testSessionEmpty "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"] - , testSessionEmpty "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"] - , testSessionEmpty "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] - , testSessionEmpty "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] - , testSessionEmpty "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] - , testSessionEmpty "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 - test doc pos label mn expected = do - _ <- waitForDiagnostics - compls <- getCompletions doc pos - rcompls <- forM compls $ \item -> do - if isJust (item ^. L.data_) - then do - rsp <- request SMethod_CompletionItemResolve item - case rsp ^. L.result of - Left err -> liftIO $ assertFailure ("completionItem/resolve failed with: " <> show err) - Right x -> pure x - else pure item - let compls' = [ - -- We ignore doc uris since it points to the local path which determined by specific machines - case mn of - Nothing -> txt - Just n -> T.take n txt - | CompletionItem {_documentation = Just (InR (MarkupContent MarkupKind_Markdown txt)), ..} <- rcompls - , _label == label - ] - liftIO $ compls' @?= expected diff --git a/ghcide/test/exe/Config.hs b/ghcide/test/exe/Config.hs deleted file mode 100644 --- a/ghcide/test/exe/Config.hs +++ /dev/null @@ -1,162 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - -module Config( - -- * basic config for ghcIde testing - mkIdeTestFs - , dummyPlugin - - -- * runners for testing with dummy plugin - , runWithDummyPlugin - , testWithDummyPlugin - , testWithDummyPluginEmpty - , testWithDummyPlugin' - , testWithDummyPluginEmpty' - , testWithConfig - , testWithExtraFiles - , runWithExtraFiles - , runInDir - , run - - -- * utilities for testing - , Expect(..) - , pattern R - , mkR - , checkDefs - , mkL - , withLongTimeout - , lspTestCaps - , lspTestCapsNoFileWatches - ) where - -import Control.Exception (bracket_) -import Control.Lens.Setter ((.~)) -import Data.Foldable (traverse_) -import Data.Function ((&)) -import qualified Data.Text as T -import Development.IDE.Test (canonicalizeUri) -import Ide.Types (defaultPluginDescriptor) -import qualified Language.LSP.Protocol.Lens as L -import Language.LSP.Protocol.Types (Null (..)) -import System.Environment.Blank (setEnv, unsetEnv) -import System.FilePath (()) -import Test.Hls -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" - -runWithDummyPlugin :: FS.VirtualFileTree -> Session a -> IO a -runWithDummyPlugin = runSessionWithServerInTmpDir def dummyPlugin - -testWithConfig :: String -> TestConfig () -> Session () -> TestTree -testWithConfig name conf s = testCase name $ runSessionWithTestConfig conf $ const s - -runWithDummyPlugin' :: FS.VirtualFileTree -> (FilePath -> Session a) -> IO a -runWithDummyPlugin' fs = runSessionWithTestConfig def - { testPluginDescriptor = dummyPlugin - , testDirLocation = Right fs - , testConfigCaps = lspTestCaps - , testShiftRoot = True - } - -testWithDummyPlugin :: String -> FS.VirtualFileTree -> Session () -> TestTree -testWithDummyPlugin caseName vfs = testWithDummyPlugin' caseName vfs . const - -testWithDummyPlugin' :: String -> FS.VirtualFileTree -> (FilePath -> Session ()) -> TestTree -testWithDummyPlugin' caseName vfs = testCase caseName . runWithDummyPlugin' vfs - -testWithDummyPluginEmpty :: String -> Session () -> TestTree -testWithDummyPluginEmpty caseName = testWithDummyPlugin caseName $ mkIdeTestFs [] - -testWithDummyPluginEmpty' :: String -> (FilePath -> Session ()) -> TestTree -testWithDummyPluginEmpty' caseName = testWithDummyPlugin' caseName $ mkIdeTestFs [] - -runWithExtraFiles :: String -> (FilePath -> Session a) -> IO a -runWithExtraFiles dirName action = do - let vfs = mkIdeTestFs [FS.copyDir dirName] - runWithDummyPlugin' vfs action - -testWithExtraFiles :: String -> String -> (FilePath -> Session ()) -> TestTree -testWithExtraFiles testName dirName action = testCase testName $ runWithExtraFiles dirName action - -runInDir :: FilePath -> Session a -> IO a -runInDir fs = runSessionWithServer def dummyPlugin fs - -run :: Session a -> IO a -run = runSessionWithTestConfig def - { testDirLocation = Right (mkIdeTestFs []) - , testPluginDescriptor = dummyPlugin } - . const - -pattern R :: UInt -> UInt -> UInt -> UInt -> Range -pattern R x y x' y' = Range (Position x y) (Position x' y') - -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 - - -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)) = [] - -lspTestCaps :: ClientCapabilities -lspTestCaps = fullLatestClientCaps { _window = Just $ WindowClientCapabilities (Just True) Nothing Nothing } - -lspTestCapsNoFileWatches :: ClientCapabilities -lspTestCapsNoFileWatches = lspTestCaps & L.workspace . traverse . L.didChangeWatchedFiles .~ Nothing - -withLongTimeout :: IO a -> IO a -withLongTimeout = bracket_ (setEnv "LSP_TIMEOUT" "120" True) (unsetEnv "LSP_TIMEOUT") diff --git a/ghcide/test/exe/CradleTests.hs b/ghcide/test/exe/CradleTests.hs deleted file mode 100644 --- a/ghcide/test/exe/CradleTests.hs +++ /dev/null @@ -1,240 +0,0 @@ - -{-# LANGUAGE GADTs #-} - -module CradleTests (tests) where - -import Config (checkDefs, mkL, runInDir, - runWithExtraFiles, - testWithDummyPluginEmpty') -import Control.Applicative.Combinators -import Control.Lens ((^.)) -import Control.Monad.IO.Class (liftIO) -import qualified Data.Text as T -import Development.IDE.GHC.Compat (GhcVersion (..)) -import Development.IDE.GHC.Util -import Development.IDE.Plugin.Test (WaitForIdeRuleResult (..)) -import Development.IDE.Test (expectDiagnostics, - expectDiagnosticsWithTags, - expectNoMoreDiagnostics, - isReferenceReady, - waitForAction) -import Development.IDE.Types.Location -import GHC.TypeLits (symbolVal) -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.Hls (ignoreForGhcVersions) -import Test.Tasty -import Test.Tasty.HUnit - - -tests :: TestTree -tests = testGroup "cradle" - [testGroup "dependencies" [sessionDepsArePickedUp] - ,testGroup "ignore-fatal" [ignoreFatalWarning] - ,testGroup "loading" [loadCradleOnlyonce, retryFailedCradle] - ,testGroup "multi" (multiTests "multi") - ,ignoreForGhcVersions [GHC92] "multiple units not supported on 9.2" - $ testGroup "multi-unit" (multiTests "multi-unit") - ,testGroup "sub-directory" [simpleSubDirectoryTest] - ,ignoreForGhcVersions [GHC92] "multiple units not supported on 9.2" - $ testGroup "multi-unit-rexport" [multiRexportTest] - ] - -loadCradleOnlyonce :: TestTree -loadCradleOnlyonce = testGroup "load cradle only once" - [ testWithDummyPluginEmpty' "implicit" implicit - , testWithDummyPluginEmpty' "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 . TextDocumentContentChangeWholeDocument $ "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 = testWithDummyPluginEmpty' "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") $ 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 = testWithDummyPluginEmpty' - "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 TextDocumentContentChangePartial - { _range = Range (Position 4 0) (Position 4 0) - , _rangeLength = Nothing - , _text = "\n" - } - changeDoc doc [change] - -- Now no errors. - expectDiagnostics [("Foo.hs", [])] - where - fooContent = - T.unlines - [ "module Foo where", - "import Data.Text", - "foo :: Text", - "foo = \"hello\"" - ] diff --git a/ghcide/test/exe/DependentFileTest.hs b/ghcide/test/exe/DependentFileTest.hs deleted file mode 100644 --- a/ghcide/test/exe/DependentFileTest.hs +++ /dev/null @@ -1,62 +0,0 @@ - -{-# LANGUAGE GADTs #-} - -module DependentFileTest (tests) where - -import Config -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 Test.Hls - - -tests :: TestTree -tests = testGroup "addDependentFile" - [testGroup "file-changed" [testCase "test" $ runSessionWithTestConfig def - { testShiftRoot = True - , testDirLocation = Right (mkIdeTestFs []) - , testPluginDescriptor = dummyPlugin - } test] - ] - where - test :: FilePath -> Session () - test _ = do - -- If the file contains B then no type error - -- otherwise type error - let depFilePath = "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 \"" <> T.pack depFilePath <> "\"" - , " f <- qRunIO (readFile \"" <> T.pack depFilePath <> "\")" - , " if f == \"B\" then [| 1 |] else lift f)" - ] - let bazContent = T.unlines ["module Baz where", "import Foo ()"] - _fooDoc <- 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 depFilePath) FileChangeType_Changed ] - - -- Modifying Baz will now trigger Foo to be rebuilt as well - let change = TextDocumentContentChangeEvent $ InL TextDocumentContentChangePartial - { _range = Range (Position 2 0) (Position 2 6) - , _rangeLength = Nothing - , _text = "f = ()" - } - changeDoc doc [change] - expectDiagnostics [("Foo.hs", [])] diff --git a/ghcide/test/exe/DiagnosticTests.hs b/ghcide/test/exe/DiagnosticTests.hs deleted file mode 100644 --- a/ghcide/test/exe/DiagnosticTests.hs +++ /dev/null @@ -1,596 +0,0 @@ - -{-# LANGUAGE GADTs #-} - -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 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 Config -import Control.Lens ((^.)) -import Control.Monad.Extra (whenJust) -import Data.Default (def) -import Development.IDE.Plugin.Test (WaitForIdeRuleResult (..)) -import System.Time.Extra -import Test.Hls (TestConfig (testConfigCaps, testDirLocation, testDisableKick, testPluginDescriptor), - runSessionWithTestConfig, - waitForProgressBegin) -import Test.Hls.FileSystem (directCradle, file, text) -import Test.Tasty -import Test.Tasty.HUnit - -tests :: TestTree -tests = testGroup "diagnostics" - [ testWithDummyPluginEmpty "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 TextDocumentContentChangePartial - { _range = Range (Position 0 15) (Position 0 19) - , _rangeLength = Nothing - , _text = "where" - } - changeDoc doc [change] - expectDiagnostics [("Testing.hs", [])] - , testWithDummyPluginEmpty "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 TextDocumentContentChangePartial - { _range = Range (Position 0 15) (Position 0 18) - , _rangeLength = Nothing - , _text = "wher" - } - changeDoc doc [change] - expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "parse error")])] - , testWithDummyPluginEmpty "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 TextDocumentContentChangePartial - { _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'")])] - , testWithDummyPluginEmpty "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") - ] - ) - ] - , testWithDummyPluginEmpty "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'")] - ) - ] - , testWithDummyPluginEmpty "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 = testWithDummyPluginEmpty 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" - ] - - , testWithDummyPluginEmpty "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 TextDocumentContentChangePartial - { _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")])] - , testWithDummyPluginEmpty "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)" $ - runSessionWithTestConfig def - { testPluginDescriptor = dummyPlugin - , testConfigCaps = lspTestCapsNoFileWatches - , testDirLocation = Right (mkIdeTestFs []) - } - $ \tmpDir -> do - -- 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 - 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", [])] - , testWithDummyPluginEmpty "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")] - ) - ] - , let contentA = T.unlines [ "module ModuleA where" , "import ModuleB" ] - contentB = T.unlines [ "module ModuleB where" , "import ModuleA" ] - contentC = T.unlines [ "module ModuleC where" , "import ModuleB" ] - contentD = T.unlines [ "module ModuleD where" , "import ModuleC" ] - cradle = directCradle ["ModuleA", "ModuleB", "ModuleC", "ModuleD"] - in testWithDummyPlugin "deeply nested cyclic module dependency" - (mkIdeTestFs [ - file "ModuleA.hs" (text contentA) - ,file "ModuleB.hs" (text contentB) - ,file "ModuleC.hs" (text contentC) - ,cradle - ]) $ do - _ <- createDoc "ModuleD.hs" "haskell" contentD - expectDiagnostics - [ ( "ModuleB.hs" , [(DiagnosticSeverity_Error, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]) - , ( "ModuleA.hs" , [(DiagnosticSeverity_Error, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]) - ] - , testWithDummyPluginEmpty "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")])] - , testWithDummyPlugin "bidirectional module dependency with hs-boot" - (mkIdeTestFs [directCradle ["ModuleA", "ModuleB"]]) - $ do - 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" - ] - _ <- 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")])] - , testWithDummyPluginEmpty "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")])] - , testWithDummyPluginEmpty "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)] - ) - ] - , testWithDummyPluginEmpty "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")])] - , testWithDummyPluginEmpty "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") - ] - ) - ] - , testWithDummyPluginEmpty "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") - ] - ) - ] - , testWithDummyPluginEmpty "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 - , testWithDummyPluginEmpty "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 - , testWithDummyPlugin "-Werror in cradle is ignored" - (mkIdeTestFs [directCradle ["-Wall", "-Werror"]]) - $ do - 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:") - ] - ) - ] - , testWithDummyPluginEmpty "-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 . TextDocumentContentChangeWholeDocument $ - 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 . TextDocumentContentChangeWholeDocument $ - 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 - - , testWithDummyPluginEmpty "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 . TextDocumentContentChangeWholeDocument $ "module Foo() where" ] - expectDiagnostics [] - - changeDoc doc [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ 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 TextDocumentContentChangePartial - { _range = Range p p - , _rangeLength = Nothing - , _text = "fd" - } - - ,TextDocumentContentChangeEvent $ InL TextDocumentContentChangePartial - { _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 - runTestNoKick s = - runSessionWithTestConfig def - { testPluginDescriptor = dummyPlugin - , testDirLocation = Right (mkIdeTestFs []) - , testDisableKick = True - } $ const s - - typeCheck doc = do - WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc - liftIO $ assertBool "The file should typecheck" ideResultSuccess - -- wait for the debouncer to publish diagnostics if the rule runs - liftIO $ sleep 0.2 - -- flush messages to ensure current diagnostics state is updated - flushMessages diff --git a/ghcide/test/exe/ExceptionTests.hs b/ghcide/test/exe/ExceptionTests.hs deleted file mode 100644 --- a/ghcide/test/exe/ExceptionTests.hs +++ /dev/null @@ -1,140 +0,0 @@ - -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.Default (Default (..)) -import Data.Text as T -import Development.IDE.Core.Shake (IdeState (..)) -import qualified Development.IDE.LSP.Notifications as Notifications -import Development.IDE.Plugin.HLS (toResponseError) -import GHC.Base (coerce) -import Ide.Logger (Recorder, WithPriority, - cmapWithPrio) -import Ide.Plugin.Error -import Ide.Plugin.HandleRequestTypes (RejectionReason (DisabledGlobally)) -import Ide.PluginUtils (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.Hls (TestConfig (testDisableDefaultPlugin, testPluginDescriptor), - runSessionWithTestConfig, - testCheckProject, - waitForProgressDone) -import Test.Tasty -import Test.Tasty.HUnit - -tests :: TestTree -tests = do - testGroup "Exceptions and PluginError" [ - testGroup "Testing that IO Exceptions are caught in..." - [ testCase "PluginHandlers" $ do - let pluginId = "plugin-handler-exception" - plugins :: Recorder (WithPriority Log) -> IdePlugins IdeState - plugins r = pluginDescToIdePlugins $ - [ (defaultPluginDescriptor pluginId "") - { pluginHandlers = mconcat - [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do - _ <- liftIO $ throwIO DivideByZero - pure (InL []) - ] - }] ++ [Notifications.descriptor (cmapWithPrio LogNotifications r) "ghcide-core"] - runSessionWithTestConfig def {testPluginDescriptor = plugins, testDisableDefaultPlugin=True, testCheckProject=False - } $ const $ do - doc <- createDoc "A.hs" "haskell" "module A where" - (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) - case lens of - Left (TResponseError {_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 :: Recorder (WithPriority Log) -> IdePlugins IdeState - plugins r = pluginDescToIdePlugins $ - [ (defaultPluginDescriptor pluginId "") - { pluginCommands = - [ PluginCommand commandId "Causes an exception" $ \_ _ (_::Int) -> do - _ <- liftIO $ throwIO DivideByZero - pure (InR Null) - ] - }] ++ [Notifications.descriptor (cmapWithPrio LogNotifications r) "ghcide-core"] - runSessionWithTestConfig def {testPluginDescriptor = plugins, testDisableDefaultPlugin=True, testCheckProject=False} $ const $ 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 (TResponseError {_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 :: Recorder (WithPriority Log) -> IdePlugins IdeState - plugins r = pluginDescToIdePlugins $ - [ (defaultPluginDescriptor pluginId "") - { pluginNotificationHandlers = mconcat - [ mkPluginNotificationHandler SMethod_TextDocumentDidOpen $ \_ _ _ _ -> - liftIO $ throwIO DivideByZero - ] - , pluginHandlers = mconcat - [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do - pure (InL []) - ] - }] ++ [Notifications.descriptor (cmapWithPrio LogNotifications r) "ghcide-core"] - runSessionWithTestConfig def {testPluginDescriptor = plugins, testDisableDefaultPlugin=True, testCheckProject=False} $ const $ 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 "InternalError over InvalidParams" (PluginInternalError "error test") (PluginInvalidParams "error test") - , pluginOrderTestCase "InvalidParams over InvalidUserState" (PluginInvalidParams "error test") (PluginInvalidUserState "error test") - , pluginOrderTestCase "InvalidUserState over RequestRefused" (PluginInvalidUserState "error test") (PluginRequestRefused DisabledGlobally) - ] - ] - -pluginOrderTestCase :: TestName -> PluginError -> PluginError -> TestTree -pluginOrderTestCase msg err1 err2 = - testCase msg $ do - let pluginId = "error-order-test" - plugins :: Recorder (WithPriority Log) -> IdePlugins IdeState - plugins r = pluginDescToIdePlugins $ - [ (defaultPluginDescriptor pluginId "") - { pluginHandlers = mconcat - [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do - throwError err1 - ,mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do - throwError err2 - ] - }] ++ [Notifications.descriptor (cmapWithPrio LogNotifications r) "ghcide-core"] - runSessionWithTestConfig def {testPluginDescriptor = plugins, testDisableDefaultPlugin=True, testCheckProject=False} $ const $ do - doc <- createDoc "A.hs" "haskell" "module A where" - waitForProgressDone - (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) - case lens of - Left re | toResponseError (pluginId, err1) == re -> pure () - | otherwise -> liftIO $ assertFailure "We caught an error, but it wasn't ours!" - _ -> liftIO $ assertFailure $ show lens diff --git a/ghcide/test/exe/FindDefinitionAndHoverTests.hs b/ghcide/test/exe/FindDefinitionAndHoverTests.hs deleted file mode 100644 --- a/ghcide/test/exe/FindDefinitionAndHoverTests.hs +++ /dev/null @@ -1,231 +0,0 @@ -{-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} - -module FindDefinitionAndHoverTests (tests) where - -import Control.Monad -import Data.Foldable -import Data.Maybe -import qualified Data.Text as T -import qualified Language.LSP.Protocol.Lens as L -import Language.LSP.Test -import System.Info.Extra (isWindows) - -import Config -import Control.Lens ((^.)) -import Development.IDE.Test (expectDiagnostics, - standardizeQuotes) -import Test.Hls -import Test.Hls.FileSystem (copyDir) -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 = - testWithDummyPlugin title (mkIdeTestFs [copyDir "hover"]) $ do - doc <- openDoc sfp "haskell" - waitForProgressDone - _x <- waitForTypecheck doc - found <- get doc pos - check found targetRange - - - - checkHover :: (HasCallStack) => Maybe Hover -> Session [Expect] -> Session () - checkHover hover expectations = traverse_ check =<< expectations where - - check :: (HasCallStack) => Expect -> Session () - check expected = - case hover of - Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found" - Just Hover{_contents = (InL MarkupContent{_value = standardizeQuotes -> msg}) - ,_range = rangeInHover } -> - case expected of - ExpectRange expectedRange -> checkHoverRange expectedRange rangeInHover msg - ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg - ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets - ExpectHoverExcludeText snippets -> liftIO $ traverse_ (`assertNotFoundIn` msg) snippets - ExpectHoverTextRegex re -> liftIO $ assertBool ("Regex not found in " <> T.unpack msg) (msg =~ re :: Bool) - ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover - _ -> pure () -- all other expectations not relevant to hover - _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover - - extractLineColFromHoverMsg :: T.Text -> [T.Text] - extractLineColFromHoverMsg = T.splitOn ":" . head . T.splitOn "*" . last . T.splitOn (sourceFileName <> ":") - - checkHoverRange :: Range -> Maybe Range -> T.Text -> Session () - checkHoverRange expectedRange rangeInHover msg = - let - lineCol = extractLineColFromHoverMsg msg - -- looks like hovers use 1-based numbering while definitions use 0-based - -- turns out that they are stored 1-based in RealSrcLoc by GHC itself. - adjust Position{_line = l, _character = c} = - Position{_line = l + 1, _character = c + 1} - in - case map (read . T.unpack) lineCol of - [l,c] -> liftIO $ adjust (expectedRange ^. L.start) @=? Position l c - _ -> liftIO $ assertFailure $ - "expected: " <> show ("[...]" <> sourceFileName <> "::**[...]", Just expectedRange) <> - "\n but got: " <> show (msg, rangeInHover) - - assertFoundIn :: T.Text -> T.Text -> Assertion - assertFoundIn part whole = assertBool - (T.unpack $ "failed to find: `" <> part <> "` in hover message:\n" <> whole) - (part `T.isInfixOf` whole) - - assertNotFoundIn :: T.Text -> T.Text -> Assertion - assertNotFoundIn part whole = assertBool - (T.unpack $ "found unexpected: `" <> part <> "` in hover message:\n" <> whole) - (not . T.isInfixOf part $ whole) - - sourceFilePath = T.unpack sourceFileName - sourceFileName = "GotoHover.hs" - - mkFindTests tests = testGroup "get" - [ testGroup "definition" $ mapMaybe fst tests - , testGroup "hover" $ mapMaybe snd tests - , testGroup "hover compile" [checkFileCompiles sourceFilePath $ - expectDiagnostics - [ ( "GotoHover.hs", [(DiagnosticSeverity_Error, (62, 7), "Found hole: _")]) - , ( "GotoHover.hs", [(DiagnosticSeverity_Error, (65, 8), "Found hole: _")]) - ]] - , testGroup "type-definition" typeDefinitionTests - , testGroup "hover-record-dot-syntax" recordDotSyntaxTests ] - - typeDefinitionTests = [ tst (getTypeDefinitions, checkDefs) aaaL14 sourceFilePath (pure tcData) "Saturated data con" - , tst (getTypeDefinitions, checkDefs) aL20 sourceFilePath (pure [ExpectNoDefinitions]) "Polymorphic variable"] - - recordDotSyntaxTests = - [ tst (getHover, checkHover) (Position 17 24) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["x :: MyRecord"]]) "hover over parent" - , tst (getHover, checkHover) (Position 17 25) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over dot shows child" - , tst (getHover, checkHover) (Position 17 26) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over child" - ] - - test :: (HasCallStack) => (TestTree -> a) -> (TestTree -> b) -> Position -> [Expect] -> String -> (a, b) - test runDef runHover look expect = testM runDef runHover look (return expect) - - testM :: (HasCallStack) => (TestTree -> a) - -> (TestTree -> b) - -> Position - -> Session [Expect] - -> String - -> (a, b) - testM runDef runHover look expect title = - ( runDef $ tst def look sourceFilePath expect title - , runHover $ tst hover look sourceFilePath expect title ) where - def = (getDefinitions, checkDefs) - hover = (getHover , checkHover) - - -- search locations expectations on results - fffL4 = fffR ^. L.start; fffR = mkRange 8 4 8 7 ; fff = [ExpectRange fffR] - fffL8 = Position 12 4 ; - fffL14 = Position 18 7 ; - aL20 = Position 19 15 - aaaL14 = Position 18 20 ; aaa = [mkR 11 0 11 3] - dcL7 = Position 11 11 ; tcDC = [mkR 7 23 9 16] - dcL12 = Position 16 11 ; - xtcL5 = Position 9 11 ; xtc = [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 = [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 = [ExpectHoverText ["Num", "Defined in ", if ghcVersion < GHC910 then "GHC.Num" else "GHC.Internal.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"], if ghcVersion >= GHC94 && ghcVersion < GHC910 then mkL bar 3 5 3 8 else mkL bar 3 0 3 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 yes yes xtcL5 xtc "type constructor external #717,1028" - , test yes 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 yes 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 - -xfail :: TestTree -> String -> TestTree -xfail = flip expectFailBecause - -checkFileCompiles :: FilePath -> Session () -> TestTree -checkFileCompiles fp diag = - testWithDummyPlugin ("hover: Does " ++ fp ++ " compile") (mkIdeTestFs [copyDir "hover"]) $ do - _ <- openDoc fp "haskell" - diag diff --git a/ghcide/test/exe/FuzzySearch.hs b/ghcide/test/exe/FuzzySearch.hs deleted file mode 100644 --- a/ghcide/test/exe/FuzzySearch.hs +++ /dev/null @@ -1,129 +0,0 @@ -module FuzzySearch (tests) where - -import Data.Char (toLower) -import Data.Maybe (catMaybes) -import qualified Data.Monoid.Textual as T -import Data.Text (Text, inits, pack) -import qualified Data.Text as Text -import Prelude hiding (filter) -import System.Directory (doesFileExist) -import System.IO.Unsafe (unsafePerformIO) -import Test.QuickCheck -import Test.Tasty -import Test.Tasty.ExpectedFailure -import Test.Tasty.QuickCheck (testProperty) -import qualified Text.Fuzzy as Fuzzy -import Text.Fuzzy (Fuzzy (..)) -import Text.Fuzzy.Parallel - -tests :: TestTree -tests = - testGroup - "Fuzzy search" - [ needDictionary $ - testGroup - "match works as expected on the english dictionary" - [ testProperty "for legit words" propLegit, - testProperty "for prefixes" propPrefix, - testProperty "for typos" propTypo - ] - ] - -test :: Text -> Bool -test candidate = do - let previous = - catMaybes - [ (d,) . Fuzzy.score - <$> referenceImplementation candidate d "" "" id - | d <- dictionary - ] - new = catMaybes [(d,) <$> match candidate d | d <- dictionary] - previous == new - -propLegit :: Property -propLegit = forAll (elements dictionary) test - -propPrefix :: Property -propPrefix = forAll (elements dictionary >>= elements . inits) test - -propTypo :: Property -propTypo = forAll typoGen test - -typoGen :: Gen Text -typoGen = do - w <- elements dictionary - l <- elements [0 .. Text.length w -1] - let wl = Text.index w l - c <- elements [ c | c <- ['a' .. 'z'], c /= wl] - return $ replaceAt w l c - -replaceAt :: Text -> Int -> Char -> Text -replaceAt t i c = - let (l, r) = Text.splitAt i t - in l <> Text.singleton c <> r - -dictionaryPath :: FilePath -dictionaryPath = "/usr/share/dict/words" - -{-# NOINLINE dictionary #-} -dictionary :: [Text] -dictionary = unsafePerformIO $ do - existsDictionary <- doesFileExist dictionaryPath - if existsDictionary - then map pack . words <$> readFile dictionaryPath - else pure [] - -referenceImplementation :: - (T.TextualMonoid s) => - -- | Pattern in lowercase except for first character - s -> - -- | The value containing the text to search in. - t -> - -- | The text to add before each match. - s -> - -- | The text to add after each match. - s -> - -- | The function to extract the text from the container. - (t -> s) -> - -- | The original value, rendered string and score. - Maybe (Fuzzy t s) -referenceImplementation pattern t pre post extract = - if null pat then Just (Fuzzy t result totalScore) else Nothing - where - null :: (T.TextualMonoid s) => s -> Bool - null = not . T.any (const True) - - s = extract t - (totalScore, _currScore, result, pat, _) = - T.foldl' - undefined - ( \(tot, cur, res, pat, isFirst) c -> - case T.splitCharacterPrefix pat of - Nothing -> (tot, 0, res <> T.singleton c, pat, isFirst) - Just (x, xs) -> - -- the case of the first character has to match - -- otherwise use lower case since the pattern is assumed lower - let !c' = if isFirst then c else toLower c - in if x == c' - then - let cur' = cur * 2 + 1 - in ( tot + cur', - cur', - res <> pre <> T.singleton c <> post, - xs, - False - ) - else (tot, 0, res <> T.singleton c, pat, isFirst) - ) - ( 0, - 1, -- matching at the start gives a bonus (cur = 1) - mempty, - pattern, - True - ) - s - -needDictionary :: TestTree -> TestTree -needDictionary - | null dictionary = ignoreTestBecause ("not found: " <> dictionaryPath) - | otherwise = id diff --git a/ghcide/test/exe/GarbageCollectionTests.hs b/ghcide/test/exe/GarbageCollectionTests.hs deleted file mode 100644 --- a/ghcide/test/exe/GarbageCollectionTests.hs +++ /dev/null @@ -1,89 +0,0 @@ -module GarbageCollectionTests (tests) where - -import Config (testWithDummyPluginEmpty') -import Control.Monad.IO.Class (liftIO) -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.Tasty -import Test.Tasty.HUnit -import Text.Printf (printf) - -tests :: TestTree -tests = testGroup "garbage collection" - [ testGroup "dirty keys" - [ testWithDummyPluginEmpty' "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 - - , testWithDummyPluginEmpty' "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) - - , testWithDummyPluginEmpty' "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 - - , testWithDummyPluginEmpty' "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 $ TextDocumentContentChangeWholeDocument edit] - builds <- waitForTypecheck doc - liftIO $ assertBool "it still builds" builds - expectCurrentDiagnostics doc [(DiagnosticSeverity_Error, (2,4), "Couldn't match expected type")] - ] - ] - where - isExpected k = "GhcSessionIO" `T.isPrefixOf` k - - generateGarbage :: String -> FilePath -> Session TextDocumentIdentifier - generateGarbage modName dir = do - let fp = modName <> ".hs" - body = printf "module %s where" modName - doc <- createDoc fp "haskell" (T.pack body) - liftIO $ writeFile (dir fp) body - builds <- waitForTypecheck doc - liftIO $ assertBool "something is wrong with this test" builds - return doc diff --git a/ghcide/test/exe/HaddockTests.hs b/ghcide/test/exe/HaddockTests.hs deleted file mode 100644 --- a/ghcide/test/exe/HaddockTests.hs +++ /dev/null @@ -1,90 +0,0 @@ - -module HaddockTests (tests) where - -import Development.IDE.Spans.Common --- import Test.QuickCheck.Instances () -import Test.Tasty -import Test.Tasty.HUnit - -tests :: TestTree -tests - = testGroup "haddock" - [ testCase "Num" $ checkHaddock - (unlines - [ "However, '(+)' and '(*)' are" - , "customarily expected to define a ring and have the following properties:" - , "" - , "[__Associativity of (+)__]: @(x + y) + z@ = @x + (y + z)@" - , "[__Commutativity of (+)__]: @x + y@ = @y + x@" - , "[__@fromInteger 0@ is the additive identity__]: @x + fromInteger 0@ = @x@" - ] - ) - (unlines - [ "" - , "" - , "However, `(+)` and `(*)` are" - , "customarily expected to define a ring and have the following properties: " - , "+ ****Associativity of (+)****: `(x + y) + z` = `x + (y + z)`" - , "+ ****Commutativity of (+)****: `x + y` = `y + x`" - , "+ ****`fromInteger 0` is the additive identity****: `x + fromInteger 0` = `x`" - ] - ) - , testCase "unsafePerformIO" $ checkHaddock - (unlines - [ "may require" - , "different precautions:" - , "" - , " * Use @{\\-\\# NOINLINE foo \\#-\\}@ as a pragma on any function @foo@" - , " that calls 'unsafePerformIO'. If the call is inlined," - , " the I\\/O may be performed more than once." - , "" - , " * Use the compiler flag @-fno-cse@ to prevent common sub-expression" - , " elimination being performed on the module." - , "" - ] - ) - (unlines - [ "" - , "" - , "may require" - , "different precautions: " - , "+ Use `{-# NOINLINE foo #-}` as a pragma on any function `foo` " - , " that calls `unsafePerformIO` . If the call is inlined," - , " the I/O may be performed more than once." - , "" - , "+ Use the compiler flag `-fno-cse` to prevent common sub-expression" - , " elimination being performed on the module." - , "" - ] - ) - , testCase "ordered list" $ checkHaddock - (unlines - [ "may require" - , "different precautions:" - , "" - , " 1. Use @{\\-\\# NOINLINE foo \\#-\\}@ as a pragma on any function @foo@" - , " that calls 'unsafePerformIO'. If the call is inlined," - , " the I\\/O may be performed more than once." - , "" - , " 2. Use the compiler flag @-fno-cse@ to prevent common sub-expression" - , " elimination being performed on the module." - , "" - ] - ) - (unlines - [ "" - , "" - , "may require" - , "different precautions: " - , "1. Use `{-# NOINLINE foo #-}` as a pragma on any function `foo` " - , " that calls `unsafePerformIO` . If the call is inlined," - , " the I/O may be performed more than once." - , "" - , "2. Use the compiler flag `-fno-cse` to prevent common sub-expression" - , " elimination being performed on the module." - , "" - ] - ) - ] - where - checkHaddock s txt = spanDocToMarkdownForTest s @?= txt diff --git a/ghcide/test/exe/HieDbRetry.hs b/ghcide/test/exe/HieDbRetry.hs deleted file mode 100644 --- a/ghcide/test/exe/HieDbRetry.hs +++ /dev/null @@ -1,136 +0,0 @@ -{-# LANGUAGE MultiWayIf #-} -module HieDbRetry (tests) where - -import Control.Concurrent.Extra (Var, modifyVar, newVar, readVar, - withVar) -import Control.Exception (ErrorCall (ErrorCall), evaluate, - throwIO, tryJust) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Data.Tuple.Extra (dupe) -import qualified Database.SQLite.Simple as SQLite -import Development.IDE.Session (retryOnException, retryOnSqliteBusy) -import qualified Development.IDE.Session as Session -import Ide.Logger (Recorder (Recorder, logger_), - WithPriority (WithPriority, payload), - cmapWithPrio) -import qualified System.Random as Random -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) - -data Log - = LogSession Session.Log - deriving Show - -makeLogger :: Var [Log] -> Recorder (WithPriority Log) -makeLogger msgsVar = - Recorder { - logger_ = \WithPriority{ payload = msg } -> liftIO $ modifyVar msgsVar (\msgs -> pure (msg : msgs, ())) - } - -rng :: Random.StdGen -rng = Random.mkStdGen 0 - -retryOnSqliteBusyForTest :: Recorder (WithPriority Log) -> Int -> IO a -> IO a -retryOnSqliteBusyForTest recorder maxRetryCount = retryOnException isErrorBusy (cmapWithPrio LogSession recorder) 1 1 maxRetryCount rng - -isErrorBusy :: SQLite.SQLError -> Maybe SQLite.SQLError -isErrorBusy e - | SQLite.SQLError { sqlError = SQLite.ErrorBusy } <- e = Just e - | otherwise = Nothing - -errorBusy :: SQLite.SQLError -errorBusy = SQLite.SQLError{ sqlError = SQLite.ErrorBusy, sqlErrorDetails = "", sqlErrorContext = "" } - -isErrorCall :: ErrorCall -> Maybe ErrorCall -isErrorCall e - | ErrorCall _ <- e = Just e - -tests :: TestTree -tests = testGroup "RetryHieDb" - [ testCase "retryOnException throws exception after max retries" $ do - logMsgsVar <- newVar [] - let logger = makeLogger logMsgsVar - let maxRetryCount = 1 - - result <- tryJust isErrorBusy (retryOnSqliteBusyForTest logger maxRetryCount (throwIO errorBusy)) - - case result of - Left exception -> do - exception @?= errorBusy - withVar logMsgsVar $ \logMsgs -> - length logMsgs @?= 2 - -- uncomment if want to compare log msgs - -- logMsgs @?= [] - Right _ -> assertFailure "Expected ErrorBusy exception" - - , testCase "retryOnException doesn't throw if given function doesn't throw" $ do - let expected = 1 :: Int - let maxRetryCount = 0 - - actual <- retryOnSqliteBusyForTest mempty maxRetryCount (pure expected) - - actual @?= expected - - , testCase "retryOnException retries the number of times it should" $ do - countVar <- newVar 0 - let maxRetryCount = 3 - let incrementThenThrow = modifyVar countVar (\count -> pure (dupe (count + 1))) >> throwIO errorBusy - - _ <- tryJust isErrorBusy (retryOnSqliteBusyForTest mempty maxRetryCount incrementThenThrow) - - withVar countVar $ \count -> - count @?= maxRetryCount + 1 - - , testCase "retryOnException doesn't retry if exception is not ErrorBusy" $ do - countVar <- newVar (0 :: Int) - let maxRetryCount = 1 - - let throwThenIncrement = do - count <- readVar countVar - if count == 0 then - evaluate (error "dummy exception") - else - modifyVar countVar (\count -> pure (dupe (count + 1))) - - - _ <- tryJust isErrorCall (retryOnSqliteBusyForTest mempty maxRetryCount throwThenIncrement) - - withVar countVar $ \count -> - count @?= 0 - - , testCase "retryOnSqliteBusy retries on ErrorBusy" $ do - countVar <- newVar (0 :: Int) - - let incrementThenThrowThenIncrement = do - count <- readVar countVar - if count == 0 then - modifyVar countVar (\count -> pure (dupe (count + 1))) >> throwIO errorBusy - else - modifyVar countVar (\count -> pure (dupe (count + 1))) - - _ <- retryOnSqliteBusy mempty rng incrementThenThrowThenIncrement - - withVar countVar $ \count -> - count @?= 2 - - , testCase "retryOnException exponentially backs off" $ do - logMsgsVar <- newVar ([] :: [Log]) - - let maxDelay = 100 - let baseDelay = 1 - let maxRetryCount = 6 - let logger = makeLogger logMsgsVar - - result <- tryJust isErrorBusy (retryOnException isErrorBusy (cmapWithPrio LogSession logger) maxDelay baseDelay maxRetryCount rng (throwIO errorBusy)) - - case result of - Left _ -> do - withVar logMsgsVar $ \logMsgs -> - -- uses log messages to check backoff... - if | (LogSession (Session.LogHieDbRetriesExhausted baseDelay maximumDelay maxRetryCount _) : _) <- logMsgs -> do - baseDelay @?= 64 - maximumDelay @?= 100 - maxRetryCount @?= 0 - | otherwise -> assertFailure "Expected more than 0 log messages" - Right _ -> assertFailure "Expected ErrorBusy exception" - ] diff --git a/ghcide/test/exe/HighlightTests.hs b/ghcide/test/exe/HighlightTests.hs deleted file mode 100644 --- a/ghcide/test/exe/HighlightTests.hs +++ /dev/null @@ -1,78 +0,0 @@ - -module HighlightTests (tests) where - -import Config -import Control.Monad.IO.Class (liftIO) -import qualified Data.Text as T -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 - -tests :: TestTree -tests = testGroup "highlight" - [ testWithDummyPluginEmpty "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) - ] - , testWithDummyPluginEmpty "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) - ] - , testWithDummyPluginEmpty "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) - ] - , - testWithDummyPluginEmpty "record" $ do - doc <- createDoc "A.hs" "haskell" recsource - _ <- waitForDiagnostics - highlights <- getHighlights doc (Position 4 15) - liftIO $ highlights @?= - [ DocumentHighlight (R 4 8 4 10) (Just DocumentHighlightKind_Write) - , DocumentHighlight (R 4 14 4 20) (Just DocumentHighlightKind_Read) - ] - highlights <- getHighlights doc (Position 3 17) - liftIO $ highlights @?= - [ DocumentHighlight (R 3 17 3 23) (Just DocumentHighlightKind_Write) - , DocumentHighlight (R 4 8 4 10) (Just DocumentHighlightKind_Read) - ] - ] - where - source = T.unlines - ["{-# OPTIONS_GHC -Wunused-binds #-}" - ,"module Highlight () where" - ,"foo :: Int" - ,"foo = 3 :: Int" - ,"bar = foo" - ," where baz = let x = foo in x" - ,"baz arg = arg + x" - ," where x = arg" - ] - recsource = T.unlines - ["{-# LANGUAGE RecordWildCards #-}" - ,"{-# OPTIONS_GHC -Wunused-binds #-}" - ,"module Highlight () where" - ,"data Rec = Rec { field1 :: Int, field2 :: Char }" - ,"foo Rec{..} = field2 + field1" - ] diff --git a/ghcide/test/exe/IfaceTests.hs b/ghcide/test/exe/IfaceTests.hs deleted file mode 100644 --- a/ghcide/test/exe/IfaceTests.hs +++ /dev/null @@ -1,162 +0,0 @@ -module IfaceTests (tests) where - -import Config -import Control.Monad.IO.Class (liftIO) -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 - -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 = testWithExtraFiles "iface-th-test" "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 $ TextDocumentContentChangeWholeDocument 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 = testWithExtraFiles "iface-error-test-1" "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 . TextDocumentContentChangeWholeDocument $ - 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 . TextDocumentContentChangeWholeDocument $ 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 = testWithExtraFiles "iface-error-test-2" "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 . TextDocumentContentChangeWholeDocument $ - T.unlines ["module B where", "y :: Bool", "y = undefined"]] - - -- Add a new definition to P - changeDoc pdoc [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ 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 = testWithExtraFiles "iface-error-test-3" "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 . TextDocumentContentChangeWholeDocument $ T.unlines ["module B where", "y :: Bool", "y = undefined"]] - - -- P should not typecheck, as there are no last valid artifacts for A - _pdoc <- createDoc pPath "haskell" pSource - - -- In this example the interface file for A should not exist (modulo the cache folder) - -- Despite that P still type checks, as we can generate an interface file for A thanks to -fdeferred-type-errors - expectDiagnostics - [("A.hs", [(DiagnosticSeverity_Error, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")]) - ,("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")]) - ] - expectNoMoreDiagnostics 2 diff --git a/ghcide/test/exe/InitializeResponseTests.hs b/ghcide/test/exe/InitializeResponseTests.hs deleted file mode 100644 --- a/ghcide/test/exe/InitializeResponseTests.hs +++ /dev/null @@ -1,94 +0,0 @@ - -{-# LANGUAGE DataKinds #-} - -module InitializeResponseTests (tests) where - -import Control.Monad -import Data.List.Extra -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 -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 $ WorkspaceOptions - { _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 = run initializeResponse - - release :: TResponseMessage Method_Initialize -> IO () - release = mempty - diff --git a/ghcide/test/exe/LogType.hs b/ghcide/test/exe/LogType.hs deleted file mode 100644 --- a/ghcide/test/exe/LogType.hs +++ /dev/null @@ -1,21 +0,0 @@ -module LogType (Log(..)) where - -import qualified Development.IDE.LSP.Notifications as Notifications -import qualified Development.IDE.Main as IDE -import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide - -import Ide.Logger (Pretty (pretty)) -import Language.LSP.VFS (VfsLog) - -data Log - = LogGhcIde Ghcide.Log - | LogIDEMain IDE.Log - | LogVfs VfsLog - | LogNotifications Notifications.Log - -instance Pretty Log where - pretty = \case - LogGhcIde log -> pretty log - LogIDEMain log -> pretty log - LogVfs log -> pretty log - LogNotifications log -> pretty log diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs deleted file mode 100644 --- a/ghcide/test/exe/Main.hs +++ /dev/null @@ -1,102 +0,0 @@ --- 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 qualified HieDbRetry -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 - -- 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 - , 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 - ] diff --git a/ghcide/test/exe/NonLspCommandLine.hs b/ghcide/test/exe/NonLspCommandLine.hs deleted file mode 100644 --- a/ghcide/test/exe/NonLspCommandLine.hs +++ /dev/null @@ -1,50 +0,0 @@ - -module NonLspCommandLine (tests) where - -import Control.Monad ((>=>)) -import Data.Foldable (for_) -import Development.Shake (getDirectoryFilesIO) -import System.Directory (copyFile, createDirectoryIfMissing) -import System.Directory.Extra (canonicalizePath) -import System.Environment.Blank (setEnv) -import System.Exit (ExitCode (ExitSuccess)) -import System.FilePath (takeDirectory, ()) -import qualified System.IO.Extra -import System.Process.Extra (CreateProcess (cwd), proc, - readCreateProcessWithExitCode) -import Test.Tasty -import Test.Tasty.HUnit - - --- 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 - ] - -locateGhcideExecutable :: IO FilePath -locateGhcideExecutable = pure "ghcide" - --- | 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 $ canonicalizePath >=> f - - -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) diff --git a/ghcide/test/exe/OpenCloseTest.hs b/ghcide/test/exe/OpenCloseTest.hs deleted file mode 100644 --- a/ghcide/test/exe/OpenCloseTest.hs +++ /dev/null @@ -1,20 +0,0 @@ - -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 Config (testWithDummyPluginEmpty) -import Test.Hls (waitForProgressBegin, - waitForProgressDone) -import Test.Tasty - -tests :: TestTree -tests = testWithDummyPluginEmpty "open close" $ do - doc <- createDoc "Testing.hs" "haskell" "" - void (skipManyTill anyMessage $ message SMethod_WindowWorkDoneProgressCreate) - waitForProgressBegin - closeDoc doc - waitForProgressDone diff --git a/ghcide/test/exe/OutlineTests.hs b/ghcide/test/exe/OutlineTests.hs deleted file mode 100644 --- a/ghcide/test/exe/OutlineTests.hs +++ /dev/null @@ -1,153 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} - -module OutlineTests (tests) where - -import Config -import Control.Monad.IO.Class (liftIO) -import Data.Text (Text) -import qualified Data.Text as T -import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) -import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..), - SemanticTokenRelative (..), - SemanticTokensEdit (..), mkRange) -import Language.LSP.Test -import Test.Hls.FileSystem (file, text) -import Test.Tasty -import Test.Tasty.HUnit - -testSymbols :: (HasCallStack) => TestName -> FilePath -> [Text] -> [DocumentSymbol] -> TestTree -testSymbols testName path content expectedSymbols = - testCase testName $ runWithDummyPlugin (mkIdeTestFs [file path (text $ T.unlines content)]) $ do - docId <- openDoc path "haskell" - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right expectedSymbols - -testSymbolsA :: (HasCallStack) => TestName -> [Text] -> [DocumentSymbol] -> TestTree -testSymbolsA testName content expectedSymbols = - testSymbols testName "A.hs" content expectedSymbols - -tests :: TestTree -tests = - testGroup - "outline" - [ testSymbolsA - "type class:" - ["module A where", "class A a where a :: a -> Bool"] - [ moduleSymbol - "A" - (R 0 7 0 8) - [ classSymbol - "A a" - (R 1 0 1 30) - [docSymbol' "a" SymbolKind_Method (R 1 16 1 30) (R 1 16 1 17)] - ] - ], - testSymbolsA - "type class instance " - ["class A a where", "instance A () where"] - [ classSymbol "A a" (R 0 0 0 15) [], - docSymbol "A ()" SymbolKind_Interface (R 1 0 1 19) - ], - testSymbolsA "type family" ["{-# language TypeFamilies #-}", "type family A"] [docSymbolD "A" "type family" SymbolKind_Function (R 1 0 1 13)], - testSymbolsA - "type family instance " - ["{-# language TypeFamilies #-}", "type family A a", "type instance A () = ()"] - [ docSymbolD "A a" "type family" SymbolKind_Function (R 1 0 1 15), - docSymbol "A ()" SymbolKind_Interface (R 2 0 2 23) - ], - testSymbolsA "data family" ["{-# language TypeFamilies #-}", "data family A"] [docSymbolD "A" "data family" SymbolKind_Function (R 1 0 1 (if ghcVersion >= GHC910 then 13 else 11))], - testSymbolsA - "data family instance " - ["{-# language TypeFamilies #-}", "data family A a", "data instance A () = A ()"] - [ docSymbolD "A a" "data family" SymbolKind_Function (R 1 0 1 (if ghcVersion >= GHC910 then 15 else 11)), - docSymbol "A ()" SymbolKind_Interface (R 2 0 2 25) - ], - testSymbolsA "constant" ["a = ()"] [docSymbol "a" SymbolKind_Function (R 0 0 0 6)], - testSymbolsA "pattern" ["Just foo = Just 21"] [docSymbol "Just foo" SymbolKind_Function (R 0 0 0 18)], - testSymbolsA "pattern with type signature" ["{-# language ScopedTypeVariables #-}", "a :: () = ()"] [docSymbol "a :: ()" SymbolKind_Function (R 1 0 1 12)], - testSymbolsA "function" ["a _x = ()"] [docSymbol "a" SymbolKind_Function (R 0 0 0 9)], - testSymbolsA "type synonym" ["type A = Bool"] [docSymbol' "A" SymbolKind_TypeParameter (R 0 0 0 13) (R 0 5 0 6)], - testSymbolsA "datatype" ["data A = C"] [docSymbolWithChildren "A" SymbolKind_Struct (R 0 0 0 10) [docSymbol "C" SymbolKind_Constructor (R 0 9 0 10)]], - testSymbolsA - "record fields" - ["data A = B {", " x :: Int", " , y :: Int}"] - [ docSymbolWithChildren - "A" - SymbolKind_Struct - (R 0 0 2 13) - [ docSymbolWithChildren' - "B" - SymbolKind_Constructor - (R 0 9 2 13) - (R 0 9 0 10) - [ docSymbol "x" SymbolKind_Field (R 1 2 1 3), - docSymbol "y" SymbolKind_Field (R 2 4 2 5) - ] - ] - ], - testSymbolsA - "import" - ["import Data.Maybe ()"] - [ docSymbolWithChildren - "imports" - SymbolKind_Module - (R 0 0 0 20) - [ docSymbol "import Data.Maybe" SymbolKind_Module (R 0 0 0 20) - ] - ], - testSymbolsA - "multiple import" - ["", "import Data.Maybe ()", "", "import Control.Exception ()", ""] - [ docSymbolWithChildren - "imports" - SymbolKind_Module - (R 1 0 3 27) - [ docSymbol "import Data.Maybe" SymbolKind_Module (R 1 0 1 20), - docSymbol "import Control.Exception" SymbolKind_Module (R 3 0 3 27) - ] - ], - testSymbolsA - "foreign import" - [ "{-# language ForeignFunctionInterface #-}", - "foreign import ccall \"a\" a :: Int" - ] - [docSymbolD "a" "import" SymbolKind_Object (R 1 0 1 33)], - testSymbolsA - "foreign export" - [ "{-# language ForeignFunctionInterface #-}", - "foreign export ccall odd :: Int -> Bool" - ] - [docSymbolD "odd" "export" SymbolKind_Object (R 1 0 1 39)] - ] - where - docSymbol name kind loc = - DocumentSymbol name Nothing kind Nothing Nothing loc loc Nothing - docSymbol' name kind loc selectionLoc = - DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc Nothing - docSymbolD name detail kind loc = - DocumentSymbol name (Just detail) kind Nothing Nothing loc loc Nothing - docSymbolWithChildren name kind loc cc = - DocumentSymbol name Nothing kind Nothing Nothing loc loc (Just cc) - docSymbolWithChildren' name kind loc selectionLoc cc = - DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc (Just cc) - moduleSymbol name loc cc = - DocumentSymbol - name - Nothing - SymbolKind_File - Nothing - Nothing - (R 0 0 maxBound 0) - loc - (Just cc) - classSymbol name loc cc = - DocumentSymbol - name - (Just "class") - SymbolKind_Interface - Nothing - Nothing - loc - loc - (Just cc) diff --git a/ghcide/test/exe/PluginSimpleTests.hs b/ghcide/test/exe/PluginSimpleTests.hs deleted file mode 100644 --- a/ghcide/test/exe/PluginSimpleTests.hs +++ /dev/null @@ -1,46 +0,0 @@ - -module PluginSimpleTests (tests) where - -import Config -import Control.Monad.IO.Class (liftIO) -import Development.IDE.Test (expectDiagnostics) -import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..), - SemanticTokenRelative (..), - SemanticTokensEdit (..), mkRange) -import Language.LSP.Test -import System.FilePath -import Test.Tasty - -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. - testWithExtraFiles "simple plugin" "plugin-knownnat" $ \dir -> do - _ <- openDoc (dir "KnownNat.hs") "haskell" - liftIO $ writeFile (dir"hie.yaml") - "cradle: {cabal: [{path: '.', component: 'lib:plugin'}]}" - - expectDiagnostics - [ ( "KnownNat.hs", - [(DiagnosticSeverity_Error, (9, 15), "Variable not in scope: c")] - ) - ] diff --git a/ghcide/test/exe/PositionMappingTests.hs b/ghcide/test/exe/PositionMappingTests.hs deleted file mode 100644 --- a/ghcide/test/exe/PositionMappingTests.hs +++ /dev/null @@ -1,219 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} - -module PositionMappingTests (tests) where - -import qualified Data.EnumMap.Strict as EM -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 - 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) - -mkChangeEvent :: Range -> Text -> TextDocumentContentChangeEvent -mkChangeEvent r t = TextDocumentContentChangeEvent $ InL - TextDocumentContentChangePartial {_range = r, _rangeLength = Nothing, _text = t} - -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 $ mkChangeEvent range replacement - newPos <- genPosition newRope - pure (range, replacement, newPos) - forAll - (suchThatMap gen - (\(range, replacement, newPos) -> positionResultToMaybe $ (range, replacement, newPos,) <$> fromCurrent range replacement newPos)) $ - \(range, replacement, newPos, oldPos) -> - toCurrent range replacement oldPos === PositionExact newPos - ] - ] - -newtype PrintableText = PrintableText { getPrintableText :: T.Text } - deriving Show - -instance Arbitrary PrintableText where - arbitrary = PrintableText . T.pack . getPrintableString <$> arbitrary - -genRope :: Gen Rope -genRope = Rope.fromText . getPrintableText <$> arbitrary - -genPosition :: Rope -> Gen Position -genPosition r = do - let rows :: Int = fromIntegral $ Rope.lengthInLines r - row <- choose (0, max 0 $ rows - 1) `suchThat` inBounds @UInt - let columns = T.length (nthLine (fromIntegral row) r) - column <- choose (0, max 0 $ columns - 1) `suchThat` inBounds @UInt - pure $ Position (fromIntegral row) (fromIntegral column) - -genRange :: Rope -> Gen Range -genRange r = do - let rows :: Int = fromIntegral $ Rope.lengthInLines r - startPos@(Position startLine startColumn) <- genPosition r - let maxLineDiff = max 0 $ rows - 1 - fromIntegral startLine - endLine <- choose (fromIntegral startLine, fromIntegral startLine + maxLineDiff) `suchThat` inBounds @UInt - let columns = T.length (nthLine (fromIntegral endLine) r) - endColumn <- - if fromIntegral startLine == endLine - then choose (fromIntegral startColumn, columns) - else choose (0, max 0 $ columns - 1) - `suchThat` inBounds @UInt - pure $ Range startPos (Position (fromIntegral endLine) (fromIntegral endColumn)) - -inBounds :: forall b a . (Integral a, Integral b, Bounded b) => a -> Bool -inBounds a = let i = toInteger a in i <= toInteger (maxBound @b) && i >= toInteger (minBound @b) - --- | Get the ith line of a rope, starting from 0. Trailing newline not included. -nthLine :: Int -> Rope -> T.Text -nthLine i r - | Rope.null r = "" - | otherwise = Rope.lines r !! i diff --git a/ghcide/test/exe/PreprocessorTests.hs b/ghcide/test/exe/PreprocessorTests.hs deleted file mode 100644 --- a/ghcide/test/exe/PreprocessorTests.hs +++ /dev/null @@ -1,27 +0,0 @@ - -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 Config -import Test.Tasty - -tests :: TestTree -tests = testWithDummyPluginEmpty "preprocessor" $ do - let content = - T.unlines - [ "{-# OPTIONS_GHC -F -pgmF=ghcide-test-preprocessor #-}" - , "module Testing where" - , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic - ] - _ <- createDoc "Testing.hs" "haskell" content - expectDiagnostics - [ ( "Testing.hs", - [(DiagnosticSeverity_Error, (2, 8), "Variable not in scope: z")] - ) - ] diff --git a/ghcide/test/exe/Progress.hs b/ghcide/test/exe/Progress.hs deleted file mode 100644 --- a/ghcide/test/exe/Progress.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE PackageImports #-} -module Progress (tests) where - -import Control.Concurrent.STM -import Data.Foldable (for_) -import qualified Data.HashMap.Strict as Map -import Development.IDE (NormalizedFilePath) -import Development.IDE.Core.ProgressReporting -import qualified "list-t" ListT -import qualified StmContainers.Map as STM -import Test.Tasty -import Test.Tasty.HUnit - -tests :: TestTree -tests = testGroup "Progress" - [ reportProgressTests - ] - -data InProgressModel = InProgressModel { - done, todo :: Int, - current :: Map.HashMap NormalizedFilePath Int -} - -reportProgressTests :: TestTree -reportProgressTests = testGroup "recordProgress" - [ test "addNew" addNew - , test "increase" increase - , test "decrease" decrease - , test "done" done - ] - where - p0 = pure $ InProgressModel 0 0 mempty - addNew = recordProgressModel "A" succ p0 - increase = recordProgressModel "A" succ addNew - decrease = recordProgressModel "A" succ increase - done = recordProgressModel "A" pred decrease - recordProgressModel key change state = - model state $ \st -> recordProgress st key change - model stateModelIO k = do - state <- fromModel =<< stateModelIO - _ <- k state - toModel state - test name p = testCase name $ do - InProgressModel{..} <- p - (done, todo) @?= (length (filter (==0) (Map.elems current)), Map.size current) - -fromModel :: InProgressModel -> IO InProgressState -fromModel InProgressModel{..} = do - doneVar <- newTVarIO done - todoVar <- newTVarIO todo - currentVar <- STM.newIO - atomically $ for_ (Map.toList current) $ \(k,v) -> STM.insert v k currentVar - return InProgressState{..} - -toModel :: InProgressState -> IO InProgressModel -toModel InProgressState{..} = atomically $ do - done <- readTVar doneVar - todo <- readTVar todoVar - current <- Map.fromList <$> ListT.toList (STM.listT currentVar) - return InProgressModel{..} diff --git a/ghcide/test/exe/ReferenceTests.hs b/ghcide/test/exe/ReferenceTests.hs deleted file mode 100644 --- a/ghcide/test/exe/ReferenceTests.hs +++ /dev/null @@ -1,233 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} - - -module ReferenceTests (tests) where - -import Control.Applicative.Combinators -import qualified Control.Lens as Lens -import Control.Monad -import Control.Monad.IO.Class (liftIO) -import Data.List.Extra -import qualified Data.Set as Set -import Development.IDE.Types.Location -import qualified Language.LSP.Protocol.Lens as L -import Language.LSP.Protocol.Types hiding - (SemanticTokenAbsolute (..), - SemanticTokenRelative (..), - SemanticTokensEdit (..), - mkRange) -import Language.LSP.Test -import System.Directory --- import Test.QuickCheck.Instances () -import Config -import Control.Lens ((^.)) -import qualified Data.Aeson as A -import Data.Default (def) -import Data.Tuple.Extra -import GHC.TypeLits (symbolVal) -import Ide.PluginUtils (toAbsolute) -import Ide.Types -import System.FilePath (addTrailingPathSeparator, - ()) -import Test.Hls (FromServerMessage' (..), - SMethod (..), - TCustomMessage (..), - TNotificationMessage (..)) -import Test.Hls.FileSystem (copyDir) -import Test.Tasty -import Test.Tasty.ExpectedFailure -import Test.Tasty.HUnit - - -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 = do - testWithDummyPlugin' name (mkIdeTestFs [copyDir "references"]) $ \fs -> do - let rootDir = addTrailingPathSeparator fs - -- needed to build whole project indexing - configureCheckProject True - -- need to get the real paths through links - docs <- mapM (liftIO . canonicalizePath . (fs )) $ delete thisDoc $ nubOrd docs' - -- Initial Index - docid <- openDoc thisDoc "haskell" - - liftIO $ putStrLn $ "docs:" <> show docs - let - -- todo wait for docs - loop :: [FilePath] -> Session () - loop [] = pure () - loop docs = do - - doc <- skipManyTill anyMessage $ referenceReady (`elem` docs) - loop (delete doc docs) - loop docs - f rootDir - closeDoc docid - --- | Given a location, lookup the symbol and all references to it. Make sure --- they are the ones we expect. -referenceTest :: (HasCallStack) => String -> SymbolLocation -> IncludeDeclaration -> [SymbolLocation] -> TestTree -referenceTest name loc includeDeclaration expected = - referenceTestSession name (fst3 loc) docs $ \rootDir -> do - actual <- getReferences' loc includeDeclaration - liftIO $ expectSameLocations rootDir actual expected - where - docs = map fst3 expected - -type SymbolLocation = (FilePath, UInt, UInt) - -expectSameLocations :: (HasCallStack) => FilePath -> [Location] -> [SymbolLocation] -> Assertion -expectSameLocations rootDir 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 $ toAbsolute rootDir file - return (filePathToUri fp, l, c)) - actual' @?= expected' - - --- todo find where to put this in hls -configureCheckProject :: Bool -> Session () -configureCheckProject overrideCheckProject = setConfigSection "haskell" (A.toJSON $ def{checkProject = overrideCheckProject}) -referenceReady :: (FilePath -> Bool) -> Session FilePath -referenceReady pred = satisfyMaybe $ \case - FromServerMess (SMethod_CustomMethod p) (NotMess TNotificationMessage{_params}) - | A.Success fp <- A.fromJSON _params - , pred fp - , symbolVal p == "ghcide/reference/ready" - -> Just fp - _ -> Nothing diff --git a/ghcide/test/exe/RootUriTests.hs b/ghcide/test/exe/RootUriTests.hs deleted file mode 100644 --- a/ghcide/test/exe/RootUriTests.hs +++ /dev/null @@ -1,39 +0,0 @@ - -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 Config -import Data.Default (def) -import Test.Hls (TestConfig (..), - runSessionWithTestConfig) -import Test.Hls.FileSystem (copyDir) -import Test.Tasty -import Test.Tasty.HUnit - - --- | 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" - 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 = runSessionWithTestConfig - def - { - testPluginDescriptor = dummyPlugin - , testDirLocation = Right $ mkIdeTestFs [copyDir "rootUri"] - , testServerRoot = Just dir1 - , testClientRoot = Just dir2 - , testShiftRoot = True - } - - diff --git a/ghcide/test/exe/SafeTests.hs b/ghcide/test/exe/SafeTests.hs deleted file mode 100644 --- a/ghcide/test/exe/SafeTests.hs +++ /dev/null @@ -1,38 +0,0 @@ - -module SafeTests (tests) where - -import qualified Data.Text as T -import Development.IDE.Test (expectNoMoreDiagnostics) -import Language.LSP.Test - -import Config -import Test.Tasty - -tests :: TestTree -tests = - testGroup - "SafeHaskell" - [ -- Test for https://github.com/haskell/ghcide/issues/424 - testWithDummyPluginEmpty "load" $ do - let sourceA = - T.unlines - ["{-# LANGUAGE Trustworthy #-}" - ,"module A where" - ,"import System.IO.Unsafe" - ,"import System.IO ()" - ,"trustWorthyId :: a -> a" - ,"trustWorthyId i = unsafePerformIO $ do" - ," putStrLn \"I'm safe\"" - ," return i"] - sourceB = - T.unlines - ["{-# LANGUAGE Safe #-}" - ,"module B where" - ,"import A" - ,"safeId :: a -> a" - ,"safeId = trustWorthyId" - ] - - _ <- createDoc "A.hs" "haskell" sourceA - _ <- createDoc "B.hs" "haskell" sourceB - expectNoMoreDiagnostics 1 ] diff --git a/ghcide/test/exe/SymlinkTests.hs b/ghcide/test/exe/SymlinkTests.hs deleted file mode 100644 --- a/ghcide/test/exe/SymlinkTests.hs +++ /dev/null @@ -1,27 +0,0 @@ - -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 Config -import Test.Tasty -import Test.Tasty.HUnit - --- | Tests for projects that use symbolic links one way or another -tests :: TestTree -tests = - testGroup "Projects using Symlinks" - [ testCase "Module is symlinked" $ runWithExtraFiles "symlink" $ \dir -> do - liftIO $ createFileLink (dir "some_loc" "Sym.hs") (dir "other_loc" "Sym.hs") - let fooPath = dir "src" "Foo.hs" - _ <- openDoc fooPath "haskell" - expectDiagnosticsWithTags [("src" "Foo.hs", [(DiagnosticSeverity_Warning, (2, 0), "The import of 'Sym' is redundant", Just DiagnosticTag_Unnecessary)])] - pure () - ] diff --git a/ghcide/test/exe/THTests.hs b/ghcide/test/exe/THTests.hs deleted file mode 100644 --- a/ghcide/test/exe/THTests.hs +++ /dev/null @@ -1,190 +0,0 @@ - -module THTests (tests) where - -import Config -import Control.Monad.IO.Class (liftIO) -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 - -tests :: TestTree -tests = - testGroup - "TemplateHaskell" - [ -- Test for https://github.com/haskell/ghcide/pull/212 - testWithDummyPluginEmpty "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")] ) ] - , testWithDummyPluginEmpty "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 - , thReloadingTest True - -- Regression test for https://github.com/haskell/haskell-language-server/issues/891 - , thLinkingTest False - , thLinkingTest True - , testWithDummyPluginEmpty "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 $ TextDocumentContentChangeWholeDocument aSource'] - -- generate an artificial warning to avoid timing out if the TH change does not propagate - changeDoc cdoc [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ 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 $ TextDocumentContentChangeWholeDocument aSource'] - - -- modify b too - let bSource' = T.unlines $ init (T.lines bSource) ++ ["$th"] - changeDoc bdoc [TextDocumentContentChangeEvent . InR $ TextDocumentContentChangeWholeDocument bSource'] - _ <- waitForDiagnostics - - expectCurrentDiagnostics bdoc [(DiagnosticSeverity_Warning, (4,1), "Top-level binding")] - - closeDoc adoc - closeDoc bdoc - where - name = "th-linking-test" <> if unboxed then "-unboxed" else "" - dir | unboxed = "THUnboxed" - | otherwise = "TH" diff --git a/ghcide/test/exe/UnitTests.hs b/ghcide/test/exe/UnitTests.hs deleted file mode 100644 --- a/ghcide/test/exe/UnitTests.hs +++ /dev/null @@ -1,112 +0,0 @@ - -module UnitTests (tests) where - -import Config (mkIdeTestFs) -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.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) -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 Network.URI -import qualified Progress -import System.IO.Extra hiding (withTempDir) -import System.Mem (performGC) -import Test.Hls (IdeState, def, - runSessionWithServerInTmpDir, - waitForProgressDone) -import Test.Tasty -import Test.Tasty.ExpectedFailure -import Test.Tasty.HUnit -import Text.Printf (printf) - -tests :: TestTree -tests = 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 ::Recorder (WithPriority Ghcide.Log) -> IdePlugins IdeState - plugins recorder = pluginDescToIdePlugins $ - [ (priorityPluginDescriptor i) - { pluginNotificationHandlers = mconcat - [ mkPluginNotificationHandler SMethod_TextDocumentDidOpen $ \_ _ _ _ -> - liftIO $ atomicModifyIORef_ orderRef (i:) - ] - } - | i <- [1..20] - ] ++ Ghcide.descriptors recorder - priorityPluginDescriptor i = (defaultPluginDescriptor (fromString $ show i) ""){pluginPriority = i} - - runSessionWithServerInTmpDir def plugins (mkIdeTestFs []) $ do - _ <- createDoc "A.hs" "haskell" "module A where" - waitForProgressDone - actualOrder <- liftIO $ reverse <$> readIORef orderRef - - -- Handlers are run in priority descending order - liftIO $ actualOrder @?= [20, 19 .. 1] - , ignoreTestBecause "The test fails sometimes showing 10000us" $ - testCase "timestamps have millisecond resolution" $ do - resolution_us <- findResolution_us 1 - let msg = printf "Timestamps do not have millisecond resolution: %dus" resolution_us - assertBool msg (resolution_us <= 1000) - , Progress.tests - , FuzzySearch.tests - ] - -findResolution_us :: Int -> IO Int -findResolution_us delay_us | delay_us >= 1000000 = error "Unable to compute timestamp resolution" -findResolution_us delay_us = withTempFile $ \f -> withTempFile $ \f' -> do - performGC - writeFile f "" - threadDelay delay_us - writeFile f' "" - t <- getModTime f - t' <- getModTime f' - if t /= t' then return delay_us else findResolution_us (delay_us * 10) diff --git a/ghcide/test/exe/WatchedFileTests.hs b/ghcide/test/exe/WatchedFileTests.hs deleted file mode 100644 --- a/ghcide/test/exe/WatchedFileTests.hs +++ /dev/null @@ -1,83 +0,0 @@ - -{-# LANGUAGE GADTs #-} - -module WatchedFileTests (tests) where - -import Config (testWithDummyPluginEmpty') -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 - -tests :: TestTree -tests = testGroup "watched files" - [ testGroup "Subscriptions" - [ testWithDummyPluginEmpty' "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 - - , testWithDummyPluginEmpty' "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" - [ - testWithDummyPluginEmpty' "workspace files" $ \sessionDir -> do - liftIO $ writeFile (sessionDir "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"B\"]}}" - liftIO $ writeFile (sessionDir "B.hs") $ unlines - ["module B where" - ,"b :: Bool" - ,"b = False"] - _doc <- createDoc "A.hs" "haskell" $ T.unlines - ["module A where" - ,"import B" - ,"a :: ()" - ,"a = b" - ] - expectDiagnostics [("A.hs", [(DiagnosticSeverity_Error, (3, 4), "Couldn't match expected type '()' with actual type 'Bool'")])] - -- modify B off editor - liftIO $ writeFile (sessionDir "B.hs") $ unlines - ["module B where" - ,"b :: Int" - ,"b = 0"] - sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ - [FileEvent (filePathToUri $ sessionDir "B.hs") FileChangeType_Changed ] - expectDiagnostics [("A.hs", [(DiagnosticSeverity_Error, (3, 4), "Couldn't match expected type '()' with actual type 'Int'")])] - ] - ] - -getWatchedFilesSubscriptionsUntil :: forall m. SServerMethod m -> Session [DidChangeWatchedFilesRegistrationOptions] -getWatchedFilesSubscriptionsUntil m = do - msgs <- manyTill (Just <$> message SMethod_ClientRegisterCapability <|> Nothing <$ anyMessage) (message m) - return - [ x - | Just TRequestMessage{_params = RegistrationParams regs} <- msgs - , Registration _id "workspace/didChangeWatchedFiles" (Just args) <- regs - , Just x@(DidChangeWatchedFilesRegistrationOptions _) <- [A.decode . A.encode $ args] - ] diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -1,7 +1,7 @@ cabal-version: 3.4 category: Development name: haskell-language-server -version: 2.9.0.1 +version: 2.10.0.0 synopsis: LSP server for GHC description: Please see the README on GitHub at @@ -14,7 +14,7 @@ license: Apache-2.0 license-file: LICENSE build-type: Simple -tested-with: GHC ==9.10.1 || ==9.8.2 || ==9.6.5 || ==9.4.8 || ==9.2.8 +tested-with: GHC ==9.10.1 || ==9.8.2 || ==9.6.5 || ==9.4.8 extra-source-files: README.md ChangeLog.md @@ -32,6 +32,12 @@ plugins/**/*.txt plugins/**/*.hs + ghcide-test/data/**/*.cabal + ghcide-test/data/**/*.hs + ghcide-test/data/**/*.hs-boot + ghcide-test/data/**/*.project + ghcide-test/data/**/*.yaml + bindist/wrapper.in source-repository head @@ -42,6 +48,8 @@ default-language: GHC2021 -- Should have been in GHC2021, an oversight default-extensions: ExplicitNamespaces + build-depends: + , base >=4.12 && <5 common test-defaults ghc-options: -threaded -rtsopts -with-rtsopts=-N @@ -126,33 +134,34 @@ exposed-modules: Ide.Plugin.CabalFmt hs-source-dirs: plugins/hls-cabal-fmt-plugin/src build-depends: - , base >=4.12 && <5 , directory , filepath - , ghcide == 2.9.0.1 - , hls-plugin-api == 2.9.0.1 + , ghcide == 2.10.0.0 + , hls-plugin-api == 2.10.0.0 , lens , lsp-types , mtl , process-extras , text +-- The `hls-cabal-plugin` is needed for tests, as we need to install notification handlers test-suite hls-cabal-fmt-plugin-tests import: defaults, pedantic, test-defaults, warnings - if !flag(cabalfmt) + if !flag(cabalfmt) || !flag(cabal) buildable: False type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-cabal-fmt-plugin/test main-is: Main.hs build-depends: - , base >=4.12 && <5 , directory , filepath + , haskell-language-server:hls-cabal-plugin , haskell-language-server:hls-cabal-fmt-plugin - , hls-test-utils == 2.9.0.1 + , hls-plugin-api == 2.10.0.0 + , hls-test-utils == 2.10.0.0 if flag(isolateCabalfmtTests) - build-tool-depends: cabal-fmt:cabal-fmt ^>=0.1.6 + build-tool-depends: cabal-fmt:cabal-fmt ^>=0.1.12 cpp-options: -Dhls_isolate_cabalfmt_tests ----------------------------- @@ -165,7 +174,7 @@ manual: True common cabalgild - if flag(cabalgild) + if flag(cabalgild) && impl(ghc < 9.11) build-depends: haskell-language-server:hls-cabal-gild-plugin cpp-options: -Dhls_cabalgild @@ -177,37 +186,39 @@ library hls-cabal-gild-plugin import: defaults, pedantic, warnings - if !flag(cabalgild) + if !flag(cabalgild) || impl(ghc > 9.11) 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.9.0.1 - , hls-plugin-api == 2.9.0.1 + , ghcide == 2.10.0.0 + , hls-plugin-api == 2.10.0.0 , lsp-types , text , mtl , process-extras +-- The `hls-cabal-plugin` is needed for tests, as we need to install notification handlers test-suite hls-cabal-gild-plugin-tests import: defaults, pedantic, test-defaults, warnings - if !flag(cabalgild) + if !flag(cabalgild) || !flag(cabal) || impl(ghc > 9.11) buildable: False type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-cabal-gild-plugin/test main-is: Main.hs build-depends: - , base >=4.12 && <5 , directory , filepath + , haskell-language-server:hls-cabal-plugin , haskell-language-server:hls-cabal-gild-plugin - , hls-test-utils == 2.9.0.1 + , hls-plugin-api == 2.10.0.0 + , hls-test-utils == 2.10.0.0 if flag(isolateCabalGildTests) - build-tool-depends: cabal-gild:cabal-gild ^>=1.3 + -- https://github.com/tfausak/cabal-gild/issues/89 + build-tool-depends: cabal-gild:cabal-gild >= 1.3 && < 1.3.2 cpp-options: -Dhls_isolate_cabalgild_tests ----------------------------- @@ -231,6 +242,7 @@ exposed-modules: Ide.Plugin.Cabal Ide.Plugin.Cabal.Diagnostics + Ide.Plugin.Cabal.Completion.CabalFields Ide.Plugin.Cabal.Completion.Completer.FilePath Ide.Plugin.Cabal.Completion.Completer.Module Ide.Plugin.Cabal.Completion.Completer.Paths @@ -240,13 +252,16 @@ Ide.Plugin.Cabal.Completion.Completions Ide.Plugin.Cabal.Completion.Data Ide.Plugin.Cabal.Completion.Types + Ide.Plugin.Cabal.Definition + Ide.Plugin.Cabal.FieldSuggest Ide.Plugin.Cabal.LicenseSuggest + Ide.Plugin.Cabal.CabalAdd Ide.Plugin.Cabal.Orphans + Ide.Plugin.Cabal.Outline Ide.Plugin.Cabal.Parse build-depends: - , base >=4.12 && <5 , bytestring , Cabal-syntax >= 3.7 , containers @@ -254,18 +269,25 @@ , directory , filepath , extra >=1.7.4 - , ghcide == 2.9.0.1 + , ghcide == 2.10.0.0 , hashable - , hls-plugin-api == 2.9.0.1 - , hls-graph == 2.9.0.1 + , hls-plugin-api == 2.10.0.0 + , hls-graph == 2.10.0.0 , lens , lsp ^>=2.7 , lsp-types ^>=2.3 , regex-tdfa ^>=1.3.1 , text + , text-rope , transformers , unordered-containers >=0.2.10.0 , containers + , cabal-add + , process + , aeson + , Cabal + , pretty + hs-source-dirs: plugins/hls-cabal-plugin/src test-suite hls-cabal-plugin-tests @@ -276,20 +298,24 @@ hs-source-dirs: plugins/hls-cabal-plugin/test main-is: Main.hs other-modules: + CabalAdd Completer Context + Definition + Outline Utils build-depends: - , base >=4.12 && <5 , bytestring , Cabal-syntax >= 3.7 + , extra , filepath , ghcide , haskell-language-server:hls-cabal-plugin - , hls-test-utils == 2.9.0.1 + , hls-test-utils == 2.10.0.0 , lens , lsp-types , text + , hls-plugin-api ----------------------------- -- class plugin @@ -318,15 +344,14 @@ hs-source-dirs: plugins/hls-class-plugin/src build-depends: , aeson - , base >=4.12 && <5 , containers , deepseq , extra , ghc - , ghc-exactprint >= 1.5 && < 1.10.0.0 - , ghcide == 2.9.0.1 + , ghc-exactprint >= 1.5 && < 1.13.0.0 + , ghcide == 2.10.0.0 , hls-graph - , hls-plugin-api == 2.9.0.1 + , hls-plugin-api == 2.10.0.0 , lens , lsp , mtl @@ -345,10 +370,9 @@ hs-source-dirs: plugins/hls-class-plugin/test main-is: Main.hs build-depends: - , base >=4.12 && <5 , filepath , haskell-language-server:hls-class-plugin - , hls-test-utils == 2.9.0.1 + , hls-test-utils == 2.10.0.0 , lens , lsp-types , text @@ -380,12 +404,11 @@ hs-source-dirs: plugins/hls-call-hierarchy-plugin/src build-depends: , aeson - , base >=4.12 && <5 , containers , extra - , ghcide == 2.9.0.1 + , ghcide == 2.10.0.0 , hiedb ^>= 0.6.0.0 - , hls-plugin-api == 2.9.0.1 + , hls-plugin-api == 2.10.0.0 , lens , lsp >=2.7 , sqlite-simple @@ -402,12 +425,11 @@ main-is: Main.hs build-depends: , aeson - , base >=4.12 && <5 , containers , extra , filepath , haskell-language-server:hls-call-hierarchy-plugin - , hls-test-utils == 2.9.0.1 + , hls-test-utils == 2.10.0.0 , lens , lsp , lsp-test @@ -448,7 +470,6 @@ build-depends: , aeson - , base >=4.12 && <5 , bytestring , containers , deepseq @@ -458,9 +479,9 @@ , filepath , ghc , ghc-boot-th - , ghcide == 2.9.0.1 + , ghcide == 2.10.0.0 , hls-graph - , hls-plugin-api == 2.9.0.1 + , hls-plugin-api == 2.10.0.0 , lens , lsp , lsp-types @@ -468,6 +489,7 @@ , mtl , parser-combinators >=1.2 , text + , text-rope , transformers , unliftio , unordered-containers @@ -485,13 +507,12 @@ ghc-options: -fno-ignore-asserts build-depends: , aeson - , base >=4.12 && <5 , containers , extra , filepath , haskell-language-server:hls-eval-plugin , hls-plugin-api - , hls-test-utils == 2.9.0.1 + , hls-test-utils == 2.10.0.0 , lens , lsp-types , text @@ -500,16 +521,16 @@ -- import lens plugin ----------------------------- +flag importLens + description: Enable importLens plugin + default: True + manual: False + common importLens if flag(importLens) build-depends: haskell-language-server:hls-explicit-imports-plugin cpp-options: -Dhls_importLens -flag importLens - description: Enable importLens plugin - default: True - manual: True - library hls-explicit-imports-plugin import: defaults, pedantic, warnings if !flag(importlens) @@ -518,13 +539,12 @@ hs-source-dirs: plugins/hls-explicit-imports-plugin/src build-depends: , aeson - , base >=4.12 && <5 , containers , deepseq , ghc - , ghcide == 2.9.0.1 + , ghcide == 2.10.0.0 , hls-graph - , hls-plugin-api == 2.9.0.1 + , hls-plugin-api == 2.10.0.0 , lens , lsp , mtl @@ -542,11 +562,10 @@ hs-source-dirs: plugins/hls-explicit-imports-plugin/test main-is: Main.hs build-depends: - , base >=4.12 && <5 , extra , filepath , haskell-language-server:hls-explicit-imports-plugin - , hls-test-utils == 2.9.0.1 + , hls-test-utils == 2.10.0.0 , lens , lsp-types , text @@ -561,24 +580,23 @@ manual: True common rename - if flag(rename) + if flag(rename) && impl(ghc < 9.11) build-depends: haskell-language-server:hls-rename-plugin cpp-options: -Dhls_rename library hls-rename-plugin import: defaults, pedantic, warnings - if !flag(rename) + if !flag(rename) || impl(ghc > 9.11) buildable: False exposed-modules: Ide.Plugin.Rename hs-source-dirs: plugins/hls-rename-plugin/src build-depends: - , base >=4.12 && <5 , containers - , ghcide == 2.9.0.1 + , ghcide == 2.10.0.0 , hashable , hiedb ^>= 0.6.0.0 , hie-compat - , hls-plugin-api == 2.9.0.1 + , hls-plugin-api == 2.10.0.0 , haskell-language-server:hls-refactor-plugin , lens , lsp-types @@ -592,19 +610,18 @@ test-suite hls-rename-plugin-tests import: defaults, pedantic, test-defaults, warnings - if !flag(rename) + if !flag(rename) || impl(ghc > 9.11) buildable: False type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-rename-plugin/test main-is: Main.hs build-depends: , aeson - , base >=4.12 && <5 , containers , filepath , hls-plugin-api , haskell-language-server:hls-rename-plugin - , hls-test-utils == 2.9.0.1 + , hls-test-utils == 2.10.0.0 , lens , lsp-types , text @@ -631,14 +648,13 @@ hs-source-dirs: plugins/hls-retrie-plugin/src build-depends: , aeson - , base >=4.12 && <5 , bytestring , containers , extra , ghc - , ghcide == 2.9.0.1 + , ghcide == 2.10.0.0 , hashable - , hls-plugin-api == 2.9.0.1 + , hls-plugin-api == 2.10.0.0 , haskell-language-server:hls-refactor-plugin , lens , lsp @@ -648,6 +664,7 @@ , safe-exceptions , stm , text + , text-rope , transformers , unordered-containers @@ -662,12 +679,11 @@ hs-source-dirs: plugins/hls-retrie-plugin/test main-is: Main.hs build-depends: - , base >=4.12 && <5 , containers , filepath , hls-plugin-api , haskell-language-server:{hls-refactor-plugin, hls-retrie-plugin} - , hls-test-utils == 2.9.0.1 + , hls-test-utils == 2.10.0.0 , text ----------------------------- @@ -694,33 +710,34 @@ library hls-hlint-plugin import: defaults, pedantic, warnings -- https://github.com/ndmitchell/hlint/pull/1594 - if !(flag(hlint) && impl(ghc < 9.10)) + if !(flag(hlint)) || impl(ghc > 9.10) buildable: False exposed-modules: Ide.Plugin.Hlint hs-source-dirs: plugins/hls-hlint-plugin/src build-depends: , aeson - , base >=4.12 && <5 , bytestring , containers , deepseq , filepath - , ghcide == 2.9.0.1 + , ghcide == 2.10.0.0 , hashable , hlint >= 3.5 && < 3.9 - , hls-plugin-api == 2.9.0.1 + , hls-plugin-api == 2.10.0.0 , lens - , lsp , mtl , refact , regex-tdfa , stm , temporary , text + , text-rope , transformers , unordered-containers , ghc-lib-parser-ex , apply-refact + -- + , lsp-types if flag(ghc-lib) cpp-options: -DGHC_LIB @@ -736,19 +753,21 @@ test-suite hls-hlint-plugin-tests import: defaults, pedantic, test-defaults, warnings - if !(flag(hlint) && impl(ghc < 9.10)) + if (!flag(hlint)) || impl(ghc > 9.10) buildable: False type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-hlint-plugin/test main-is: Main.hs + -- Work around https://gitlab.haskell.org/ghc/ghc/-/issues/24648 + if os(darwin) + ghc-options: -optl-Wl,-ld_classic build-depends: aeson - , base >=4.12 && <5 , containers , filepath , haskell-language-server:hls-hlint-plugin , hls-plugin-api - , hls-test-utils == 2.9.0.1 + , hls-test-utils == 2.10.0.0 , lens , lsp-types , text @@ -763,20 +782,17 @@ manual: True common stan - if flag(stan) && (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 < 9.11) build-depends: haskell-language-server:hls-stan-plugin cpp-options: -Dhls_stan library hls-stan-plugin import: defaults, pedantic, warnings - 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 + if !flag(stan) || impl(ghc > 9.11) buildable: False exposed-modules: Ide.Plugin.Stan hs-source-dirs: plugins/hls-stan-plugin/src build-depends: - base >=4.12 && <5 , deepseq , hashable , hie-compat @@ -797,19 +813,16 @@ test-suite hls-stan-plugin-tests import: defaults, pedantic, test-defaults, warnings - 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 + if !flag(stan) || impl(ghc > 9.11) buildable: False type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-stan-plugin/test main-is: Main.hs build-depends: - , base >=4.12 && <5 , filepath , haskell-language-server:hls-stan-plugin , hls-plugin-api - , hls-test-utils == 2.9.0.1 + , hls-test-utils == 2.10.0.0 , lens , lsp-types , text @@ -838,13 +851,13 @@ hs-source-dirs: plugins/hls-module-name-plugin/src build-depends: , aeson - , base >=4.12 && <5 , containers , filepath - , ghcide == 2.9.0.1 - , hls-plugin-api == 2.9.0.1 + , ghcide == 2.10.0.0 + , hls-plugin-api == 2.10.0.0 , lsp , text + , text-rope , transformers @@ -856,10 +869,9 @@ hs-source-dirs: plugins/hls-module-name-plugin/test main-is: Main.hs build-depends: - , base >=4.12 && <5 , filepath , haskell-language-server:hls-module-name-plugin - , hls-test-utils == 2.9.0.1 + , hls-test-utils == 2.10.0.0 ----------------------------- -- pragmas plugin @@ -882,12 +894,13 @@ exposed-modules: Ide.Plugin.Pragmas hs-source-dirs: plugins/hls-pragmas-plugin/src build-depends: - , base >=4.12 && <5 + , aeson , extra , fuzzy - , ghcide == 2.9.0.1 - , hls-plugin-api == 2.9.0.1 + , ghcide == 2.10.0.0 + , hls-plugin-api == 2.10.0.0 , lens + , lens-aeson , lsp , text , transformers @@ -902,10 +915,9 @@ main-is: Main.hs build-depends: , aeson - , base >=4.12 && <5 , filepath , haskell-language-server:hls-pragmas-plugin - , hls-test-utils == 2.9.0.1 + , hls-test-utils == 2.10.0.0 , lens , lsp-types , text @@ -935,13 +947,11 @@ hs-source-dirs: plugins/hls-splice-plugin/src build-depends: , aeson - , base >=4.12 && <5 , extra , foldl , ghc - , ghc-exactprint - , ghcide == 2.9.0.1 - , hls-plugin-api == 2.9.0.1 + , ghcide == 2.10.0.0 + , hls-plugin-api == 2.10.0.0 , haskell-language-server:hls-refactor-plugin , lens , lsp @@ -962,10 +972,9 @@ hs-source-dirs: plugins/hls-splice-plugin/test main-is: Main.hs build-depends: - , base >=4.12 && <5 , filepath , haskell-language-server:hls-splice-plugin - , hls-test-utils == 2.9.0.1 + , hls-test-utils == 2.10.0.0 , text ----------------------------- @@ -990,13 +999,12 @@ other-modules: Ide.Plugin.Literals hs-source-dirs: plugins/hls-alternate-number-format-plugin/src build-depends: - , base >=4.12 && < 5 , containers , extra - , ghcide == 2.9.0.1 + , ghcide == 2.10.0.0 , ghc-boot-th , hls-graph - , hls-plugin-api == 2.9.0.1 + , hls-plugin-api == 2.10.0.0 , lens , lsp ^>=2.7 , mtl @@ -1019,10 +1027,9 @@ main-is: Main.hs ghc-options: -fno-ignore-asserts build-depends: - , base >=4.12 && < 5 , filepath , haskell-language-server:hls-alternate-number-format-plugin - , hls-test-utils == 2.9.0.1 + , hls-test-utils == 2.10.0.0 , regex-tdfa , tasty-quickcheck , text @@ -1053,13 +1060,13 @@ exposed-modules: Ide.Plugin.QualifyImportedNames hs-source-dirs: plugins/hls-qualify-imported-names-plugin/src build-depends: - , base >=4.12 && <5 , containers - , ghcide == 2.9.0.1 - , hls-plugin-api == 2.9.0.1 + , ghcide == 2.10.0.0 + , hls-plugin-api == 2.10.0.0 , lens , lsp , text + , text-rope , dlist , transformers @@ -1074,11 +1081,10 @@ hs-source-dirs: plugins/hls-qualify-imported-names-plugin/test main-is: Main.hs build-depends: - , base >=4.12 && <5 , text , filepath , haskell-language-server:hls-qualify-imported-names-plugin - , hls-test-utils == 2.9.0.1 + , hls-test-utils == 2.10.0.0 ----------------------------- -- code range plugin @@ -1105,13 +1111,12 @@ Ide.Plugin.CodeRange.ASTPreProcess hs-source-dirs: plugins/hls-code-range-plugin/src build-depends: - , base >=4.12 && <5 , containers , deepseq , extra - , ghcide == 2.9.0.1 + , ghcide == 2.10.0.0 , hashable - , hls-plugin-api == 2.9.0.1 + , hls-plugin-api == 2.10.0.0 , lens , lsp , mtl @@ -1130,11 +1135,10 @@ Ide.Plugin.CodeRangeTest Ide.Plugin.CodeRange.RulesTest build-depends: - , base >=4.12 && <5 , bytestring , filepath , haskell-language-server:hls-code-range-plugin - , hls-test-utils == 2.9.0.1 + , hls-test-utils == 2.10.0.0 , lens , lsp , lsp-test @@ -1162,9 +1166,8 @@ exposed-modules: Ide.Plugin.ChangeTypeSignature hs-source-dirs: plugins/hls-change-type-signature-plugin/src build-depends: - , base >=4.12 && < 5 - , ghcide == 2.9.0.1 - , hls-plugin-api == 2.9.0.1 + , ghcide == 2.10.0.0 + , hls-plugin-api == 2.10.0.0 , lsp-types , regex-tdfa , syb @@ -1186,10 +1189,9 @@ hs-source-dirs: plugins/hls-change-type-signature-plugin/test main-is: Main.hs build-depends: - , base >=4.12 && < 5 , filepath , haskell-language-server:hls-change-type-signature-plugin - , hls-test-utils == 2.9.0.1 + , hls-test-utils == 2.10.0.0 , regex-tdfa , text default-extensions: @@ -1206,26 +1208,25 @@ manual: True common gadt - if flag(gadt) + if flag(gadt) && impl(ghc < 9.11) build-depends: haskell-language-server:hls-gadt-plugin cpp-options: -Dhls_gadt library hls-gadt-plugin import: defaults, pedantic, warnings - if !flag(gadt) + if !flag(gadt) || impl(ghc > 9.11) buildable: False exposed-modules: Ide.Plugin.GADT other-modules: Ide.Plugin.GHC hs-source-dirs: plugins/hls-gadt-plugin/src build-depends: , aeson - , base >=4.12 && <5 , containers , extra , ghc - , ghcide == 2.9.0.1 + , ghcide == 2.10.0.0 , ghc-exactprint - , hls-plugin-api == 2.9.0.1 + , hls-plugin-api == 2.10.0.0 , haskell-language-server:hls-refactor-plugin , lens , lsp >=2.7 @@ -1237,16 +1238,15 @@ test-suite hls-gadt-plugin-tests import: defaults, pedantic, test-defaults, warnings - if !flag(gadt) + if !flag(gadt) || impl(ghc > 9.11) buildable: False type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-gadt-plugin/test main-is: Main.hs build-depends: - , base >=4.12 && <5 , filepath , haskell-language-server:hls-gadt-plugin - , hls-test-utils == 2.9.0.1 + , hls-test-utils == 2.10.0.0 , text ----------------------------- @@ -1270,13 +1270,12 @@ exposed-modules: Ide.Plugin.ExplicitFixity hs-source-dirs: plugins/hls-explicit-fixity-plugin/src build-depends: - base >=4.12 && <5 , containers , deepseq , extra - , ghcide == 2.9.0.1 + , ghcide == 2.10.0.0 , hashable - , hls-plugin-api == 2.9.0.1 + , hls-plugin-api == 2.10.0.0 , lsp >=2.7 , text @@ -1290,10 +1289,9 @@ hs-source-dirs: plugins/hls-explicit-fixity-plugin/test main-is: Main.hs build-depends: - , base >=4.12 && <5 , filepath , haskell-language-server:hls-explicit-fixity-plugin - , hls-test-utils == 2.9.0.1 + , hls-test-utils == 2.10.0.0 , text ----------------------------- @@ -1316,9 +1314,8 @@ buildable: False exposed-modules: Ide.Plugin.ExplicitFields build-depends: - , base >=4.12 && <5 - , ghcide == 2.9.0.1 - , hls-plugin-api == 2.9.0.1 + , ghcide == 2.10.0.0 + , hls-plugin-api == 2.10.0.0 , lsp , lens , hls-graph @@ -1340,11 +1337,11 @@ hs-source-dirs: plugins/hls-explicit-record-fields-plugin/test main-is: Main.hs build-depends: - , base >=4.12 && <5 , filepath , text + , ghcide , haskell-language-server:hls-explicit-record-fields-plugin - , hls-test-utils == 2.9.0.1 + , hls-test-utils == 2.10.0.0 ----------------------------- -- overloaded record dot plugin @@ -1366,7 +1363,6 @@ buildable: False exposed-modules: Ide.Plugin.OverloadedRecordDot build-depends: - , base >=4.16 && <5 , aeson , ghcide , hls-plugin-api @@ -1388,11 +1384,10 @@ hs-source-dirs: plugins/hls-overloaded-record-dot-plugin/test main-is: Main.hs build-depends: - , base >=4.12 && <5 , filepath , text , haskell-language-server:hls-overloaded-record-dot-plugin - , hls-test-utils == 2.9.0.1 + , hls-test-utils == 2.10.0.0 ----------------------------- @@ -1417,10 +1412,9 @@ 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.9.0.1 - , hls-plugin-api == 2.9.0.1 + , ghcide == 2.10.0.0 + , hls-plugin-api == 2.10.0.0 , lsp-types ^>=2.3 , mtl , text @@ -1434,10 +1428,9 @@ hs-source-dirs: plugins/hls-floskell-plugin/test main-is: Main.hs build-depends: - , base >=4.12 && <5 , filepath , haskell-language-server:hls-floskell-plugin - , hls-test-utils == 2.9.0.1 + , hls-test-utils == 2.10.0.0 ----------------------------- -- fourmolu plugin @@ -1449,23 +1442,22 @@ manual: True common fourmolu - if flag(fourmolu) + if flag(fourmolu) && impl(ghc < 9.11) build-depends: haskell-language-server:hls-fourmolu-plugin cpp-options: -Dhls_fourmolu library hls-fourmolu-plugin import: defaults, pedantic, warnings - if !flag(fourmolu) + if !flag(fourmolu) || impl(ghc > 9.11) buildable: False exposed-modules: Ide.Plugin.Fourmolu hs-source-dirs: plugins/hls-fourmolu-plugin/src build-depends: - , base >=4.12 && <5 , filepath , fourmolu ^>= 0.14 || ^>= 0.15 || ^>= 0.16 , ghc-boot-th - , ghcide == 2.9.0.1 - , hls-plugin-api == 2.9.0.1 + , ghcide == 2.10.0.0 + , hls-plugin-api == 2.10.0.0 , lens , lsp , mtl @@ -1476,7 +1468,7 @@ test-suite hls-fourmolu-plugin-tests import: defaults, pedantic, test-defaults, warnings - if !flag(fourmolu) + if !flag(fourmolu) || impl(ghc > 9.11) buildable: False type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-fourmolu-plugin/test @@ -1487,12 +1479,11 @@ build-tool-depends: fourmolu:fourmolu build-depends: - , base >=4.12 && <5 , aeson , filepath , haskell-language-server:hls-fourmolu-plugin , hls-plugin-api - , hls-test-utils == 2.9.0.1 + , hls-test-utils == 2.10.0.0 , lsp-test ----------------------------- @@ -1505,23 +1496,22 @@ manual: True common ormolu - if flag(ormolu) + if flag(ormolu) && impl(ghc < 9.11) build-depends: haskell-language-server:hls-ormolu-plugin cpp-options: -Dhls_ormolu library hls-ormolu-plugin import: defaults, pedantic, warnings - if !flag(ormolu) + if !flag(ormolu) || impl(ghc > 9.11) buildable: False exposed-modules: Ide.Plugin.Ormolu hs-source-dirs: plugins/hls-ormolu-plugin/src build-depends: - , base >=4.12 && <5 , extra , filepath , ghc-boot-th - , ghcide == 2.9.0.1 - , hls-plugin-api == 2.9.0.1 + , ghcide == 2.10.0.0 + , hls-plugin-api == 2.10.0.0 , lsp , mtl , process-extras >= 0.7.1 @@ -1532,7 +1522,7 @@ test-suite hls-ormolu-plugin-tests import: defaults, pedantic, test-defaults, warnings - if !flag(ormolu) + if !flag(ormolu) || impl(ghc > 9.11) buildable: False type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-ormolu-plugin/test @@ -1543,12 +1533,11 @@ build-tool-depends: ormolu:ormolu build-depends: - , base >=4.12 && <5 , aeson , filepath , haskell-language-server:hls-ormolu-plugin , hls-plugin-api - , hls-test-utils == 2.9.0.1 + , hls-test-utils == 2.10.0.0 , lsp-types , ormolu @@ -1574,12 +1563,11 @@ exposed-modules: Ide.Plugin.StylishHaskell hs-source-dirs: plugins/hls-stylish-haskell-plugin/src build-depends: - , base >=4.12 && <5 , directory , filepath , ghc-boot-th - , ghcide == 2.9.0.1 - , hls-plugin-api == 2.9.0.1 + , ghcide == 2.10.0.0 + , hls-plugin-api == 2.10.0.0 , lsp-types , mtl , stylish-haskell ^>=0.12 || ^>=0.13 || ^>=0.14 @@ -1594,10 +1582,9 @@ hs-source-dirs: plugins/hls-stylish-haskell-plugin/test main-is: Main.hs build-depends: - , base >=4.12 && <5 , filepath , haskell-language-server:hls-stylish-haskell-plugin - , hls-test-utils == 2.9.0.1 + , hls-test-utils == 2.10.0.0 ----------------------------- -- refactor plugin @@ -1609,13 +1596,13 @@ manual: True common refactor - if flag(refactor) + if flag(refactor) && impl(ghc < 9.11) build-depends: haskell-language-server:hls-refactor-plugin cpp-options: -Dhls_refactor library hls-refactor-plugin import: defaults, pedantic, warnings - if !flag(refactor) + if !flag(refactor) || impl(ghc > 9.11) buildable: False exposed-modules: Development.IDE.GHC.ExactPrint Development.IDE.GHC.Compat.ExactPrint @@ -1645,15 +1632,15 @@ ViewPatterns hs-source-dirs: plugins/hls-refactor-plugin/src build-depends: - , base >=4.12 && <5 , ghc , bytestring , ghc-boot , regex-tdfa - , ghcide == 2.9.0.1 - , hls-plugin-api == 2.9.0.1 + , ghcide == 2.10.0.0 + , hls-plugin-api == 2.10.0.0 , lsp , text + , text-rope , transformers , unordered-containers , containers @@ -1674,7 +1661,7 @@ test-suite hls-refactor-plugin-tests import: defaults, pedantic, test-defaults, warnings - if !flag(refactor) + if !flag(refactor) || impl(ghc > 9.11) buildable: False type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-refactor-plugin/test @@ -1682,14 +1669,13 @@ other-modules: Test.AddArgument ghc-options: -O0 build-depends: - , base >=4.12 && <5 , data-default , directory , extra , filepath , ghcide:ghcide , haskell-language-server:hls-refactor-plugin - , hls-test-utils == 2.9.0.1 + , hls-test-utils == 2.10.0.0 , lens , lsp-test , lsp-types @@ -1732,13 +1718,12 @@ hs-source-dirs: plugins/hls-semantic-tokens-plugin/src build-depends: - , base >=4.12 && <5 , containers , extra , text-rope , mtl >= 2.2 - , ghcide == 2.9.0.1 - , hls-plugin-api == 2.9.0.1 + , ghcide == 2.10.0.0 + , hls-plugin-api == 2.10.0.0 , lens , lsp >=2.6 , text @@ -1748,7 +1733,7 @@ , array , deepseq , dlist - , hls-graph == 2.9.0.1 + , hls-graph == 2.10.0.0 , template-haskell , data-default , stm @@ -1766,14 +1751,13 @@ build-depends: , aeson - , base >=4.12 && <5 , containers , data-default , filepath - , ghcide == 2.9.0.1 + , ghcide == 2.10.0.0 , haskell-language-server:hls-semantic-tokens-plugin - , hls-plugin-api == 2.9.0.1 - , hls-test-utils == 2.9.0.1 + , hls-plugin-api == 2.10.0.0 + , hls-test-utils == 2.10.0.0 , lens , lsp , lsp-test @@ -1802,11 +1786,10 @@ Ide.Plugin.Notes hs-source-dirs: plugins/hls-notes-plugin/src build-depends: - , base >=4.12 && <5 , array - , ghcide == 2.9.0.1 - , hls-graph == 2.9.0.1 - , hls-plugin-api == 2.9.0.1 + , ghcide == 2.10.0.0 + , hls-graph == 2.10.0.0 + , hls-plugin-api == 2.10.0.0 , lens , lsp >=2.7 , mtl >= 2.2 @@ -1830,10 +1813,9 @@ hs-source-dirs: plugins/hls-notes-plugin/test main-is: NotesTest.hs build-depends: - , base >=4.12 && <5 , filepath , haskell-language-server:hls-notes-plugin - , hls-test-utils == 2.9.0.1 + , hls-test-utils == 2.10.0.0 default-extensions: OverloadedStrings ---------------------------- @@ -1888,16 +1870,15 @@ hs-source-dirs: src build-depends: , aeson-pretty - , base >=4.16 && <5 , data-default , directory , extra , filepath , ghc - , ghcide == 2.9.0.1 + , ghcide == 2.10.0.0 , githash >=0.1.6.1 , hie-bios - , hls-plugin-api == 2.9.0.1 + , hls-plugin-api == 2.10.0.0 , optparse-applicative , optparse-simple , prettyprinter >= 1.7 @@ -1934,7 +1915,6 @@ ghc-options: -dynamic build-depends: - , base >=4.16 && <5 , haskell-language-server , hls-plugin-api , lsp @@ -1960,7 +1940,6 @@ "-with-rtsopts=-I0 -A128M" build-depends: - , base >=4.16 && <5 , data-default , directory , extra @@ -1991,11 +1970,9 @@ type: exitcode-stdio-1.0 build-tool-depends: haskell-language-server:haskell-language-server, - ghcide:ghcide-test-preprocessor build-depends: , aeson - , base >=4.16 && <5 , bytestring , containers , deepseq @@ -2004,7 +1981,7 @@ , ghcide:ghcide , hashable , hls-plugin-api - , hls-test-utils == 2.9.0.1 + , hls-test-utils == 2.10.0.0 , lens , lsp-test , lsp-types @@ -2032,9 +2009,9 @@ -- formatters if flag(floskell) && impl(ghc < 9.10) cpp-options: -Dhls_floskell - if flag(fourmolu) + if flag(fourmolu) && impl(ghc < 9.11) cpp-options: -Dhls_fourmolu - if flag(ormolu) + if flag(ormolu) && impl(ghc < 9.11) cpp-options: -Dhls_ormolu test-suite wrapper-test @@ -2047,9 +2024,8 @@ haskell-language-server:haskell-language-server build-depends: - , base >=4.16 && <5 , extra - , hls-test-utils == 2.9.0.1 + , hls-test-utils == 2.10.0.0 , process hs-source-dirs: test/wrapper @@ -2064,7 +2040,7 @@ hs-source-dirs: bench build-tool-depends: haskell-language-server:ghcide-bench, - hp2pretty:hp2pretty, + eventlog2html:eventlog2html, default-extensions: LambdaCase RecordWildCards @@ -2072,7 +2048,6 @@ build-depends: , aeson - , base >=4.16 && <5 , containers , data-default , directory @@ -2088,19 +2063,31 @@ , text , yaml +flag test-exe + description: Build the ghcide-test-preprocessor executable + default: True -test-suite ghcide-tests +executable ghcide-test-preprocessor import: warnings + default-language: GHC2021 + hs-source-dirs: ghcide-test/preprocessor + main-is: Main.hs + build-depends: base >=4 && <5 + + if !flag(test-exe) + buildable: False + +test-suite ghcide-tests + import: warnings, defaults type: exitcode-stdio-1.0 default-language: GHC2021 build-tool-depends: , ghcide:ghcide - , ghcide:ghcide-test-preprocessor + , haskell-language-server:ghcide-test-preprocessor , implicit-hie:gen-hie build-depends: , aeson - , base >=4.12 && <5 , containers , data-default , directory @@ -2133,12 +2120,12 @@ , text , text-rope , unordered-containers - , hls-test-utils == 2.9.0.1 + , hls-test-utils == 2.10.0.0 if impl(ghc <9.3) build-depends: ghc-typelits-knownnat - hs-source-dirs: ghcide/test/exe + hs-source-dirs: ghcide-test/exe ghc-options: -threaded -O0 main-is: Main.hs @@ -2155,6 +2142,7 @@ DiagnosticTests ExceptionTests FindDefinitionAndHoverTests + FindImplementationAndHoverTests FuzzySearch GarbageCollectionTests HaddockTests @@ -2171,6 +2159,7 @@ PreprocessorTests Progress ReferenceTests + ResolveTests RootUriTests SafeTests SymlinkTests @@ -2187,10 +2176,9 @@ executable ghcide-bench - default-language: GHC2021 + import: defaults build-depends: aeson, - base, bytestring, containers, data-default, @@ -2219,7 +2207,7 @@ ViewPatterns library ghcide-bench-lib - default-language: GHC2021 + import: defaults hs-source-dirs: ghcide-bench/src ghc-options: -Wall -Wno-name-shadowing exposed-modules: @@ -2228,7 +2216,6 @@ build-depends: aeson, async, - base == 4.*, binary, bytestring, deepseq, @@ -2255,8 +2242,8 @@ test-suite ghcide-bench-test + import: defaults type: exitcode-stdio-1.0 - default-language: GHC2021 build-tool-depends: ghcide:ghcide, main-is: Main.hs @@ -2264,7 +2251,6 @@ ghc-options: -Wunused-packages ghc-options: -threaded -Wall build-depends: - base, extra, haskell-language-server:ghcide-bench-lib, lsp-test ^>= 0.17, diff --git a/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/Literals.hs b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/Literals.hs --- a/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/Literals.hs +++ b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/Literals.hs @@ -68,13 +68,8 @@ HsInt _ val -> fromIntegralLit patSpan val HsRat _ val _ -> fromFractionalLit patSpan val _ -> Nothing -#if __GLASGOW_HASKELL__ == 902 - NPat _ (L (RealSrcSpan sSpan _) overLit) _ _ -> fromOverLit overLit sSpan - NPlusKPat _ _ (L (RealSrcSpan sSpan _) overLit1) _ _ _ -> fromOverLit overLit1 sSpan -#else NPat _ (L (locA -> (RealSrcSpan sSpan _)) overLit) _ _ -> fromOverLit overLit sSpan NPlusKPat _ _ (L (locA -> (RealSrcSpan sSpan _)) overLit1) _ _ _ -> fromOverLit overLit1 sSpan -#endif _ -> Nothing getPattern _ = Nothing diff --git a/plugins/hls-cabal-fmt-plugin/src/Ide/Plugin/CabalFmt.hs b/plugins/hls-cabal-fmt-plugin/src/Ide/Plugin/CabalFmt.hs --- a/plugins/hls-cabal-fmt-plugin/src/Ide/Plugin/CabalFmt.hs +++ b/plugins/hls-cabal-fmt-plugin/src/Ide/Plugin/CabalFmt.hs @@ -6,22 +6,23 @@ module Ide.Plugin.CabalFmt where import Control.Lens -import Control.Monad.Except (throwError) +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 qualified Data.Text as T +import Development.IDE hiding (pluginHandlers) +import Development.IDE.Core.PluginUtils (mkFormattingHandlers) +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 +import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Types -import Prelude hiding (log) +import Prelude hiding (log) import System.Directory import System.Exit import System.FilePath import System.Process.ListLike -import qualified System.Process.Text as Process +import qualified System.Process.Text as Process data Log = LogProcessInvocationFailure Int @@ -64,7 +65,7 @@ throwError $ PluginInvalidParams "You cannot format a text-range using cabal-fmt." provider recorder plId ideState _ FormatText contents nfp opts = do let cabalFmtArgs = [ "--indent", show tabularSize] - cabalFmtExePath <- fmap T.unpack $ liftIO $ runAction "cabal-gild" ideState $ usePropertyAction #path plId properties + cabalFmtExePath <- fmap T.unpack $ liftIO $ runAction "cabal-fmt" ideState $ usePropertyAction #path plId properties x <- liftIO $ findExecutable cabalFmtExePath case x of Just _ -> do @@ -85,7 +86,7 @@ pure $ InL fmtDiff Nothing -> do 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") + throwError (PluginInternalError "No installation of cabal-fmt could be found. Please install it globally, or provide the full path to the executable") where fp = fromNormalizedFilePath nfp tabularSize = opts ^. L.tabSize diff --git a/plugins/hls-cabal-fmt-plugin/test/Main.hs b/plugins/hls-cabal-fmt-plugin/test/Main.hs --- a/plugins/hls-cabal-fmt-plugin/test/Main.hs +++ b/plugins/hls-cabal-fmt-plugin/test/Main.hs @@ -1,14 +1,26 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Main ( main ) where +import Ide.Logger +import qualified Ide.Plugin.Cabal as Cabal import qualified Ide.Plugin.CabalFmt as CabalFmt import System.Directory (findExecutable) import System.FilePath import Test.Hls +data TestLog + = LogCabalFmt CabalFmt.Log + | LogCabal Cabal.Log + +instance Pretty TestLog where + pretty = \case + LogCabalFmt msg -> pretty msg + LogCabal msg -> pretty msg + data CabalFmtFound = Found | NotFound isTestIsolated :: Bool @@ -30,8 +42,11 @@ foundCabalFmt <- isCabalFmtFound defaultTestRunner (tests foundCabalFmt) -cabalFmtPlugin :: PluginTestDescriptor CabalFmt.Log -cabalFmtPlugin = mkPluginTestDescriptor CabalFmt.descriptor "cabal-fmt" +cabalFmtPlugin :: PluginTestDescriptor TestLog +cabalFmtPlugin = mconcat + [ mkPluginTestDescriptor (CabalFmt.descriptor . cmapWithPrio LogCabalFmt) "cabal-fmt" + , mkPluginTestDescriptor (Cabal.descriptor . cmapWithPrio LogCabal) "cabal" + ] tests :: CabalFmtFound -> TestTree tests found = testGroup "cabal-fmt" @@ -39,8 +54,9 @@ cabalFmtGolden found "formats a simple document" "simple_testdata" "formatted_document" $ \doc -> do formatDoc doc (FormattingOptions 2 True Nothing Nothing Nothing) - , expectFailBecause "cabal-fmt can't expand modules if .cabal file is read from stdin. Tracking issue: https://github.com/phadej/cabal-fmt/pull/82" $ - cabalFmtGolden found "formats a document with expand:src comment" "commented_testdata" "formatted_document" $ \doc -> do + -- TODO: cabal-fmt can't expand modules if .cabal file is read from stdin. Tracking + -- issue: https://github.com/phadej/cabal-fmt/pull/82 + , cabalFmtGolden found "formats a document with expand:src comment" "commented_testdata" "formatted_document" $ \doc -> do formatDoc doc (FormattingOptions 2 True Nothing Nothing Nothing) , cabalFmtGolden found "formats a document with lib information" "lib_testdata" "formatted_document" $ \doc -> do diff --git a/plugins/hls-cabal-fmt-plugin/test/testdata/commented_testdata.formatted_document.cabal b/plugins/hls-cabal-fmt-plugin/test/testdata/commented_testdata.formatted_document.cabal --- a/plugins/hls-cabal-fmt-plugin/test/testdata/commented_testdata.formatted_document.cabal +++ b/plugins/hls-cabal-fmt-plugin/test/testdata/commented_testdata.formatted_document.cabal @@ -6,10 +6,7 @@ library -- cabal-fmt: expand src - exposed-modules: - MyLib - MyOtherLib - + exposed-modules: MyLib build-depends: base ^>=4.14.1.0 hs-source-dirs: src default-language: Haskell2010 diff --git a/plugins/hls-cabal-gild-plugin/src/Ide/Plugin/CabalGild.hs b/plugins/hls-cabal-gild-plugin/src/Ide/Plugin/CabalGild.hs --- a/plugins/hls-cabal-gild-plugin/src/Ide/Plugin/CabalGild.hs +++ b/plugins/hls-cabal-gild-plugin/src/Ide/Plugin/CabalGild.hs @@ -5,21 +5,22 @@ module Ide.Plugin.CabalGild where -import Control.Monad.Except (throwError) +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 qualified Data.Text as T +import Development.IDE hiding (pluginHandlers) +import Development.IDE.Core.PluginUtils (mkFormattingHandlers) +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 Prelude hiding (log) import System.Directory import System.Exit import System.FilePath import System.Process.ListLike -import qualified System.Process.Text as Process +import qualified System.Process.Text as Process data Log = LogProcessInvocationFailure Int T.Text diff --git a/plugins/hls-cabal-gild-plugin/test/Main.hs b/plugins/hls-cabal-gild-plugin/test/Main.hs --- a/plugins/hls-cabal-gild-plugin/test/Main.hs +++ b/plugins/hls-cabal-gild-plugin/test/Main.hs @@ -1,14 +1,26 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Main ( main ) where +import Ide.Logger +import qualified Ide.Plugin.Cabal as Cabal import qualified Ide.Plugin.CabalGild as CabalGild import System.Directory (findExecutable) import System.FilePath import Test.Hls +data TestLog + = LogCabalGild CabalGild.Log + | LogCabal Cabal.Log + +instance Pretty TestLog where + pretty = \case + LogCabalGild msg -> pretty msg + LogCabal msg -> pretty msg + data CabalGildFound = Found | NotFound isTestIsolated :: Bool @@ -30,8 +42,11 @@ foundCabalFmt <- isCabalFmtFound defaultTestRunner (tests foundCabalFmt) -cabalGildPlugin :: PluginTestDescriptor CabalGild.Log -cabalGildPlugin = mkPluginTestDescriptor CabalGild.descriptor "cabal-gild" +cabalGildPlugin :: PluginTestDescriptor TestLog +cabalGildPlugin = mconcat + [ mkPluginTestDescriptor (CabalGild.descriptor . cmapWithPrio LogCabalGild) "cabal-gild" + , mkPluginTestDescriptor (Cabal.descriptor . cmapWithPrio LogCabal) "cabal" + ] tests :: CabalGildFound -> TestTree tests found = testGroup "cabal-gild" diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs @@ -4,46 +4,70 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} -module Ide.Plugin.Cabal (descriptor, Log (..)) where +module Ide.Plugin.Cabal (descriptor, haskellInteractionDescriptor, Log (..)) where import Control.Concurrent.Strict import Control.DeepSeq -import Control.Lens ((^.)) +import Control.Lens ((^.)) import Control.Monad.Extra import Control.Monad.IO.Class -import Control.Monad.Trans.Class -import Control.Monad.Trans.Maybe (runMaybeT) -import qualified Data.ByteString as BS +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Maybe (runMaybeT) +import qualified Data.ByteString as BS import Data.Hashable -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import qualified Data.List.NonEmpty as NE -import qualified Data.Text.Encoding as Encoding -import Data.Typeable -import Development.IDE as D -import Development.IDE.Core.Shake (restartShakeSession) -import qualified Development.IDE.Core.Shake as Shake -import Development.IDE.Graph (Key, alwaysRerun) -import qualified Development.IDE.Plugin.Completions.Logic as Ghcide -import qualified Development.IDE.Plugin.Completions.Types as Ghcide -import Development.IDE.Types.Shake (toKey) -import qualified Distribution.Fields as Syntax -import qualified Distribution.Parsec.Position as Syntax +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import qualified Data.List as List +import qualified Data.List.NonEmpty as NE +import qualified Data.Maybe as Maybe +import Data.Proxy +import qualified Data.Text () +import qualified Data.Text as T +import qualified Data.Text.Encoding as Encoding +import Data.Text.Utf16.Rope.Mixed as Rope +import Development.IDE as D +import Development.IDE.Core.FileStore (getVersionedTextDoc) +import Development.IDE.Core.PluginUtils +import Development.IDE.Core.Shake (restartShakeSession) +import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.Graph (Key, + alwaysRerun) +import Development.IDE.LSP.HoverDefinition (foundHover) +import qualified Development.IDE.Plugin.Completions.Logic as Ghcide +import Development.IDE.Types.Shake (toKey) +import qualified Distribution.CabalSpecVersion as Cabal +import qualified Distribution.Fields as Syntax +import Distribution.Package (Dependency) +import Distribution.PackageDescription (allBuildDepends, + depPkgName, + unPackageName) +import Distribution.PackageDescription.Configuration (flattenPackageDescription) +import Distribution.Parsec.Error +import qualified Distribution.Parsec.Position as Syntax import GHC.Generics -import qualified Ide.Plugin.Cabal.Completion.Completer.Types as CompleterTypes -import qualified Ide.Plugin.Cabal.Completion.Completions as Completions -import Ide.Plugin.Cabal.Completion.Types (ParseCabalFields (..), - ParseCabalFile (..)) -import qualified Ide.Plugin.Cabal.Completion.Types as Types -import qualified Ide.Plugin.Cabal.Diagnostics as Diagnostics -import qualified Ide.Plugin.Cabal.LicenseSuggest as LicenseSuggest -import Ide.Plugin.Cabal.Orphans () -import qualified Ide.Plugin.Cabal.Parse as Parse +import qualified Ide.Plugin.Cabal.CabalAdd as CabalAdd +import Ide.Plugin.Cabal.Completion.CabalFields as CabalFields +import qualified Ide.Plugin.Cabal.Completion.Completer.Types as CompleterTypes +import qualified Ide.Plugin.Cabal.Completion.Completions as Completions +import qualified Ide.Plugin.Cabal.Completion.Data as Data +import Ide.Plugin.Cabal.Completion.Types (ParseCabalCommonSections (ParseCabalCommonSections), + ParseCabalFields (..), + ParseCabalFile (..)) +import qualified Ide.Plugin.Cabal.Completion.Types as Types +import Ide.Plugin.Cabal.Definition (gotoDefinition) +import qualified Ide.Plugin.Cabal.Diagnostics as Diagnostics +import qualified Ide.Plugin.Cabal.FieldSuggest as FieldSuggest +import qualified Ide.Plugin.Cabal.LicenseSuggest as LicenseSuggest +import Ide.Plugin.Cabal.Orphans () +import Ide.Plugin.Cabal.Outline +import qualified Ide.Plugin.Cabal.Parse as Parse +import Ide.Plugin.Error import Ide.Types -import qualified Language.LSP.Protocol.Lens as JL -import qualified Language.LSP.Protocol.Message as LSP +import qualified Language.LSP.Protocol.Lens as JL +import qualified Language.LSP.Protocol.Message as LSP import Language.LSP.Protocol.Types -import qualified Language.LSP.VFS as VFS +import qualified Language.LSP.VFS as VFS +import Text.Regex.TDFA data Log = LogModificationTime NormalizedFilePath FileVersion @@ -55,6 +79,7 @@ | LogFOI (HashMap NormalizedFilePath FileOfInterestStatus) | LogCompletionContext Types.Context Position | LogCompletions Types.Log + | LogCabalAdd CabalAdd.Log deriving (Show) instance Pretty Log where @@ -78,7 +103,26 @@ <+> "for cursor position:" <+> pretty position LogCompletions logs -> pretty logs + LogCabalAdd logs -> pretty logs +-- | Some actions with cabal files originate from haskell files. +-- This descriptor allows to hook into the diagnostics of haskell source files, and +-- allows us to provide code actions and commands that interact with `.cabal` files. +haskellInteractionDescriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState +haskellInteractionDescriptor recorder plId = + (defaultPluginDescriptor plId "Provides the cabal-add code action in haskell files") + { pluginHandlers = + mconcat + [ mkPluginHandler LSP.SMethod_TextDocumentCodeAction cabalAddCodeAction + ] + , pluginCommands = [PluginCommand CabalAdd.cabalAddCommand "add a dependency to a cabal file" (CabalAdd.command cabalAddRecorder)] + , pluginRules = pure () + , pluginNotificationHandlers = mempty + } + where + cabalAddRecorder = cmapWithPrio LogCabalAdd recorder + + descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultCabalPluginDescriptor plId "Provides a variety of IDE features in cabal files") @@ -87,6 +131,10 @@ mconcat [ mkPluginHandler LSP.SMethod_TextDocumentCodeAction licenseSuggestCodeAction , mkPluginHandler LSP.SMethod_TextDocumentCompletion $ completion recorder + , mkPluginHandler LSP.SMethod_TextDocumentDocumentSymbol moduleOutline + , mkPluginHandler LSP.SMethod_TextDocumentCodeAction $ fieldSuggestCodeAction recorder + , mkPluginHandler LSP.SMethod_TextDocumentDefinition gotoDefinition + , mkPluginHandler LSP.SMethod_TextDocumentHover hover ] , pluginNotificationHandlers = mconcat @@ -160,7 +208,7 @@ log' Debug $ LogModificationTime file t contents <- case mCabalSource of Just sources -> - pure $ Encoding.encodeUtf8 sources + pure $ Encoding.encodeUtf8 $ Rope.toText sources Nothing -> do liftIO $ BS.readFile $ fromNormalizedFilePath file @@ -170,6 +218,14 @@ Right fields -> pure ([], Just fields) + define (cmapWithPrio LogShake recorder) $ \ParseCabalCommonSections file -> do + fields <- use_ ParseCabalFields file + let commonSections = Maybe.mapMaybe (\case + commonSection@(Syntax.Section (Syntax.Name _ "common") _ _) -> Just commonSection + _ -> Nothing) + fields + pure ([], Just commonSections) + define (cmapWithPrio LogShake recorder) $ \ParseCabalFile file -> do config <- getPluginConfigAction plId if not (plcGlobalOn config && plcDiagnosticsOn config) @@ -181,7 +237,7 @@ log' Debug $ LogModificationTime file t contents <- case mCabalSource of Just sources -> - pure $ Encoding.encodeUtf8 sources + pure $ Encoding.encodeUtf8 $ Rope.toText sources Nothing -> do liftIO $ BS.readFile $ fromNormalizedFilePath file @@ -193,7 +249,38 @@ let warningDiags = fmap (Diagnostics.warningDiagnostic file) pWarnings case pm of Left (_cabalVersion, pErrorNE) -> do - let errorDiags = NE.toList $ NE.map (Diagnostics.errorDiagnostic file) pErrorNE + let regexUnknownCabalBefore310 :: T.Text + -- We don't support the cabal version, this should not be an error, as the + -- user did not do anything wrong. Instead we cast it to a warning + regexUnknownCabalBefore310 = "Unsupported cabal-version [0-9]+.[0-9]*" + regexUnknownCabalVersion :: T.Text + regexUnknownCabalVersion = "Unsupported cabal format version in cabal-version field: [0-9]+.[0-9]+" + unsupportedCabalHelpText = unlines + [ "The used `cabal-version` is not fully supported by this `HLS` binary." + , "Either the `cabal-version` is unknown, or too new for this executable." + , "This means that some functionality might not work as expected." + , "If you face any issues, try downgrading to a supported `cabal-version` or upgrading `HLS` if possible." + , "" + , "Supported versions are: " <> + List.intercalate ", " + (fmap Cabal.showCabalSpecVersion Data.supportedCabalVersions) + ] + errorDiags = + NE.toList $ + NE.map + ( \pe@(PError pos text) -> + if any (text =~) + [ regexUnknownCabalBefore310 + , regexUnknownCabalVersion + ] + then Diagnostics.warningDiagnostic file (Syntax.PWarning Syntax.PWTOther pos $ + unlines + [ text + , unsupportedCabalHelpText + ]) + else Diagnostics.errorDiagnostic file pe + ) + pErrorNE allDiags = errorDiags <> warningDiags pure (allDiags, Nothing) Right gpd -> do @@ -217,7 +304,7 @@ kick :: Action () kick = do files <- HashMap.keys <$> getCabalFilesOfInterestUntracked - void $ uses Types.ParseCabalFile files + Shake.runWithSignal (Proxy @"kick/start/cabal") (Proxy @"kick/done/cabal") files Types.ParseCabalFile -- ---------------------------------------------------------------- -- Code Actions @@ -228,6 +315,117 @@ maxCompls <- fmap maxCompletions . liftIO $ runAction "cabal-plugin.suggestLicense" ideState getClientConfigAction pure $ InL $ diags >>= (fmap InR . LicenseSuggest.licenseErrorAction maxCompls uri) +-- | CodeActions for correcting field names with typos in them. +-- +-- Provides CodeActions that fix typos in both stanzas and top-level field names. +-- The suggestions are computed based on the completion context, where we "move" a fake cursor +-- to the end of the field name and trigger cabal file completions. The completions are then +-- suggested to the user. +-- +-- TODO: Relying on completions here often does not produce the desired results, we should +-- use some sort of fuzzy matching in the future, see issue #4357. +fieldSuggestCodeAction :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction +fieldSuggestCodeAction recorder ide _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _ CodeActionContext{_diagnostics=diags}) = do + mContents <- liftIO $ runAction "cabal-plugin.getUriContents" ide $ getUriContents $ toNormalizedUri uri + case (,) <$> mContents <*> uriToFilePath' uri of + Nothing -> pure $ InL [] + Just (fileContents, path) -> do + -- We decide on `useWithStale` here, since `useWithStaleFast` often leads to the wrong completions being suggested. + -- In case it fails, we still will get some completion results instead of an error. + mFields <- liftIO $ runAction "cabal-plugin.fields" ide $ useWithStale ParseCabalFields $ toNormalizedFilePath path + case mFields of + Nothing -> + pure $ InL [] + Just (cabalFields, _) -> do + let fields = Maybe.mapMaybe FieldSuggest.fieldErrorName diags + results <- forM fields (getSuggestion fileContents path cabalFields) + pure $ InL $ map InR $ concat results + where + getSuggestion fileContents fp cabalFields (fieldName,Diagnostic{ _range=_range@(Range (Position lineNr col) _) }) = do + let -- Compute where we would anticipate the cursor to be. + fakeLspCursorPosition = Position lineNr (col + fromIntegral (T.length fieldName)) + lspPrefixInfo = Ghcide.getCompletionPrefixFromRope fakeLspCursorPosition fileContents + cabalPrefixInfo = Completions.getCabalPrefixInfo fp lspPrefixInfo + completions <- liftIO $ computeCompletionsAt recorder ide cabalPrefixInfo fp cabalFields + let completionTexts = fmap (^. JL.label) completions + pure $ FieldSuggest.fieldErrorAction uri fieldName completionTexts _range + +cabalAddCodeAction :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction +cabalAddCodeAction state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) _ CodeActionContext{_diagnostics=diags}) = do + maxCompls <- fmap maxCompletions . liftIO $ runAction "cabal.cabal-add" state getClientConfigAction + let suggestions = take maxCompls $ concatMap CabalAdd.hiddenPackageSuggestion diags + case suggestions of + [] -> pure $ InL [] + _ -> + case uriToFilePath uri of + Nothing -> pure $ InL [] + Just haskellFilePath -> do + mbCabalFile <- liftIO $ CabalAdd.findResponsibleCabalFile haskellFilePath + case mbCabalFile of + Nothing -> pure $ InL [] + Just cabalFilePath -> do + verTxtDocId <- runActionE "cabalAdd.getVersionedTextDoc" state $ + lift $ getVersionedTextDoc $ TextDocumentIdentifier (filePathToUri cabalFilePath) + mbGPD <- liftIO $ runAction "cabal.cabal-add" state $ useWithStale ParseCabalFile $ toNormalizedFilePath cabalFilePath + case mbGPD of + Nothing -> pure $ InL [] + Just (gpd, _) -> do + actions <- liftIO $ CabalAdd.addDependencySuggestCodeAction plId verTxtDocId + suggestions + haskellFilePath cabalFilePath + gpd + pure $ InL $ fmap InR actions + +-- | Handler for hover messages. +-- +-- Provides a Handler for displaying message on hover. +-- If found that the filtered hover message is a dependency, +-- adds a Documentation link. +hover :: PluginMethodHandler IdeState LSP.Method_TextDocumentHover +hover ide _ msgParam = do + nfp <- getNormalizedFilePathE uri + cabalFields <- runActionE "cabal.cabal-hover" ide $ useE ParseCabalFields nfp + case CabalFields.findTextWord cursor cabalFields of + Nothing -> + pure $ InR Null + Just cursorText -> do + gpd <- runActionE "cabal.GPD" ide $ useE ParseCabalFile nfp + let depsNames = map dependencyName $ allBuildDepends $ flattenPackageDescription gpd + case filterVersion cursorText of + Nothing -> pure $ InR Null + Just txt -> + if txt `elem` depsNames + then pure $ foundHover (Nothing, [txt <> "\n", documentationText txt]) + else pure $ InR Null + where + cursor = Types.lspPositionToCabalPosition (msgParam ^. JL.position) + uri = msgParam ^. JL.textDocument . JL.uri + + dependencyName :: Dependency -> T.Text + dependencyName dep = T.pack $ unPackageName $ depPkgName dep + + -- | Removes version requirements like + -- `==1.0.0.0`, `>= 2.1.1` that could be included in + -- hover message. Assumes that the dependency consists + -- of alphanums with dashes in between. Ends with an alphanum. + -- + -- Examples: + -- >>> filterVersion "imp-deps>=2.1.1" + -- "imp-deps" + filterVersion :: T.Text -> Maybe T.Text + filterVersion msg = getMatch (msg =~ regex) + where + regex :: T.Text + regex = "([a-zA-Z0-9-]*[a-zA-Z0-9])" + + getMatch :: (T.Text, T.Text, T.Text, [T.Text]) -> Maybe T.Text + getMatch (_, _, _, [dependency]) = Just dependency + getMatch (_, _, _, _) = Nothing -- impossible case + + documentationText :: T.Text -> T.Text + documentationText package = "[Documentation](https://hackage.haskell.org/package/" <> package <> ")" + + -- ---------------------------------------------------------------- -- Cabal file of Interest rules and global variable -- ---------------------------------------------------------------- @@ -244,14 +442,14 @@ instance Shake.IsIdeGlobal OfInterestCabalVar data IsCabalFileOfInterest = IsCabalFileOfInterest - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable IsCabalFileOfInterest instance NFData IsCabalFileOfInterest type instance RuleResult IsCabalFileOfInterest = CabalFileOfInterestResult data CabalFileOfInterestResult = NotCabalFOI | IsCabalFOI FileOfInterestStatus - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable CabalFileOfInterestResult instance NFData CabalFileOfInterestResult @@ -309,10 +507,10 @@ completion :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'LSP.Method_TextDocumentCompletion completion recorder ide _ complParams = do - let (TextDocumentIdentifier uri) = complParams ^. JL.textDocument + let TextDocumentIdentifier uri = complParams ^. JL.textDocument position = complParams ^. JL.position - mVf <- lift $ pluginGetVirtualFile $ toNormalizedUri uri - case (,) <$> mVf <*> uriToFilePath' uri of + mContents <- liftIO $ runAction "cabal-plugin.getUriContents" ide $ getUriContents $ toNormalizedUri uri + case (,) <$> mContents <*> uriToFilePath' uri of Just (cnts, path) -> do -- We decide on `useWithStale` here, since `useWithStaleFast` often leads to the wrong completions being suggested. -- In case it fails, we still will get some completion results instead of an error. @@ -321,36 +519,36 @@ Nothing -> pure . InR $ InR Null Just (fields, _) -> do - let pref = Ghcide.getCompletionPrefix position cnts - let res = produceCompletions pref path fields + let lspPrefInfo = Ghcide.getCompletionPrefixFromRope position cnts + cabalPrefInfo = Completions.getCabalPrefixInfo path lspPrefInfo + let res = computeCompletionsAt recorder ide cabalPrefInfo path fields liftIO $ fmap InL res Nothing -> pure . InR $ InR Null - where - completerRecorder = cmapWithPrio LogCompletions recorder - produceCompletions :: Ghcide.PosPrefixInfo -> FilePath -> [Syntax.Field Syntax.Position] -> IO [CompletionItem] - produceCompletions prefix fp fields = do - runMaybeT (context fields) >>= \case - Nothing -> pure [] - Just ctx -> do - logWith recorder Debug $ LogCompletionContext ctx pos - let completer = Completions.contextToCompleter ctx - let completerData = CompleterTypes.CompleterData - { getLatestGPD = do - -- We decide on useWithStaleFast here, since we mostly care about the file's meta information, - -- thus, a quick response gives us the desired result most of the time. - -- The `withStale` option is very important here, since we often call this rule with invalid cabal files. - mGPD <- runIdeAction "cabal-plugin.modulesCompleter.gpd" (shakeExtras ide) $ useWithStaleFast ParseCabalFile $ toNormalizedFilePath fp - pure $ fmap fst mGPD - , cabalPrefixInfo = prefInfo - , stanzaName = - case fst ctx of - Types.Stanza _ name -> name - _ -> Nothing - } - completions <- completer completerRecorder completerData - pure completions - where - pos = Ghcide.cursorPos prefix +computeCompletionsAt :: Recorder (WithPriority Log) -> IdeState -> Types.CabalPrefixInfo -> FilePath -> [Syntax.Field Syntax.Position] -> IO [CompletionItem] +computeCompletionsAt recorder ide prefInfo fp fields = do + runMaybeT (context fields) >>= \case + Nothing -> pure [] + Just ctx -> do + logWith recorder Debug $ LogCompletionContext ctx pos + let completer = Completions.contextToCompleter ctx + let completerData = CompleterTypes.CompleterData + { getLatestGPD = do + -- We decide on useWithStaleFast here, since we mostly care about the file's meta information, + -- thus, a quick response gives us the desired result most of the time. + -- The `withStale` option is very important here, since we often call this rule with invalid cabal files. + mGPD <- runAction "cabal-plugin.modulesCompleter.gpd" ide $ useWithStale ParseCabalFile $ toNormalizedFilePath fp + pure $ fmap fst mGPD + , getCabalCommonSections = runAction "cabal-plugin.commonSections" ide $ use ParseCabalCommonSections $ toNormalizedFilePath fp + , cabalPrefixInfo = prefInfo + , stanzaName = + case fst ctx of + Types.Stanza _ name -> name + _ -> Nothing + } + completions <- completer completerRecorder completerData + pure completions + where + pos = Types.completionCursorPosition prefInfo context fields = Completions.getContext completerRecorder prefInfo fields - prefInfo = Completions.getCabalPrefixInfo fp prefix + completerRecorder = cmapWithPrio LogCompletions recorder diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/CabalAdd.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/CabalAdd.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/CabalAdd.hs @@ -0,0 +1,315 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RecordWildCards #-} + +module Ide.Plugin.Cabal.CabalAdd +( findResponsibleCabalFile + , addDependencySuggestCodeAction + , hiddenPackageSuggestion + , cabalAddCommand + , command + , Log +) +where + +import Control.Monad (filterM, void) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except +import Data.Aeson.Types (FromJSON, + ToJSON, toJSON) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.List.NonEmpty (NonEmpty (..), + fromList) +import Data.String (IsString) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import qualified Data.Text.Encoding as T +import Data.Text.Utf16.Rope.Mixed as Rope +import Development.IDE (IdeState, + getFileContents, + useWithStale) +import Development.IDE.Core.Rules (runAction) +import Distribution.Client.Add as Add +import Distribution.Compat.Prelude (Generic) +import Distribution.PackageDescription (GenericPackageDescription, + packageDescription, + specVersion) +import Distribution.PackageDescription.Configuration (flattenPackageDescription) +import Distribution.PackageDescription.Quirks (patchQuirks) +import qualified Distribution.Pretty as Pretty +import Distribution.Simple.BuildTarget (BuildTarget, + buildTargetComponentName, + readBuildTargets) +import Distribution.Simple.Utils (safeHead) +import Distribution.Verbosity (silent, + verboseNoStderr) +import Ide.Logger +import Ide.Plugin.Cabal.Completion.Types (ParseCabalFields (..), + ParseCabalFile (..)) +import Ide.Plugin.Cabal.Orphans () +import Ide.Plugin.Error +import Ide.PluginUtils (WithDeletions (SkipDeletions), + diffText, + mkLspCommand) +import Ide.Types (CommandFunction, + CommandId (CommandId), + PluginId, + pluginGetClientCapabilities, + pluginSendRequest) +import Language.LSP.Protocol.Message (SMethod (SMethod_WorkspaceApplyEdit)) +import Language.LSP.Protocol.Types (ApplyWorkspaceEditParams (ApplyWorkspaceEditParams), + ClientCapabilities, + CodeAction (CodeAction), + CodeActionKind (CodeActionKind_QuickFix), + Diagnostic (..), + Null (Null), + VersionedTextDocumentIdentifier, + WorkspaceEdit, + toNormalizedFilePath, + type (|?) (InR)) +import System.Directory (doesFileExist, + listDirectory) +import System.FilePath (dropFileName, + makeRelative, + splitPath, + takeExtension, + ()) +import Text.PrettyPrint (render) +import Text.Regex.TDFA + +data Log + = LogFoundResponsibleCabalFile FilePath + | LogCalledCabalAddCommand CabalAddCommandParams + | LogCreatedEdit WorkspaceEdit + | LogExecutedCommand + deriving (Show) + +instance Pretty Log where + pretty = \case + LogFoundResponsibleCabalFile fp -> "Located the responsible cabal file at " <+> pretty fp + LogCalledCabalAddCommand params -> "Called CabalAdd command with:\n" <+> pretty params + LogCreatedEdit edit -> "Created inplace edit:\n" <+> pretty edit + LogExecutedCommand -> "Executed CabalAdd command" + +cabalAddCommand :: IsString p => p +cabalAddCommand = "cabalAdd" + +data CabalAddCommandParams = + CabalAddCommandParams { cabalPath :: FilePath + , verTxtDocId :: VersionedTextDocumentIdentifier + , buildTarget :: Maybe String + , dependency :: T.Text + , version :: Maybe T.Text + } + deriving (Generic, Show) + deriving anyclass (FromJSON, ToJSON) + +instance Pretty CabalAddCommandParams where + pretty CabalAddCommandParams{..} = + "CabalAdd parameters:" <+> vcat + [ "cabal path:" <+> pretty cabalPath + , "target:" <+> pretty buildTarget + , "dependendency:" <+> pretty dependency + , "version:" <+> pretty version + ] + +-- | Creates a code action that calls the `cabalAddCommand`, +-- using dependency-version suggestion pairs as input. +-- +-- Returns disabled action if no cabal files given. +-- +-- Takes haskell file and cabal file paths to create a relative path +-- to the haskell file, which is used to get a `BuildTarget`. +-- +-- In current implementation the dependency is being added to the main found +-- build target, but if there will be a way to get all build targets from a file +-- it will be possible to support addition to a build target of choice. +addDependencySuggestCodeAction + :: PluginId + -> VersionedTextDocumentIdentifier -- ^ Cabal's versioned text identifier + -> [(T.Text, T.Text)] -- ^ A dependency-version suggestion pairs + -> FilePath -- ^ Path to the haskell file (source of diagnostics) + -> FilePath -- ^ Path to the cabal file (that will be edited) + -> GenericPackageDescription + -> IO [CodeAction] +addDependencySuggestCodeAction plId verTxtDocId suggestions haskellFilePath cabalFilePath gpd = do + buildTargets <- liftIO $ getBuildTargets gpd cabalFilePath haskellFilePath + case buildTargets of + -- If there are no build targets found, run `cabal-add` command with default behaviour + [] -> pure $ mkCodeAction cabalFilePath Nothing <$> suggestions + -- Otherwise provide actions for all found targets + targets -> pure $ concat [mkCodeAction cabalFilePath (Just $ buildTargetToStringRepr target) <$> + suggestions | target <- targets] + where + -- | Note the use of `pretty` function. + -- It converts the `BuildTarget` to an acceptable string representation. + -- It will be used in as the input for `cabal-add`'s `executeConfig`. + buildTargetToStringRepr target = render $ Pretty.pretty $ buildTargetComponentName target + + -- | Gives the build targets that are used in the `CabalAdd`. + -- Note the unorthodox usage of `readBuildTargets`: + -- If the relative path to the haskell file is provided, + -- the `readBuildTargets` will return build targets, where this + -- module is mentioned (in exposed-modules or other-modules). + getBuildTargets :: GenericPackageDescription -> FilePath -> FilePath -> IO [BuildTarget] + getBuildTargets gpd cabalFilePath haskellFilePath = do + let haskellFileRelativePath = makeRelative (dropFileName cabalFilePath) haskellFilePath + readBuildTargets (verboseNoStderr silent) (flattenPackageDescription gpd) [haskellFileRelativePath] + + mkCodeAction :: FilePath -> Maybe String -> (T.Text, T.Text) -> CodeAction + mkCodeAction cabalFilePath target (suggestedDep, suggestedVersion) = + let + versionTitle = if T.null suggestedVersion then T.empty else "-" <> suggestedVersion + targetTitle = case target of + Nothing -> T.empty + Just t -> " at " <> T.pack t + title = "Add dependency " <> suggestedDep <> versionTitle <> targetTitle + version = if T.null suggestedVersion then Nothing else Just suggestedVersion + + params = CabalAddCommandParams {cabalPath = cabalFilePath + , verTxtDocId = verTxtDocId + , buildTarget = target + , dependency = suggestedDep + , version=version} + command = mkLspCommand plId (CommandId cabalAddCommand) "Add missing dependency" (Just [toJSON params]) + in CodeAction title (Just CodeActionKind_QuickFix) (Just []) Nothing Nothing Nothing (Just command) Nothing + +-- | Gives a mentioned number of @(dependency, version)@ pairs +-- found in the "hidden package" diagnostic message. +-- +-- For example, if a ghc error looks like this: +-- +-- > "Could not load module ‘Data.List.Split’ +-- > It is a member of the hidden package ‘split-0.2.5’. +-- > Perhaps you need to add ‘split’ to the build-depends in your .cabal file." +-- +-- It extracts mentioned package names and version numbers. +-- In this example, it will be @[("split", "0.2.5")]@ +-- +-- Also supports messages without a version. +-- +-- > "Perhaps you need to add ‘split’ to the build-depends in your .cabal file." +-- +-- Will turn into @[("split", "")]@ +hiddenPackageSuggestion :: Diagnostic -> [(T.Text, T.Text)] +hiddenPackageSuggestion diag = getMatch (msg =~ regex) + where + msg :: T.Text + msg = _message diag + regex :: T.Text -- TODO: Support multiple packages suggestion + regex = "It is a member of the hidden package [\8216']([a-zA-Z0-9-]*[a-zA-Z0-9])(-([0-9\\.]*))?[\8217']" + -- Have to do this matching because `Regex.TDFA` doesn't(?) support + -- not-capturing groups like (?:message) + getMatch :: (T.Text, T.Text, T.Text, [T.Text]) -> [(T.Text, T.Text)] + getMatch (_, _, _, []) = [] + getMatch (_, _, _, [dependency, _, cleanVersion]) = [(dependency, cleanVersion)] + getMatch (_, _, _, _) = error "Impossible pattern matching case" + +command :: Recorder (WithPriority Log) -> CommandFunction IdeState CabalAddCommandParams +command recorder state _ params@(CabalAddCommandParams {cabalPath = path, verTxtDocId = verTxtDocId, buildTarget = target, dependency = dep, version = mbVer}) = do + logWith recorder Debug $ LogCalledCabalAddCommand params + let specifiedDep = case mbVer of + Nothing -> dep + Just ver -> dep <> " ^>=" <> ver + caps <- lift pluginGetClientCapabilities + let env = (state, caps, verTxtDocId) + edit <- getDependencyEdit recorder env path target (fromList [T.unpack specifiedDep]) + void $ lift $ pluginSendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) + logWith recorder Debug LogExecutedCommand + pure $ InR Null + +-- | Constructs prerequisites for the @executeConfig@ +-- and runs it, given path to the cabal file and a dependency message. +-- Given the new contents of the cabal file constructs and returns the @edit@. +-- Inspired by @main@ in cabal-add, +-- Distribution.Client.Main +getDependencyEdit :: MonadIO m => Recorder (WithPriority Log) -> (IdeState, ClientCapabilities, VersionedTextDocumentIdentifier) -> + FilePath -> Maybe String -> NonEmpty String -> ExceptT PluginError m WorkspaceEdit +getDependencyEdit recorder env cabalFilePath buildTarget dependency = do + let (state, caps, verTxtDocId) = env + (mbCnfOrigContents, mbFields, mbPackDescr) <- liftIO $ runAction "cabal.cabal-add" state $ do + contents <- getFileContents $ toNormalizedFilePath cabalFilePath + inFields <- useWithStale ParseCabalFields $ toNormalizedFilePath cabalFilePath + inPackDescr <- useWithStale ParseCabalFile $ toNormalizedFilePath cabalFilePath + let mbCnfOrigContents = case contents of + (Just txt) -> Just $ encodeUtf8 $ Rope.toText txt + _ -> Nothing + let mbFields = fst <$> inFields + let mbPackDescr = fst <$> inPackDescr + pure (mbCnfOrigContents, mbFields, mbPackDescr) + + -- Check if required info was received, + -- otherwise fall back on other options. + (cnfOrigContents, fields, packDescr) <- do + cnfOrigContents <- case mbCnfOrigContents of + (Just cnfOrigContents) -> pure cnfOrigContents + Nothing -> readCabalFile cabalFilePath + (fields, packDescr) <- case (mbFields, mbPackDescr) of + (Just fields, Just packDescr) -> pure (fields, packDescr) + (_, _) -> case parseCabalFile cabalFilePath cnfOrigContents of + Left err -> throwE $ PluginInternalError $ T.pack err + Right (f ,gpd) -> pure (f, gpd) + pure (cnfOrigContents, fields, packDescr) + + let inputs = do + let rcnfComponent = buildTarget + let specVer = specVersion $ packageDescription packDescr + cmp <- resolveComponent cabalFilePath (fields, packDescr) rcnfComponent + deps <- traverse (validateDependency specVer) dependency + pure (fields, packDescr, cmp, deps) + + (cnfFields, origPackDescr, cnfComponent, cnfDependencies) <- case inputs of + Left err -> throwE $ PluginInternalError $ T.pack err + Right pair -> pure pair + + case executeConfig (validateChanges origPackDescr) (Config {..}) of + Nothing -> throwE $ PluginInternalError $ T.pack $ "Cannot extend build-depends in " ++ cabalFilePath + Just newContents -> do + let edit = diffText caps (verTxtDocId, T.decodeUtf8 cnfOrigContents) (T.decodeUtf8 newContents) SkipDeletions + logWith recorder Debug $ LogCreatedEdit edit + pure edit + +-- | Given a path to a haskell file, returns the closest cabal file. +-- If a package.yaml is present in same directory as the .cabal file, returns nothing, because adding a dependency to a generated cabal file +-- will break propagation of changes from package.yaml to cabal files in stack projects. +-- If cabal file wasn't found, gives Nothing. +findResponsibleCabalFile :: FilePath -> IO (Maybe FilePath) +findResponsibleCabalFile haskellFilePath = do + let dirPath = dropFileName haskellFilePath + allDirPaths = reverse $ scanl1 () (splitPath dirPath) -- sorted from most to least specific + go allDirPaths + where + go [] = pure Nothing + go (path:ps) = do + objects <- listDirectory path + let objectsWithPaths = map (\obj -> path <> obj) objects + objectsCabalExtension = filter (\c -> takeExtension c == ".cabal") objectsWithPaths + cabalFiles <- filterM (\c -> doesFileExist c) objectsCabalExtension + case safeHead cabalFiles of + Nothing -> go ps + Just cabalFile -> guardAgainstHpack path cabalFile + where + guardAgainstHpack :: FilePath -> FilePath -> IO (Maybe FilePath) + guardAgainstHpack path cabalFile = do + exists <- doesFileExist $ path "package.yaml" + if exists then pure Nothing else pure $ Just cabalFile + +-- | Gives cabal file's contents or throws error. +-- Inspired by @readCabalFile@ in cabal-add, +-- Distribution.Client.Main +-- +-- This is a fallback option! +-- Use only if the `GetFileContents` fails. +readCabalFile :: MonadIO m => FilePath -> ExceptT PluginError m ByteString +readCabalFile fileName = do + cabalFileExists <- liftIO $ doesFileExist fileName + if cabalFileExists + then snd . patchQuirks <$> liftIO (B.readFile fileName) + else throwE $ PluginInternalError $ T.pack ("Failed to read cabal file at " <> fileName) diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/CabalFields.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/CabalFields.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/CabalFields.hs @@ -0,0 +1,303 @@ +module Ide.Plugin.Cabal.Completion.CabalFields + ( findStanzaForColumn + , getModulesNames + , getFieldLSPRange + , findFieldSection + , findTextWord + , findFieldLine + , getOptionalSectionName + , getAnnotation + , getFieldName + , onelineSectionArgs + , getFieldEndPosition + , getSectionArgEndPosition + , getNameEndPosition + , getFieldLineEndPosition + ) + where + +import qualified Data.ByteString as BS +import Data.List (find) +import Data.List.Extra (groupSort) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NE +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Tuple (swap) +import qualified Distribution.Fields as Syntax +import qualified Distribution.Parsec.Position as Syntax +import Ide.Plugin.Cabal.Completion.Types +import qualified Language.LSP.Protocol.Types as LSP + +-- ---------------------------------------------------------------- +-- Cabal-syntax utilities I don't really want to write myself +-- ---------------------------------------------------------------- + +-- | Determine the context of a cursor position within a stack of stanza contexts +-- +-- If the cursor is indented more than one of the stanzas in the stack +-- the respective stanza is returned if this is never the case, the toplevel stanza +-- in the stack is returned. +findStanzaForColumn :: Int -> NonEmpty (Int, StanzaContext) -> (StanzaContext, FieldContext) +findStanzaForColumn col ctx = case NE.uncons ctx of + ((_, stanza), Nothing) -> (stanza, None) + ((indentation, stanza), Just res) + | col < indentation -> findStanzaForColumn col res + | otherwise -> (stanza, None) + +-- | Determine the field the cursor is currently a part of. +-- +-- The result is said field and its starting position +-- or Nothing if the passed list of fields is empty. +-- +-- This only looks at the row of the cursor and not at the cursor's +-- position within the row. +-- +-- TODO: we do not handle braces correctly. Add more tests! +findFieldSection :: Syntax.Position -> [Syntax.Field Syntax.Position] -> Maybe (Syntax.Field Syntax.Position) +findFieldSection _cursor [] = Nothing +findFieldSection _cursor [x] = + -- Last field. We decide later, whether we are starting + -- a new section. + Just x +findFieldSection cursor (x:y:ys) + | Syntax.positionRow (getAnnotation x) <= cursorLine && cursorLine < Syntax.positionRow (getAnnotation y) + = Just x + | otherwise = findFieldSection cursor (y:ys) + where + cursorLine = Syntax.positionRow cursor + +-- | Determine the field line the cursor is currently a part of. +-- +-- The result is said field line and its starting position +-- or Nothing if the passed list of fields is empty. +-- +-- This function assumes that elements in a field's @FieldLine@ list +-- do not share the same row. +findFieldLine :: Syntax.Position -> [Syntax.Field Syntax.Position] -> Maybe (Syntax.FieldLine Syntax.Position) +findFieldLine _cursor [] = Nothing +findFieldLine cursor fields = + case findFieldSection cursor fields of + Nothing -> Nothing + Just (Syntax.Field _ fieldLines) -> find filterLineFields fieldLines + Just (Syntax.Section _ _ fields) -> findFieldLine cursor fields + where + cursorLine = Syntax.positionRow cursor + -- In contrast to `Field` or `Section`, `FieldLine` must have the exact + -- same line position as the cursor. + filterLineFields (Syntax.FieldLine pos _) = Syntax.positionRow pos == cursorLine + +-- | Determine the exact word at the current cursor position. +-- +-- The result is said word or Nothing if the passed list is empty +-- or the cursor position is not next to, or on a word. +-- For this function, a word is a sequence of consecutive characters +-- that are not a space or column. +-- +-- This function currently only considers words inside of a @FieldLine@. +findTextWord :: Syntax.Position -> [Syntax.Field Syntax.Position] -> Maybe T.Text +findTextWord _cursor [] = Nothing +findTextWord cursor fields = + case findFieldLine cursor fields of + Nothing -> Nothing + Just (Syntax.FieldLine pos byteString) -> + let decodedText = T.decodeUtf8 byteString + lineFieldCol = Syntax.positionCol pos + lineFieldLen = T.length decodedText + offset = cursorCol - lineFieldCol in + -- Range check if cursor is inside or or next to found line. + -- The latter comparison includes the length of the line as offset, + -- which is done to also include cursors that are at the end of a line. + -- e.g. "foo,bar|" + -- ^ + -- cursor + -- + -- Having an offset which is outside of the line is possible because of `splitAt`. + if offset >= 0 && lineFieldLen >= offset + then + let (lhs, rhs) = T.splitAt offset decodedText + strippedLhs = T.takeWhileEnd isAllowedChar lhs + strippedRhs = T.takeWhile isAllowedChar rhs + resultText = T.concat [strippedLhs, strippedRhs] in + -- It could be possible that the cursor was in-between separators, in this + -- case the resulting text would be empty, which should result in `Nothing`. + -- e.g. " foo ,| bar" + -- ^ + -- cursor + if not $ T.null resultText then Just resultText else Nothing + else + Nothing + where + cursorCol = Syntax.positionCol cursor + separators = [',', ' '] + isAllowedChar = (`notElem` separators) + +type FieldName = T.Text + +getAnnotation :: Syntax.Field ann -> ann +getAnnotation (Syntax.Field (Syntax.Name ann _) _) = ann +getAnnotation (Syntax.Section (Syntax.Name ann _) _ _) = ann + +getFieldName :: Syntax.Field ann -> FieldName +getFieldName (Syntax.Field (Syntax.Name _ fn) _) = T.decodeUtf8 fn +getFieldName (Syntax.Section (Syntax.Name _ fn) _ _) = T.decodeUtf8 fn + +getFieldLineName :: Syntax.FieldLine ann -> FieldName +getFieldLineName (Syntax.FieldLine _ fn) = T.decodeUtf8 fn + +-- | Returns the name of a section if it has a name. +-- +-- This assumes that the given section args belong to named stanza +-- in which case the stanza name is returned. +getOptionalSectionName :: [Syntax.SectionArg ann] -> Maybe T.Text +getOptionalSectionName [] = Nothing +getOptionalSectionName (x:xs) = case x of + Syntax.SecArgName _ name -> Just (T.decodeUtf8 name) + _ -> getOptionalSectionName xs + +type BuildTargetName = T.Text +type ModuleName = T.Text + +-- | Given a cabal AST returns pairs of all respective target names +-- and the module name bound to them. If a target is a main library gives +-- @Nothing@, otherwise @Just target-name@ +-- +-- Examples of input cabal files and the outputs: +-- +-- * Target is a main library module: +-- +-- > library +-- > exposed-modules: +-- > MyLib +-- +-- * @getModulesNames@ output: +-- +-- > [([Nothing], "MyLib")] +-- +-- * Same module names in different targets: +-- +-- > test-suite first-target +-- > other-modules: +-- > Config +-- > test-suite second-target +-- > other-modules: +-- > Config +-- +-- * @getModulesNames@ output: +-- +-- > [([Just "first-target", Just "second-target"], "Config")] +getModulesNames :: [Syntax.Field any] -> [([Maybe BuildTargetName], ModuleName)] +getModulesNames fields = map swap $ groupSort rawModuleTargetPairs + where + rawModuleTargetPairs = concatMap getSectionModuleNames sections + sections = getSectionsWithModules fields + + getSectionModuleNames :: Syntax.Field any -> [(ModuleName, Maybe BuildTargetName)] + getSectionModuleNames (Syntax.Section _ secArgs fields) = map (, getArgsName secArgs) $ concatMap getFieldModuleNames fields + getSectionModuleNames _ = [] + + getArgsName [Syntax.SecArgName _ name] = Just $ T.decodeUtf8 name + getArgsName _ = Nothing -- Can be only a main library, that has no name + -- since it's impossible to have multiple names for a build target + + getFieldModuleNames field@(Syntax.Field _ modules) = if getFieldName field == T.pack "exposed-modules" || + getFieldName field == T.pack "other-modules" + then map getFieldLineName modules + else [] + getFieldModuleNames _ = [] + +-- | Trims a given cabal AST leaving only targets and their +-- @exposed-modules@ and @other-modules@ sections. +-- +-- For example: +-- +-- * Given a cabal file like this: +-- +-- > library +-- > import: extra +-- > hs-source-dirs: source/directory +-- > ... +-- > exposed-modules: +-- > Important.Exposed.Module +-- > other-modules: +-- > Important.Other.Module +-- > +-- > test-suite tests +-- > type: type +-- > build-tool-depends: tool +-- > other-modules: +-- > Important.Other.Module +-- +-- * @getSectionsWithModules@ gives output: +-- +-- > library +-- > exposed-modules: +-- > Important.Exposed.Module +-- > other-modules: +-- > Important.Other.Module +-- > test-suite tests +-- > other-modules: +-- > Important.Other.Module +getSectionsWithModules :: [Syntax.Field any] -> [Syntax.Field any] +getSectionsWithModules fields = concatMap go fields + where + go :: Syntax.Field any -> [Syntax.Field any] + go (Syntax.Field _ _) = [] + go section@(Syntax.Section _ _ fields) = concatMap onlySectionsWithModules (section:fields) + + onlySectionsWithModules :: Syntax.Field any -> [Syntax.Field any] + onlySectionsWithModules (Syntax.Field _ _) = [] + onlySectionsWithModules (Syntax.Section name secArgs fields) + | (not . null) newFields = [Syntax.Section name secArgs newFields] + | otherwise = [] + where newFields = filter subfieldHasModule fields + + subfieldHasModule :: Syntax.Field any -> Bool + subfieldHasModule field@(Syntax.Field _ _) = getFieldName field == T.pack "exposed-modules" || + getFieldName field == T.pack "other-modules" + subfieldHasModule (Syntax.Section _ _ _) = False + +-- | Makes a single text line out of multiple +-- @SectionArg@s. Allows to display conditions, +-- flags, etc in one line, which is easier to read. +-- +-- For example, @flag@ @(@ @pedantic@ @)@ will be joined in +-- one line, instead of four @SectionArg@s separately. +onelineSectionArgs :: [Syntax.SectionArg ann] -> T.Text +onelineSectionArgs sectionArgs = joinedName + where + joinedName = T.unwords $ map getName sectionArgs + + getName :: Syntax.SectionArg ann -> T.Text + getName (Syntax.SecArgName _ identifier) = T.decodeUtf8 identifier + getName (Syntax.SecArgStr _ quotedString) = T.decodeUtf8 quotedString + getName (Syntax.SecArgOther _ string) = T.decodeUtf8 string + +-- | Returns the end position of a provided field +getFieldEndPosition :: Syntax.Field Syntax.Position -> Syntax.Position +getFieldEndPosition (Syntax.Field name []) = getNameEndPosition name +getFieldEndPosition (Syntax.Field _ (x:xs)) = getFieldLineEndPosition $ NE.last (x NE.:| xs) +getFieldEndPosition (Syntax.Section name [] []) = getNameEndPosition name +getFieldEndPosition (Syntax.Section _ (x:xs) []) = getSectionArgEndPosition $ NE.last (x NE.:| xs) +getFieldEndPosition (Syntax.Section _ _ (x:xs)) = getFieldEndPosition $ NE.last (x NE.:| xs) + +-- | Returns the end position of a provided section arg +getSectionArgEndPosition :: Syntax.SectionArg Syntax.Position -> Syntax.Position +getSectionArgEndPosition (Syntax.SecArgName (Syntax.Position row col) byteString) = Syntax.Position row (col + BS.length byteString) +getSectionArgEndPosition (Syntax.SecArgStr (Syntax.Position row col) byteString) = Syntax.Position row (col + BS.length byteString) +getSectionArgEndPosition (Syntax.SecArgOther (Syntax.Position row col) byteString) = Syntax.Position row (col + BS.length byteString) + +-- | Returns the end position of a provided name +getNameEndPosition :: Syntax.Name Syntax.Position -> Syntax.Position +getNameEndPosition (Syntax.Name (Syntax.Position row col) byteString) = Syntax.Position row (col + BS.length byteString) + +-- | Returns the end position of a provided field line +getFieldLineEndPosition :: Syntax.FieldLine Syntax.Position -> Syntax.Position +getFieldLineEndPosition (Syntax.FieldLine (Syntax.Position row col) byteString) = Syntax.Position row (col + BS.length byteString) + +-- | Returns an LSP compatible range for a provided field +getFieldLSPRange :: Syntax.Field Syntax.Position -> LSP.Range +getFieldLSPRange field = LSP.Range startLSPPos endLSPPos + where + startLSPPos = cabalPositionToLSPPosition $ getAnnotation field + endLSPPos = cabalPositionToLSPPosition $ getFieldEndPosition field diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Simple.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Simple.hs --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Simple.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Simple.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Ide.Plugin.Cabal.Completion.Completer.Simple where @@ -7,11 +8,14 @@ import qualified Data.List as List import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, + mapMaybe) import Data.Ord (Down (Down)) import qualified Data.Text as T +import qualified Distribution.Fields as Syntax import Ide.Logger (Priority (..), logWith) +import Ide.Plugin.Cabal.Completion.CabalFields import Ide.Plugin.Cabal.Completion.Completer.Types import Ide.Plugin.Cabal.Completion.Types (CabalPrefixInfo (..), Log) @@ -40,6 +44,22 @@ scored = Fuzzy.simpleFilter Fuzzy.defChunkSize Fuzzy.defMaxResults (completionPrefix prefInfo) completions range = completionRange prefInfo pure $ map (mkSimpleCompletionItem range . Fuzzy.original) scored + +-- | Completer to be used for import fields. +-- +-- TODO: Does not exclude imports, defined after the current cursor position +-- which are not allowed according to the cabal specification +importCompleter :: Completer +importCompleter l cData = do + cabalCommonsM <- getCabalCommonSections cData + case cabalCommonsM of + Just cabalCommons -> do + let commonNames = mapMaybe (\case + Syntax.Section (Syntax.Name _ "common") commonNames _ -> getOptionalSectionName commonNames + _ -> Nothing) + cabalCommons + constantCompleter commonNames l cData + Nothing -> noopCompleter l cData -- | Completer to be used for the field @name:@ value. -- diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Types.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Types.hs --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Types.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Types.hs @@ -3,7 +3,9 @@ module Ide.Plugin.Cabal.Completion.Completer.Types where import Development.IDE as D +import qualified Distribution.Fields as Syntax import Distribution.PackageDescription (GenericPackageDescription) +import qualified Distribution.Parsec.Position as Syntax import Ide.Plugin.Cabal.Completion.Types import Language.LSP.Protocol.Types (CompletionItem) @@ -16,9 +18,11 @@ { -- | Access to the latest available generic package description for the handled cabal file, -- relevant for some completion actions which require the file's meta information -- such as the module completers which require access to source directories - getLatestGPD :: IO (Maybe GenericPackageDescription), + getLatestGPD :: IO (Maybe GenericPackageDescription), + -- | Access to the entries of the handled cabal file as parsed by ParseCabalFields + getCabalCommonSections :: IO (Maybe [Syntax.Field Syntax.Position]), -- | Prefix info to be used for constructing completion items - cabalPrefixInfo :: CabalPrefixInfo, + cabalPrefixInfo :: CabalPrefixInfo, -- | The name of the stanza in which the completer is applied - stanzaName :: Maybe StanzaName + stanzaName :: Maybe StanzaName } diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completions.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completions.hs --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completions.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completions.hs @@ -8,11 +8,11 @@ import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import qualified Data.Text as T -import qualified Data.Text.Encoding as T import Development.IDE as D import qualified Development.IDE.Plugin.Completions.Types as Ghcide import qualified Distribution.Fields as Syntax import qualified Distribution.Parsec.Position as Syntax +import Ide.Plugin.Cabal.Completion.CabalFields import Ide.Plugin.Cabal.Completion.Completer.Simple import Ide.Plugin.Cabal.Completion.Completer.Snippet import Ide.Plugin.Cabal.Completion.Completer.Types (Completer) @@ -140,6 +140,7 @@ Just field@(Syntax.Field _ _) -> classifyFieldContext parentHistory cursor field Just section@(Syntax.Section _ args sectionFields) | inSameLineAsSectionName section -> (stanzaCtx, None) -- TODO: test whether keyword in same line is parsed correctly + | getFieldName section `elem` conditionalKeywords -> findCursorContext cursor parentHistory prefixText sectionFields -- Ignore if conditionals, they are not real sections | otherwise -> findCursorContext cursor (NE.cons (Syntax.positionCol (getAnnotation section) + 1, Stanza (getFieldName section) (getOptionalSectionName args)) parentHistory) @@ -147,6 +148,7 @@ where inSameLineAsSectionName section = Syntax.positionRow (getAnnotation section) == Syntax.positionRow cursor stanzaCtx = snd $ NE.head parentHistory + conditionalKeywords = ["if", "elif", "else"] -- | Finds the cursor's context, where the cursor is already found to be in a specific field -- @@ -177,57 +179,3 @@ cursorColumn = Syntax.positionCol cursor fieldColumn = Syntax.positionCol (getAnnotation field) - --- ---------------------------------------------------------------- --- Cabal-syntax utilities I don't really want to write myself --- ---------------------------------------------------------------- - --- | Determine the context of a cursor position within a stack of stanza contexts --- --- If the cursor is indented more than one of the stanzas in the stack --- the respective stanza is returned if this is never the case, the toplevel stanza --- in the stack is returned. -findStanzaForColumn :: Int -> NonEmpty (Int, StanzaContext) -> (StanzaContext, FieldContext) -findStanzaForColumn col ctx = case NE.uncons ctx of - ((_, stanza), Nothing) -> (stanza, None) - ((indentation, stanza), Just res) - | col < indentation -> findStanzaForColumn col res - | otherwise -> (stanza, None) - --- | Determine the field the cursor is currently a part of. --- --- The result is said field and its starting position --- or Nothing if the passed list of fields is empty. - --- This only looks at the row of the cursor and not at the cursor's --- position within the row. --- --- TODO: we do not handle braces correctly. Add more tests! -findFieldSection :: Syntax.Position -> [Syntax.Field Syntax.Position] -> Maybe (Syntax.Field Syntax.Position) -findFieldSection _cursor [] = Nothing -findFieldSection _cursor [x] = - -- Last field. We decide later, whether we are starting - -- a new section. - Just x -findFieldSection cursor (x:y:ys) - | Syntax.positionRow (getAnnotation x) <= cursorLine && cursorLine < Syntax.positionRow (getAnnotation y) - = Just x - | otherwise = findFieldSection cursor (y:ys) - where - cursorLine = Syntax.positionRow cursor - -type FieldName = T.Text - -getAnnotation :: Syntax.Field ann -> ann -getAnnotation (Syntax.Field (Syntax.Name ann _) _) = ann -getAnnotation (Syntax.Section (Syntax.Name ann _) _ _) = ann - -getFieldName :: Syntax.Field ann -> FieldName -getFieldName (Syntax.Field (Syntax.Name _ fn) _) = T.decodeUtf8 fn -getFieldName (Syntax.Section (Syntax.Name _ fn) _ _) = T.decodeUtf8 fn - -getOptionalSectionName :: [Syntax.SectionArg ann] -> Maybe T.Text -getOptionalSectionName [] = Nothing -getOptionalSectionName (x:xs) = case x of - Syntax.SecArgName _ name -> Just (T.decodeUtf8 name) - _ -> getOptionalSectionName xs diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Data.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Data.hs --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Data.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Data.hs @@ -23,6 +23,9 @@ -- Completion Data -- ---------------------------------------------------------------- +supportedCabalVersions :: [CabalSpecVersion] +supportedCabalVersions = [CabalSpecV2_2 .. maxBound] + -- | Keyword for cabal version; required to be the top line in a cabal file cabalVersionKeyword :: Map KeyWordName Completer cabalVersionKeyword = @@ -30,7 +33,7 @@ constantCompleter $ -- We only suggest cabal versions newer than 2.2 -- since we don't recommend using older ones. - map (T.pack . showCabalSpecVersion) [CabalSpecV2_2 .. maxBound] + map (T.pack . showCabalSpecVersion) supportedCabalVersions -- | Top level keywords of a cabal file. -- @@ -162,7 +165,8 @@ libExecTestBenchCommons :: Map KeyWordName Completer libExecTestBenchCommons = Map.fromList - [ ("build-depends:", noopCompleter), + [ ("import:", importCompleter), + ("build-depends:", noopCompleter), ("hs-source-dirs:", directoryCompleter), ("default-extensions:", noopCompleter), ("other-extensions:", noopCompleter), diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Types.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Types.hs --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Types.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Types.hs @@ -8,7 +8,6 @@ import Control.Lens ((^.)) import Data.Hashable import qualified Data.Text as T -import Data.Typeable import Development.IDE as D import qualified Distribution.Fields as Syntax import qualified Distribution.PackageDescription as PD @@ -44,7 +43,7 @@ type instance RuleResult ParseCabalFile = PD.GenericPackageDescription data ParseCabalFile = ParseCabalFile - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable ParseCabalFile @@ -53,12 +52,21 @@ type instance RuleResult ParseCabalFields = [Syntax.Field Syntax.Position] data ParseCabalFields = ParseCabalFields - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable ParseCabalFields instance NFData ParseCabalFields +type instance RuleResult ParseCabalCommonSections = [Syntax.Field Syntax.Position] + +data ParseCabalCommonSections = ParseCabalCommonSections + deriving (Eq, Show, Generic) + +instance Hashable ParseCabalCommonSections + +instance NFData ParseCabalCommonSections + -- | The context a cursor can be in within a cabal file. -- -- We can be in stanzas or the top level, @@ -171,3 +179,10 @@ lspPositionToCabalPosition pos = Syntax.Position (fromIntegral (pos ^. JL.line) + 1) (fromIntegral (pos ^. JL.character) + 1) + +-- | Convert an 'Syntax.Position' to a LSP 'Position'. +-- +-- Cabal Positions start their indexing at 1 while LSP starts at 0. +-- This helper makes sure, the translation is done properly. +cabalPositionToLSPPosition :: Syntax.Position -> Position +cabalPositionToLSPPosition (Syntax.Position start end) = Position (toEnum start -1) (toEnum end -1) diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Definition.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Definition.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Definition.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} + +module Ide.Plugin.Cabal.Definition where + +import Control.Lens ((^.)) +import Control.Monad.Extra +import Control.Monad.IO.Class +import Data.List (find) +import qualified Data.Maybe as Maybe +import qualified Data.Text as T +import Development.IDE as D +import Development.IDE.Core.PluginUtils +import qualified Distribution.Fields as Syntax +import Distribution.PackageDescription (Benchmark (..), + BuildInfo (..), + Executable (..), + ForeignLib (..), + GenericPackageDescription, + Library (..), + LibraryName (LMainLibName, LSubLibName), + PackageDescription (..), + TestSuite (..), + library, + unUnqualComponentName) +import Distribution.PackageDescription.Configuration (flattenPackageDescription) +import qualified Distribution.Parsec.Position as Syntax +import Distribution.Utils.Generic (safeHead) +import Distribution.Utils.Path (getSymbolicPath) +import Ide.Plugin.Cabal.Completion.CabalFields as CabalFields +import Ide.Plugin.Cabal.Completion.Types (ParseCabalCommonSections (ParseCabalCommonSections), + ParseCabalFields (..), + ParseCabalFile (..)) +import qualified Ide.Plugin.Cabal.Completion.Types as Types +import Ide.Plugin.Cabal.Orphans () +import Ide.Plugin.Error +import Ide.Types +import qualified Language.LSP.Protocol.Lens as JL +import qualified Language.LSP.Protocol.Message as LSP +import Language.LSP.Protocol.Types +import System.Directory (doesFileExist) +import System.FilePath (joinPath, + takeDirectory, + (<.>), ()) + +-- | Handler for going to definitions. +-- +-- Provides a handler for going to the definition in a cabal file, +-- gathering all possible definitions by calling subfunctions. + +-- TODO: Resolve more cases for go-to definition. +gotoDefinition :: PluginMethodHandler IdeState LSP.Method_TextDocumentDefinition +gotoDefinition ide _ msgParam = do + nfp <- getNormalizedFilePathE uri + cabalFields <- runActionE "cabal-plugin.commonSections" ide $ useE ParseCabalFields nfp + -- Trim the AST tree, so multiple passes in subfunctions won't hurt the performance. + let fieldsOfInterest = maybe cabalFields (:[] ) $ CabalFields.findFieldSection cursor cabalFields + + commonSections <- runActionE "cabal-plugin.commonSections" ide $ useE ParseCabalCommonSections nfp + let mCommonSectionsDef = gotoCommonSectionDefinition uri commonSections cursor fieldsOfInterest + + mModuleDef <- do + mGPD <- liftIO $ runAction "cabal.GPD" ide $ useWithStale ParseCabalFile nfp + case mGPD of + Nothing -> pure Nothing + Just (gpd, _) -> liftIO $ gotoModulesDefinition nfp gpd cursor fieldsOfInterest + + let defs = Maybe.catMaybes [ mCommonSectionsDef + , mModuleDef + ] + -- Take first found definition. + -- We assume, that there can't be multiple definitions, + -- or the most specific definitions come first. + case safeHead defs of + Nothing -> pure $ InR $ InR Null + Just def -> pure $ InL def + where + cursor = Types.lspPositionToCabalPosition (msgParam ^. JL.position) + uri = msgParam ^. JL.textDocument . JL.uri + +-- | Definitions for Sections. +-- +-- Provides a Definition if cursor is pointed at an identifier, +-- otherwise gives Nothing. +-- The definition is found by traversing the sections and comparing their name to +-- the clicked identifier. +gotoCommonSectionDefinition + :: Uri -- ^ Cabal file URI + -> [Syntax.Field Syntax.Position] -- ^ Found common sections + -> Syntax.Position -- ^ Cursor position + -> [Syntax.Field Syntax.Position] -- ^ Trimmed cabal AST on a cursor + -> Maybe Definition +gotoCommonSectionDefinition uri commonSections cursor fieldsOfInterest = do + cursorText <- CabalFields.findTextWord cursor fieldsOfInterest + commonSection <- find (isSectionArgName cursorText) commonSections + Just $ Definition $ InL $ Location uri $ CabalFields.getFieldLSPRange commonSection + where + isSectionArgName name (Syntax.Section _ sectionArgName _) = name == CabalFields.onelineSectionArgs sectionArgName + isSectionArgName _ _ = False + +-- | Definitions for Modules. +-- +-- Provides a Definition if cursor is pointed at a +-- exposed-module or other-module field, otherwise gives Nothing +-- +-- Definition is found by looking for a module name, +-- the cursor is pointing to and looking for it in @BuildInfo@s. +-- Note that since a trimmed ast is provided, a @Definition@ to +-- a module with the same name as the target one, +-- but in another build target can't be given. +-- +-- See resolving @Config@ module in tests. +gotoModulesDefinition + :: NormalizedFilePath -- ^ Normalized FilePath to the cabal file + -> GenericPackageDescription + -> Syntax.Position -- ^ Cursor position + -> [Syntax.Field Syntax.Position] -- ^ Trimmed cabal AST on a cursor + -> IO (Maybe Definition) +gotoModulesDefinition nfp gpd cursor fieldsOfInterest = do + let mCursorText = CabalFields.findTextWord cursor fieldsOfInterest + moduleNames = CabalFields.getModulesNames fieldsOfInterest + mModuleName = find (isModuleName mCursorText) moduleNames + + case mModuleName of + Nothing -> pure Nothing + Just (mBuildTargetNames, moduleName) -> do + let buildInfos = foldMap (lookupBuildTargetPackageDescription + (flattenPackageDescription gpd)) + mBuildTargetNames + sourceDirs = map getSymbolicPath $ concatMap hsSourceDirs buildInfos + potentialPaths = map (\dir -> takeDirectory (fromNormalizedFilePath nfp) dir toHaskellFile moduleName) sourceDirs + allPaths <- liftIO $ filterM doesFileExist potentialPaths + -- Don't provide the range, since there is little benefit for it + let locations = map (\pth -> Location (filePathToUri pth) (mkRange 0 0 0 0)) allPaths + case safeHead locations of -- We assume there could be only one source location + Nothing -> pure Nothing + Just location -> pure $ Just $ Definition $ InL location + where + isModuleName (Just name) (_, moduleName) = name == moduleName + isModuleName _ _ = False + +-- | Gives all `buildInfo`s given a target name. +-- +-- `Maybe buildTargetName` is provided, and if it's +-- Nothing we assume, that it's a main library. +-- Otherwise looks for the provided name. +lookupBuildTargetPackageDescription :: PackageDescription -> Maybe T.Text -> [BuildInfo] +lookupBuildTargetPackageDescription (PackageDescription {..}) Nothing = + case library of + Nothing -> [] -- Target is a main library but no main library was found + Just (Library {libBuildInfo}) -> [libBuildInfo] +lookupBuildTargetPackageDescription (PackageDescription {..}) (Just buildTargetName) = + Maybe.catMaybes $ + map executableNameLookup executables <> + map subLibraryNameLookup subLibraries <> + map foreignLibsNameLookup foreignLibs <> + map testSuiteNameLookup testSuites <> + map benchmarkNameLookup benchmarks + where + executableNameLookup :: Executable -> Maybe BuildInfo + executableNameLookup (Executable {exeName, buildInfo}) = + if T.pack (unUnqualComponentName exeName) == buildTargetName + then Just buildInfo + else Nothing + subLibraryNameLookup :: Library -> Maybe BuildInfo + subLibraryNameLookup (Library {libName, libBuildInfo}) = + case libName of + (LSubLibName name) -> + if T.pack (unUnqualComponentName name) == buildTargetName + then Just libBuildInfo + else Nothing + LMainLibName -> Nothing + foreignLibsNameLookup :: ForeignLib -> Maybe BuildInfo + foreignLibsNameLookup (ForeignLib {foreignLibName, foreignLibBuildInfo}) = + if T.pack (unUnqualComponentName foreignLibName) == buildTargetName + then Just foreignLibBuildInfo + else Nothing + testSuiteNameLookup :: TestSuite -> Maybe BuildInfo + testSuiteNameLookup (TestSuite {testName, testBuildInfo}) = + if T.pack (unUnqualComponentName testName) == buildTargetName + then Just testBuildInfo + else Nothing + benchmarkNameLookup :: Benchmark -> Maybe BuildInfo + benchmarkNameLookup (Benchmark {benchmarkName, benchmarkBuildInfo}) = + if T.pack (unUnqualComponentName benchmarkName) == buildTargetName + then Just benchmarkBuildInfo + else Nothing + +-- | Converts a name of a module to a FilePath. +-- Is needed to guess the relative path to a file +-- using the name of the module. +-- We assume, that correct module naming is guaranteed. +-- +-- Warning: Generally not advised to use, if there are +-- better ways to get the path. +-- +-- Examples: (output is system dependent) +-- >>> toHaskellFile "My.Module.Lib" +-- "My/Module/Lib.hs" +-- >>> toHaskellFile "Main" +-- "Main.hs" +toHaskellFile :: T.Text -> FilePath +toHaskellFile moduleName = joinPath (map T.unpack $ T.splitOn "." moduleName) <.> ".hs" diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs @@ -11,18 +11,21 @@ ) where -import qualified Data.Text as T -import Development.IDE (FileDiagnostic, - ShowDiagnostic (ShowDiag)) -import Distribution.Fields (showPError, showPWarning) -import qualified Distribution.Parsec as Syntax -import Ide.PluginUtils (extendNextLine) -import Language.LSP.Protocol.Types (Diagnostic (..), - DiagnosticSeverity (..), - NormalizedFilePath, - Position (Position), - Range (Range), - fromNormalizedFilePath) +import Control.Lens ((&), (.~)) +import qualified Data.Text as T +import Development.IDE (FileDiagnostic) +import Development.IDE.Types.Diagnostics (fdLspDiagnosticL, + ideErrorWithSource) +import Distribution.Fields (showPError, showPWarning) +import qualified Distribution.Parsec as Syntax +import Ide.PluginUtils (extendNextLine) +import Language.LSP.Protocol.Lens (range) +import Language.LSP.Protocol.Types (Diagnostic (..), + DiagnosticSeverity (..), + NormalizedFilePath, + Position (Position), + Range (Range), + fromNormalizedFilePath) -- | Produce a diagnostic for a fatal Cabal parser error. fatalParseErrorDiagnostic :: NormalizedFilePath -> T.Text -> FileDiagnostic @@ -63,8 +66,9 @@ positionFromCabalPosition (Syntax.Position line column) = Position (fromIntegral line') (fromIntegral col') where -- LSP is zero-based, Cabal is one-based - line' = line-1 - col' = column-1 + -- Cabal can return line 0 for errors in the first line + line' = if line <= 0 then 0 else line-1 + col' = if column <= 0 then 0 else column-1 -- | Create a 'FileDiagnostic' mkDiag @@ -79,15 +83,11 @@ -> T.Text -- ^ The message displayed by the editor -> FileDiagnostic -mkDiag file diagSource sev loc msg = (file, ShowDiag,) - Diagnostic - { _range = loc - , _severity = Just sev - , _source = Just diagSource - , _message = msg - , _code = Nothing - , _tags = Nothing - , _relatedInformation = Nothing - , _codeDescription = Nothing - , _data_ = Nothing - } +mkDiag file diagSource sev loc msg = + ideErrorWithSource + (Just diagSource) + (Just sev) + file + msg + Nothing + & fdLspDiagnosticL . range .~ loc diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/FieldSuggest.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/FieldSuggest.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/FieldSuggest.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Ide.Plugin.Cabal.FieldSuggest + ( fieldErrorName, + fieldErrorAction, + -- * Re-exports + T.Text, + Diagnostic (..), + ) +where + +import qualified Data.Map.Strict as Map +import qualified Data.Text as T +import Language.LSP.Protocol.Types (CodeAction (..), + CodeActionKind (..), + Diagnostic (..), Position (..), + Range (..), TextEdit (..), Uri, + WorkspaceEdit (..)) +import Text.Regex.TDFA + +-- | Generate all code actions for given file, erroneous/unknown field and suggestions +fieldErrorAction + :: Uri + -- ^ File for which the diagnostic was generated + -> T.Text + -- ^ Original (unknown) field + -> [T.Text] + -- ^ Suggestions for the given file + -> Range + -- ^ Location of diagnostic + -> [CodeAction] +fieldErrorAction uri original suggestions range = + fmap mkCodeAction suggestions + where + mkCodeAction suggestion = + let + -- Range returned by cabal here represents fragment from start of offending identifier + -- to end of line, we modify this range to be to the end of the identifier + adjustRange (Range rangeFrom@(Position lineNr col) _) = + Range rangeFrom (Position lineNr (col + fromIntegral (T.length original))) + title = "Replace with " <> suggestion' + tedit = [TextEdit (adjustRange range ) suggestion'] + edit = WorkspaceEdit (Just $ Map.singleton uri tedit) Nothing Nothing + in CodeAction title (Just CodeActionKind_QuickFix) (Just []) Nothing Nothing (Just edit) Nothing Nothing + where + -- dropping colon from the end of suggestion + suggestion' = T.dropEnd 1 suggestion + +-- | Given a diagnostic returned by 'Ide.Plugin.Cabal.Diag.errorDiagnostic', +-- if it represents an "Unknown field"-error with incorrect identifier +-- then return the incorrect identifier together with original diagnostics. +fieldErrorName :: + Diagnostic -> + -- ^ Output of 'Ide.Plugin.Cabal.Diag.errorDiagnostic' + Maybe (T.Text, Diagnostic) + -- ^ Original (incorrect) field name with the suggested replacement +fieldErrorName diag = + mSuggestion (_message diag) >>= \case + [original] -> Just (original, diag) + _ -> Nothing + where + regex :: T.Text + regex = "Unknown field: \"(.*)\"" + mSuggestion msg = getMatch <$> (msg :: T.Text) =~~ regex + getMatch :: (T.Text, T.Text, T.Text, [T.Text]) -> [T.Text] + getMatch (_, _, _, results) = results diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Outline.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Outline.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Outline.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +module Ide.Plugin.Cabal.Outline where + +import Control.Monad.IO.Class +import Data.Maybe +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8) +import Development.IDE.Core.Rules +import Development.IDE.Core.Shake (IdeState (shakeExtras), + runIdeAction, + useWithStaleFast) +import Development.IDE.Types.Location (toNormalizedFilePath') +import Distribution.Fields.Field (Field (Field, Section), + Name (Name)) +import Distribution.Parsec.Position (Position) +import Ide.Plugin.Cabal.Completion.CabalFields (onelineSectionArgs) +import Ide.Plugin.Cabal.Completion.Types (ParseCabalFields (..), + cabalPositionToLSPPosition) +import Ide.Plugin.Cabal.Orphans () +import Ide.Types (PluginMethodHandler) +import Language.LSP.Protocol.Message (Method (..)) +import Language.LSP.Protocol.Types (DocumentSymbol (..)) +import qualified Language.LSP.Protocol.Types as LSP + + +moduleOutline :: PluginMethodHandler IdeState Method_TextDocumentDocumentSymbol +moduleOutline ideState _ LSP.DocumentSymbolParams {_textDocument = LSP.TextDocumentIdentifier uri} = + case LSP.uriToFilePath uri of + Just (toNormalizedFilePath' -> fp) -> do + mFields <- liftIO $ runIdeAction "cabal-plugin.fields" (shakeExtras ideState) (useWithStaleFast ParseCabalFields fp) + case fmap fst mFields of + Just fieldPositions -> pure $ LSP.InR (LSP.InL allSymbols) + where + allSymbols = mapMaybe documentSymbolForField fieldPositions + Nothing -> pure $ LSP.InL [] + Nothing -> pure $ LSP.InL [] + +-- | Creates a @DocumentSymbol@ object for the +-- cabal AST, without displaying @fieldLines@ and +-- displaying @Section Name@ and @SectionArgs@ in one line. +-- +-- @fieldLines@ are leaves of a cabal AST, so they are omitted +-- in the outline. Sections have to be displayed in one line, because +-- the AST representation looks unnatural. See examples: +-- +-- * part of a cabal file: +-- +-- > if impl(ghc >= 9.8) +-- > ghc-options: -Wall +-- +-- * AST representation: +-- +-- > if +-- > impl +-- > ( +-- > ghc >= 9.8 +-- > ) +-- > +-- > ghc-options: +-- > -Wall +-- +-- * resulting @DocumentSymbol@: +-- +-- > if impl(ghc >= 9.8) +-- > ghc-options: +-- > +documentSymbolForField :: Field Position -> Maybe DocumentSymbol +documentSymbolForField (Field (Name pos fieldName) _) = + Just + (defDocumentSymbol range) + { _name = decodeUtf8 fieldName, + _kind = LSP.SymbolKind_Field, + _children = Nothing + } + where + range = cabalPositionToLSPRange pos `addNameLengthToLSPRange` decodeUtf8 fieldName +documentSymbolForField (Section (Name pos fieldName) sectionArgs fields) = + Just + (defDocumentSymbol range) + { _name = joinedName, + _kind = LSP.SymbolKind_Object, + _children = + Just + (mapMaybe documentSymbolForField fields) + } + where + joinedName = decodeUtf8 fieldName <> " " <> onelineSectionArgs sectionArgs + range = cabalPositionToLSPRange pos `addNameLengthToLSPRange` joinedName + +-- | Creates a single point LSP range +-- using cabal position +cabalPositionToLSPRange :: Position -> LSP.Range +cabalPositionToLSPRange pos = LSP.Range lspPos lspPos + where + lspPos = cabalPositionToLSPPosition pos + +addNameLengthToLSPRange :: LSP.Range -> T.Text -> LSP.Range +addNameLengthToLSPRange (LSP.Range pos1 (LSP.Position line char)) name = + LSP.Range + pos1 + (LSP.Position line (char + fromIntegral (T.length name))) + +defDocumentSymbol :: LSP.Range -> DocumentSymbol +defDocumentSymbol range = DocumentSymbol + { _detail = Nothing + , _deprecated = Nothing + , _name = "" + , _kind = LSP.SymbolKind_File + , _range = range + , _selectionRange = range + , _children = Nothing + , _tags = Nothing + } diff --git a/plugins/hls-cabal-plugin/test/CabalAdd.hs b/plugins/hls-cabal-plugin/test/CabalAdd.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/CabalAdd.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE OverloadedStrings #-} + +module CabalAdd ( + cabalAddTests, +) where + +import Control.Lens ((^.)) +import Control.Lens.Fold ((^?)) +import qualified Data.Maybe as Maybe +import qualified Data.Text as T +import qualified Data.Text.Internal.Search as T +import Distribution.Utils.Generic (safeHead) +import Ide.Plugin.Cabal.CabalAdd (hiddenPackageSuggestion) +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Types (Diagnostic (..), mkRange) +import System.FilePath +import Test.Hls (Session, TestTree, _R, anyMessage, + assertEqual, documentContents, + executeCodeAction, + getAllCodeActions, + getDocumentEdit, liftIO, openDoc, + skipManyTill, testCase, testGroup, + waitForDiagnosticsFrom, (@?=)) +import Utils + +cabalAddTests :: TestTree +cabalAddTests = + testGroup + "CabalAdd Tests" + [ runHaskellTestCaseSession "Code Actions - Can add hidden package to an executable" ("cabal-add-testdata" "cabal-add-exe") + (generateAddDependencyTestSession "cabal-add-exe.cabal" ("src" "Main.hs") "split" [253]) + , runHaskellTestCaseSession "Code Actions - Can add hidden package to a library" ("cabal-add-testdata" "cabal-add-lib") + (generateAddDependencyTestSession "cabal-add-lib.cabal" ("src" "MyLib.hs") "split" [348]) + , runHaskellTestCaseSession "Code Actions - Can add hidden package to a test" ("cabal-add-testdata" "cabal-add-tests") + (generateAddDependencyTestSession "cabal-add-tests.cabal" ("test" "Main.hs") "split" [478]) + , runHaskellTestCaseSession "Code Actions - Can add hidden package to a benchmark" ("cabal-add-testdata" "cabal-add-bench") + (generateAddDependencyTestSession "cabal-add-bench.cabal" ("bench" "Main.hs") "split" [403]) + + , runHaskellTestCaseSession "Code Actions - Can add hidden package to an executable, multiple targets" ("cabal-add-testdata" "cabal-add-multitarget") + (generateAddDependencyTestSession "cabal-add-multitarget.cabal" ("src" "Main.hs") "split" [269]) + , runHaskellTestCaseSession "Code Actions - Can add hidden package to a library, multiple targets" ("cabal-add-testdata" "cabal-add-multitarget") + (generateAddDependencyTestSession "cabal-add-multitarget.cabal" ("lib" "MyLib.hs") "split" [413]) + , runHaskellTestCaseSession "Code Actions - Can add hidden package to an internal library, multiple targets" ("cabal-add-testdata" "cabal-add-multitarget") + (generateAddDependencyTestSession "cabal-add-multitarget.cabal" ("lib" "InternalLib.hs") "split" [413]) + , runHaskellTestCaseSession "Code Actions - Can add hidden package to a test, multiple targets" ("cabal-add-testdata" "cabal-add-multitarget") + (generateAddDependencyTestSession "cabal-add-multitarget.cabal" ("test" "Main.hs") "split" [655]) + , runHaskellTestCaseSession "Code Actions - Can add hidden package to a benchmark, multiple targets" ("cabal-add-testdata" "cabal-add-multitarget") + (generateAddDependencyTestSession "cabal-add-multitarget.cabal" ("bench" "Main.hs") "split" [776]) + + + , runHaskellTestCaseSession "Code Actions - Guard against HPack" ("cabal-add-testdata" "cabal-add-packageYaml") + (generatePackageYAMLTestSession ("src" "Main.hs")) + + , testHiddenPackageSuggestions "Check CabalAdd's parser, no version" + [ "It is a member of the hidden package 'base'" + , "It is a member of the hidden package 'Blammo-wai'" + , "It is a member of the hidden package 'BlastHTTP'" + , "It is a member of the hidden package 'CC-delcont-ref-tf'" + , "It is a member of the hidden package '3d-graphics-examples'" + , "It is a member of the hidden package 'AAI'" + , "It is a member of the hidden package 'AWin32Console'" + ] + [ ("base", T.empty) + , ("Blammo-wai", T.empty) + , ("BlastHTTP", T.empty) + , ("CC-delcont-ref-tf", T.empty) + , ("3d-graphics-examples", T.empty) + , ("AAI", T.empty) + , ("AWin32Console", T.empty) + ] + , testHiddenPackageSuggestions "Check CabalAdd's parser, with version" + [ "It is a member of the hidden package 'base-0.1.0.0'" + , "It is a member of the hidden package 'Blammo-wai-0.11.0'" + , "It is a member of the hidden package 'BlastHTTP-2.6.4.3'" + , "It is a member of the hidden package 'CC-delcont-ref-tf-0.0.0.2'" + , "It is a member of the hidden package '3d-graphics-examples-1.1.6'" + , "It is a member of the hidden package 'AAI-0.1'" + , "It is a member of the hidden package 'AWin32Console-1.19.1'" + ] + [ ("base","0.1.0.0") + , ("Blammo-wai", "0.11.0") + , ("BlastHTTP", "2.6.4.3") + , ("CC-delcont-ref-tf", "0.0.0.2") + , ("3d-graphics-examples", "1.1.6") + , ("AAI", "0.1") + , ("AWin32Console", "1.19.1") + ] + , testHiddenPackageSuggestions "Check CabalAdd's parser, no version, unicode comma" + [ "It is a member of the hidden package \8216base\8217" + , "It is a member of the hidden package \8216Blammo-wai\8217" + , "It is a member of the hidden package \8216BlastHTTP\8217" + , "It is a member of the hidden package \8216CC-delcont-ref-tf\8217" + , "It is a member of the hidden package \8216AAI\8217" + , "It is a member of the hidden package \8216AWin32Console\8217" + ] + [ ("base", T.empty) + , ("Blammo-wai", T.empty) + , ("BlastHTTP", T.empty) + , ("CC-delcont-ref-tf", T.empty) + , ("AAI", T.empty) + , ("AWin32Console", T.empty) + ] + , testHiddenPackageSuggestions "Check CabalAdd's parser, with version, unicode comma" + [ "It is a member of the hidden package \8216base-0.1.0.0\8217" + , "It is a member of the hidden package \8216Blammo-wai-0.11.0\8217" + , "It is a member of the hidden package \8216BlastHTTP-2.6.4.3\8217" + , "It is a member of the hidden package \8216CC-delcont-ref-tf-0.0.0.2\8217" + , "It is a member of the hidden package \8216AAI-0.1\8217" + , "It is a member of the hidden package \8216AWin32Console-1.19.1\8217" + ] + [ ("base","0.1.0.0") + , ("Blammo-wai", "0.11.0") + , ("BlastHTTP", "2.6.4.3") + , ("CC-delcont-ref-tf", "0.0.0.2") + , ("AAI", "0.1") + , ("AWin32Console", "1.19.1") + ] + , testHiddenPackageSuggestions "Check CabalAdd's parser, with version, unicode comma" + [ "It is a member of the hidden package \8216\&3d-graphics-examples\8217" + , "It is a member of the hidden package \8216\&3d-graphics-examples-1.1.6\8217" + ] + [ ("3d-graphics-examples", T.empty) + , ("3d-graphics-examples", "1.1.6") + ] + ] + where + generateAddDependencyTestSession :: FilePath -> FilePath -> T.Text -> [Int] -> Session () + generateAddDependencyTestSession cabalFile haskellFile dependency indicesRes = do + hsdoc <- openDoc haskellFile "haskell" + cabDoc <- openDoc cabalFile "cabal" + _ <- waitForDiagnosticsFrom hsdoc + cas <- Maybe.mapMaybe (^? _R) <$> getAllCodeActions hsdoc + let selectedCas = filter (\ca -> "Add dependency" `T.isPrefixOf` (ca ^. L.title)) cas + mapM_ executeCodeAction selectedCas + _ <- skipManyTill anyMessage $ getDocumentEdit cabDoc -- Wait for the changes in cabal file + contents <- documentContents cabDoc + liftIO $ assertEqual (T.unpack dependency <> " isn't found in the cabal file") indicesRes (T.indices dependency contents) + testHiddenPackageSuggestions :: String -> [T.Text] -> [(T.Text, T.Text)] -> TestTree + testHiddenPackageSuggestions testTitle messages suggestions = + let diags = map (\msg -> messageToDiagnostic msg ) messages + suggestions' = map (safeHead . hiddenPackageSuggestion) diags + assertions = zipWith (@?=) suggestions' (map Just suggestions) + testNames = map (\(f, s) -> "Check if " ++ T.unpack f ++ (if s == "" then "" else "-") ++ T.unpack s ++ " was parsed correctly") suggestions + test = testGroup testTitle $ zipWith testCase testNames assertions + in test + messageToDiagnostic :: T.Text -> Diagnostic + messageToDiagnostic msg = Diagnostic { + _range = mkRange 0 0 0 0 + , _severity = Nothing + , _code = Nothing + , _source = Nothing + , _message = msg + , _relatedInformation = Nothing + , _tags = Nothing + , _codeDescription = Nothing + , _data_ = Nothing + } + + + generatePackageYAMLTestSession :: FilePath -> Session () + generatePackageYAMLTestSession haskellFile = do + hsdoc <- openDoc haskellFile "haskell" + _ <- waitForDiagnosticsFrom hsdoc + cas <- Maybe.mapMaybe (^? _R) <$> getAllCodeActions hsdoc + let selectedCas = filter (\ca -> "Add dependency" `T.isPrefixOf` (ca ^. L.title)) cas + liftIO $ assertEqual "PackageYAML" [] selectedCas diff --git a/plugins/hls-cabal-plugin/test/Completer.hs b/plugins/hls-cabal-plugin/test/Completer.hs --- a/plugins/hls-cabal-plugin/test/Completer.hs +++ b/plugins/hls-cabal-plugin/test/Completer.hs @@ -1,19 +1,25 @@ {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + module Completer where import Control.Lens ((^.), (^?)) import Control.Lens.Prism import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 as BS8 import Data.Maybe (mapMaybe) import qualified Data.Text as T import qualified Development.IDE.Plugin.Completions.Types as Ghcide +import qualified Distribution.Fields as Syntax import Distribution.PackageDescription (GenericPackageDescription) import Distribution.PackageDescription.Parsec (parseGenericPackageDescriptionMaybe) +import qualified Distribution.Parsec.Position as Syntax import Ide.Plugin.Cabal.Completion.Completer.FilePath import Ide.Plugin.Cabal.Completion.Completer.Module import Ide.Plugin.Cabal.Completion.Completer.Paths +import Ide.Plugin.Cabal.Completion.Completer.Simple (importCompleter) import Ide.Plugin.Cabal.Completion.Completer.Types (CompleterData (..)) import Ide.Plugin.Cabal.Completion.Completions import Ide.Plugin.Cabal.Completion.Types (CabalPrefixInfo (..), @@ -33,7 +39,8 @@ directoryCompleterTests, completionHelperTests, filePathExposedModulesTests, - exposedModuleCompleterTests + exposedModuleCompleterTests, + importCompleterTests ] basicCompleterTests :: TestTree @@ -290,23 +297,58 @@ completions @?== [] ] where - simpleCompleterData :: Maybe StanzaName -> FilePath -> T.Text -> CompleterData - simpleCompleterData sName dir pref = do - CompleterData - { cabalPrefixInfo = simpleExposedCabalPrefixInfo pref dir, - getLatestGPD = do - cabalContents <- ByteString.readFile $ testDataDir "exposed.cabal" - pure $ parseGenericPackageDescriptionMaybe cabalContents, - stanzaName = sName - } callModulesCompleter :: Maybe StanzaName -> (Maybe StanzaName -> GenericPackageDescription -> [FilePath]) -> T.Text -> IO [T.Text] callModulesCompleter sName func prefix = do let cData = simpleCompleterData sName testDataDir prefix completer <- modulesCompleter func mempty cData pure $ fmap extract completer +-- TODO: These tests are a bit barebones at the moment, +-- since we do not take cursorposition into account at this point. +importCompleterTests :: TestTree +importCompleterTests = + testGroup + "Import Completer Tests" + [ testCase "All above common sections are suggested" $ do + completions <- callImportCompleter + ("defaults" `elem` completions) @? "defaults contained" + ("test-defaults" `elem` completions) @? "test-defaults contained" + -- TODO: Only common sections defined before the current stanza may be imported + , testCase "Common sections occuring below are not suggested" $ do + completions <- callImportCompleter + ("notForLib" `elem` completions) @? "notForLib contained, this needs to be fixed" + , testCase "All common sections are suggested when curser is below them" $ do + completions <- callImportCompleter + completions @?== ["defaults", "notForLib" ,"test-defaults"] + ] + where + callImportCompleter :: IO [T.Text] + callImportCompleter = do + let cData' = simpleCompleterData Nothing testDataDir "" + let cabalCommonSections = [makeCommonSection 13 0 "defaults", makeCommonSection 18 0 "test-defaults", makeCommonSection 27 0 "notForLib"] + let cData = cData' {getCabalCommonSections = pure $ Just cabalCommonSections} + completer <- importCompleter mempty cData + pure $ fmap extract completer + makeCommonSection :: Int -> Int -> String -> Syntax.Field Syntax.Position + makeCommonSection row col name = + Syntax.Section + (Syntax.Name (Syntax.Position row col) "common") + [Syntax.SecArgName (Syntax.Position row (col + 7)) (BS8.pack name)] + [] + +simpleCompleterData :: Maybe StanzaName -> FilePath -> T.Text -> CompleterData +simpleCompleterData sName dir pref = do + CompleterData + { cabalPrefixInfo = simpleExposedCabalPrefixInfo pref dir, + getLatestGPD = do + cabalContents <- ByteString.readFile $ testDataDir "exposed.cabal" + pure $ parseGenericPackageDescriptionMaybe cabalContents, + getCabalCommonSections = undefined, + stanzaName = sName + } + mkCompleterData :: CabalPrefixInfo -> CompleterData -mkCompleterData prefInfo = CompleterData {getLatestGPD = undefined, cabalPrefixInfo = prefInfo, stanzaName = Nothing} +mkCompleterData prefInfo = CompleterData {getLatestGPD = undefined, getCabalCommonSections = undefined, cabalPrefixInfo = prefInfo, stanzaName = Nothing} exposedTestDir :: FilePath exposedTestDir = addTrailingPathSeparator $ testDataDir "src-modules" @@ -326,3 +368,41 @@ extract item = case item ^. L.textEdit of Just (InL v) -> v ^. L.newText _ -> error "" + +importTestData :: T.Text +importTestData = [trimming| +cabal-version: 3.0 +name: hls-cabal-plugin +version: 0.1.0.0 +synopsis: +homepage: +license: MIT +license-file: LICENSE +author: Fendor +maintainer: fendor@posteo.de +category: Development +extra-source-files: CHANGELOG.md + +common defaults + default-language: GHC2021 + -- Should have been in GHC2021, an oversight + default-extensions: ExplicitNamespaces + +common test-defaults + ghc-options: -threaded -rtsopts -with-rtsopts=-N + +library + import: + ^ + exposed-modules: IDE.Plugin.Cabal + build-depends: base ^>=4.14.3.0 + hs-source-dirs: src + default-language: Haskell2010 + +common notForLib + default-language: GHC2021 + +test-suite tests + import: + ^ +|] diff --git a/plugins/hls-cabal-plugin/test/Context.hs b/plugins/hls-cabal-plugin/test/Context.hs --- a/plugins/hls-cabal-plugin/test/Context.hs +++ b/plugins/hls-cabal-plugin/test/Context.hs @@ -154,6 +154,15 @@ , testCase "Top level - cursor in later line with partially written value" $ do ctx <- callGetContext (Position 5 13) "eee" topLevelData ctx @?= (TopLevel, KeyWord "name:") + , testCase "If is ignored" $ do + ctx <- callGetContext (Position 5 18) "" conditionalData + ctx @?= (Stanza "library" Nothing, None) + , testCase "Elif is ignored" $ do + ctx <- callGetContext (Position 7 18) "" conditionalData + ctx @?= (Stanza "library" Nothing, None) + , testCase "Else is ignored" $ do + ctx <- callGetContext (Position 9 18) "" conditionalData + ctx @?= (Stanza "library" Nothing, KeyWord "buildable:") , testCase "Named Stanza" $ do ctx <- callGetContext (Position 2 18) "" executableStanzaData ctx @?= (TopLevel, None) @@ -237,6 +246,18 @@ eee |] +conditionalData :: T.Text +conditionalData = [trimming| +cabal-version: 3.0 +name: simple-cabal +library + if os(windows) + buildable: + elif os(linux) + buildable: + else + buildable: +|] multiLineOptsData :: T.Text multiLineOptsData = [trimming| cabal-version: 3.0 diff --git a/plugins/hls-cabal-plugin/test/Definition.hs b/plugins/hls-cabal-plugin/test/Definition.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/Definition.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Definition ( + gotoDefinitionTests, +) where + +import Control.Lens ((^.)) +import Data.List.Extra (isSuffixOf) +import qualified Data.Text as T +import Ide.Plugin.Cabal.Definition (toHaskellFile) +import qualified Language.LSP.Protocol.Lens as L +import qualified Language.LSP.Protocol.Types as LSP +import System.FilePath +import Test.Hls +import Utils + + +gotoDefinitionTests :: TestTree +gotoDefinitionTests = testGroup "Goto Definition" + [ gotoCommonSectionDefinitionTests + , gotoModuleDefinitionTests + ] + +gotoModuleDefinitionTests :: TestTree +gotoModuleDefinitionTests = testGroup "Goto Module Definition" + [ testGoToDefinitionLink "simple cabal test" "simple-cabal" "simple-cabal.cabal" + (Position 8 23) (toTestHaskellPath "" "A") + + , testGoToDefinitionLink "library start of exposed-modules" ("goto-definition" "modules") "module-examples.cabal" + (Position 6 22) (toTestHaskellPath "src" "Library.Lib") + , testGoToDefinitionLink "library middle of exposed-modules" ("goto-definition" "modules") "module-examples.cabal" + (Position 6 29) (toTestHaskellPath "src" "Library.Lib") + , testGoToDefinitionLink "library end of exposed-modules" ("goto-definition" "modules") "module-examples.cabal" + (Position 6 33) (toTestHaskellPath "src" "Library.Lib") + , testGoToDefinitionLink "library start of other-modules" ("goto-definition" "modules") "module-examples.cabal" + (Position 9 22) (toTestHaskellPath "src" "Library.Other.OtherLib") + , testGoToDefinitionLink "library end of other-modules" ("goto-definition" "modules") "module-examples.cabal" + (Position 9 44) (toTestHaskellPath "src" "Library.Other.OtherLib") + + , testGoToDefinitionLink "executable other-modules" ("goto-definition" "modules") "module-examples.cabal" + (Position 22 10) (toTestHaskellPath ("src" "exe") "Config") + + , testGoToDefinitionLink "test-suite other-modules Config" ("goto-definition" "modules") "module-examples.cabal" + (Position 31 10) (toTestHaskellPath ("src" "test") "Config") + , testGoToDefinitionLink "test-suite other-modules Library" ("goto-definition" "modules") "module-examples.cabal" + (Position 34 10) (toTestHaskellPath ("src" "test") "Library") + + , testGoToDefinitionLink "benchmark other-modules Config" ("goto-definition" "modules") "module-examples.cabal" + (Position 45 30) (toTestHaskellPath ("src" "bench") "Config") + + , testGoToDefinitionLinkNoLocation "not existent module" ("goto-definition" "modules") "module-examples.cabal" (Position 48 25) + , testGoToDefinitionLinkNoLocation "behind module" ("goto-definition" "modules") "module-examples.cabal" (Position 9 20) + , testGoToDefinitionLinkNoLocation "after module" ("goto-definition" "modules") "module-examples.cabal" (Position 9 50) + ] + where + toTestHaskellPath :: FilePath -> T.Text -> FilePath + toTestHaskellPath dir moduleName = dir toHaskellFile moduleName + + getUriFromDefinition :: Show b => (Definition |? b) -> Uri + getUriFromDefinition (InL (Definition (InL loc))) = loc^.L.uri + getUriFromDefinition unk = error $ "Unexpected pattern '" ++ show unk ++ "' , expected '(InL (Definition (InL loc))'" + + testGoToDefinitionLink :: TestName -> FilePath -> FilePath -> Position -> FilePath -> TestTree + testGoToDefinitionLink testName testDir cabalFile cursorPos expectedFilePath = + runCabalTestCaseSession testName testDir $ do + doc <- openDoc cabalFile "cabal" + definitions <- getDefinitions doc cursorPos + let uri = getUriFromDefinition definitions + mFilePath = (testDir ) <$> uriToFilePath uri + case mFilePath of + Nothing -> error $ "Not possible to convert Uri " <> show uri <> " to FilePath" + Just filePath -> do + let filePathWithDir = testDir expectedFilePath + isCorrectPath = filePathWithDir `isSuffixOf` filePath + liftIO $ isCorrectPath @? ("Absolute path expected to end on " <> filePathWithDir <> + " but " <> filePath <> " was given.") + + testGoToDefinitionLinkNoLocation :: TestName -> FilePath -> FilePath -> Position -> TestTree + testGoToDefinitionLinkNoLocation testName testDir cabalFile cursorPos = + runCabalTestCaseSession testName testDir $ do + doc <- openDoc cabalFile "cabal" + empty <- getDefinitions doc cursorPos + liftIO $ empty @?= (InR $ InR LSP.Null) + +gotoCommonSectionDefinitionTests :: TestTree +gotoCommonSectionDefinitionTests = testGroup "Goto Common Section Definition" + [ positiveTest "middle of identifier" (Position 27 16) (mkRange 6 0 7 22) + , positiveTest "left of identifier" (Position 30 12) (mkRange 10 0 17 40) + , positiveTest "right of identifier" (Position 33 22) (mkRange 20 0 23 34) + , positiveTest "left of '-' in identifier" (Position 36 20) (mkRange 6 0 7 22) + , positiveTest "right of '-' in identifier" (Position 39 19) (mkRange 10 0 17 40) + , positiveTest "identifier in identifier list" (Position 42 16) (mkRange 20 0 23 34) + , positiveTest "left of ',' right of identifier" (Position 45 33) (mkRange 10 0 17 40) + , positiveTest "right of ',' left of identifier" (Position 48 34) (mkRange 6 0 7 22) + + , negativeTest "right of ',' left of space" (Position 51 23) + , negativeTest "right of ':' left of space" (Position 54 11) + , negativeTest "not a definition" (Position 57 8) + , negativeTest "empty space" (Position 59 7) + ] + where + getRangeFromDefinition :: Show b => (Definition |? b) -> Range + getRangeFromDefinition (InL (Definition (InL loc))) = loc^.L.range + getRangeFromDefinition unk = error $ "Unexpected pattern '" ++ show unk ++ "' , expected '(InL (Definition (InL loc))'" + + -- A positive test checks if the provided range is equal + -- to the expected range from the definition in the test file. + -- The test emulates a goto-definition request of an actual definition. + positiveTest :: TestName -> Position -> Range -> TestTree + positiveTest testName cursorPos expectedRange = + runCabalTestCaseSession testName ("goto-definition" "common-section") $ do + doc <- openDoc "simple-with-common.cabal" "cabal" + definitions <- getDefinitions doc cursorPos + let range = getRangeFromDefinition definitions + liftIO $ range @?= expectedRange + + -- A negative test checks if the request failed and + -- the provided result is empty, i.e. `InR $ InR Null`. + -- The test emulates a goto-definition request of anything but an + -- actual definition. + negativeTest :: TestName -> Position -> TestTree + negativeTest testName cursorPos = + runCabalTestCaseSession testName ("goto-definition" "common-section") $ do + doc <- openDoc "simple-with-common.cabal" "cabal" + empty <- getDefinitions doc cursorPos + liftIO $ empty @?= (InR $ InR LSP.Null) diff --git a/plugins/hls-cabal-plugin/test/Main.hs b/plugins/hls-cabal-plugin/test/Main.hs --- a/plugins/hls-cabal-plugin/test/Main.hs +++ b/plugins/hls-cabal-plugin/test/Main.hs @@ -6,17 +6,22 @@ main, ) where +import CabalAdd (cabalAddTests) import Completer (completerTests) import Context (contextTests) import Control.Lens ((^.)) +import Control.Lens.Fold ((^?)) import Control.Monad (guard) import qualified Data.ByteString as BS import Data.Either (isRight) +import Data.List.Extra (nubOrdOn) +import qualified Data.Maybe as Maybe import qualified Data.Text as T -import qualified Data.Text as Text +import Definition (gotoDefinitionTests) import Ide.Plugin.Cabal.LicenseSuggest (licenseErrorSuggestion) import qualified Ide.Plugin.Cabal.Parse as Lib import qualified Language.LSP.Protocol.Lens as L +import Outline (outlineTests) import System.FilePath import Test.Hls import Utils @@ -30,6 +35,10 @@ , pluginTests , completerTests , contextTests + , outlineTests + , codeActionTests + , gotoDefinitionTests + , hoverTests ] -- ------------------------------------------------------------------------ @@ -79,6 +88,7 @@ where maxCompletions = 100 + -- ------------------------ ------------------------------------------------ -- Integration Tests -- ------------------------------------------------------------------------ @@ -90,23 +100,31 @@ [ testGroup "Diagnostics" [ runCabalTestCaseSession "Publishes Diagnostics on Error" "" $ do - doc <- openDoc "invalid.cabal" "cabal" - diags <- waitForDiagnosticsFromSource doc "cabal" + _ <- openDoc "invalid.cabal" "cabal" + diags <- cabalCaptureKick unknownLicenseDiag <- liftIO $ inspectDiagnostic diags ["Unknown SPDX license identifier: 'BSD3'"] liftIO $ do length diags @?= 1 unknownLicenseDiag ^. L.range @?= Range (Position 3 24) (Position 4 0) unknownLicenseDiag ^. L.severity @?= Just DiagnosticSeverity_Error + , runCabalTestCaseSession "Publishes Diagnostics on unsupported cabal version as Warning" "" $ do + _ <- openDoc "unsupportedVersion.cabal" "cabal" + diags <- cabalCaptureKick + unknownVersionDiag <- liftIO $ inspectDiagnosticAny diags ["Unsupported cabal-version 99999.0", "Unsupported cabal format version in cabal-version field: 99999.0"] + liftIO $ do + length diags @?= 1 + unknownVersionDiag ^. L.range @?= Range (Position 0 0) (Position 1 0) + unknownVersionDiag ^. L.severity @?= Just DiagnosticSeverity_Warning , runCabalTestCaseSession "Clears diagnostics" "" $ do doc <- openDoc "invalid.cabal" "cabal" - diags <- waitForDiagnosticsFrom doc + diags <- cabalCaptureKick unknownLicenseDiag <- liftIO $ inspectDiagnostic diags ["Unknown SPDX license identifier: 'BSD3'"] liftIO $ do length diags @?= 1 unknownLicenseDiag ^. L.range @?= Range (Position 3 24) (Position 4 0) unknownLicenseDiag ^. L.severity @?= Just DiagnosticSeverity_Error _ <- applyEdit doc $ TextEdit (Range (Position 3 20) (Position 4 0)) "BSD-3-Clause\n" - newDiags <- waitForDiagnosticsFrom doc + newDiags <- cabalCaptureKick liftIO $ newDiags @?= [] , runCabalTestCaseSession "No Diagnostics in .hs files from valid .cabal file" "simple-cabal" $ do hsDoc <- openDoc "A.hs" "haskell" @@ -137,60 +155,130 @@ unknownLicenseDiag ^. L.range @?= Range (Position 3 24) (Position 4 0) unknownLicenseDiag ^. L.severity @?= Just DiagnosticSeverity_Error ] - , testGroup - "Code Actions" - [ runCabalTestCaseSession "BSD-3" "" $ do - doc <- openDoc "licenseCodeAction.cabal" "cabal" - diags <- waitForDiagnosticsFromSource doc "cabal" - reduceDiag <- liftIO $ inspectDiagnostic diags ["Unknown SPDX license identifier: 'BSD3'"] - liftIO $ do - length diags @?= 1 - reduceDiag ^. L.range @?= Range (Position 3 24) (Position 4 0) - reduceDiag ^. L.severity @?= Just DiagnosticSeverity_Error - [codeAction] <- getLicenseAction "BSD-3-Clause" <$> getCodeActions doc (Range (Position 3 24) (Position 4 0)) - executeCodeAction codeAction - contents <- documentContents doc - liftIO $ - contents - @?= Text.unlines - [ "cabal-version: 3.0" - , "name: licenseCodeAction" - , "version: 0.1.0.0" - , "license: BSD-3-Clause" - , "" - , "library" - , " build-depends: base" - , " default-language: Haskell2010" - ] - , runCabalTestCaseSession "Apache-2.0" "" $ do - doc <- openDoc "licenseCodeAction2.cabal" "cabal" - diags <- waitForDiagnosticsFromSource doc "cabal" - -- test if it supports typos in license name, here 'apahe' - reduceDiag <- liftIO $ inspectDiagnostic diags ["Unknown SPDX license identifier: 'APAHE'"] - liftIO $ do - length diags @?= 1 - reduceDiag ^. L.range @?= Range (Position 3 25) (Position 4 0) - reduceDiag ^. L.severity @?= Just DiagnosticSeverity_Error - [codeAction] <- getLicenseAction "Apache-2.0" <$> getCodeActions doc (Range (Position 3 24) (Position 4 0)) - executeCodeAction codeAction - contents <- documentContents doc - liftIO $ - contents - @?= Text.unlines - [ "cabal-version: 3.0" - , "name: licenseCodeAction2" - , "version: 0.1.0.0" - , "license: Apache-2.0" - , "" - , "library" - , " build-depends: base" - , " default-language: Haskell2010" - ] - ] ] +-- ---------------------------------------------------------------------------- +-- Code Action Tests +-- ---------------------------------------------------------------------------- + +codeActionTests :: TestTree +codeActionTests = testGroup "Code Actions" + [ runCabalTestCaseSession "BSD-3" "" $ do + doc <- openDoc "licenseCodeAction.cabal" "cabal" + diags <- waitForDiagnosticsFromSource doc "cabal" + reduceDiag <- liftIO $ inspectDiagnostic diags ["Unknown SPDX license identifier: 'BSD3'"] + liftIO $ do + length diags @?= 1 + reduceDiag ^. L.range @?= Range (Position 3 24) (Position 4 0) + reduceDiag ^. L.severity @?= Just DiagnosticSeverity_Error + [codeAction] <- getLicenseAction "BSD-3-Clause" <$> getCodeActions doc (Range (Position 3 24) (Position 4 0)) + executeCodeAction codeAction + contents <- documentContents doc + liftIO $ + contents + @?= T.unlines + [ "cabal-version: 3.0" + , "name: licenseCodeAction" + , "version: 0.1.0.0" + , "license: BSD-3-Clause" + , "" + , "library" + , " build-depends: base" + , " default-language: Haskell2010" + ] + , runCabalTestCaseSession "Apache-2.0" "" $ do + doc <- openDoc "licenseCodeAction2.cabal" "cabal" + diags <- waitForDiagnosticsFromSource doc "cabal" + -- test if it supports typos in license name, here 'apahe' + reduceDiag <- liftIO $ inspectDiagnostic diags ["Unknown SPDX license identifier: 'APAHE'"] + liftIO $ do + length diags @?= 1 + reduceDiag ^. L.range @?= Range (Position 3 25) (Position 4 0) + reduceDiag ^. L.severity @?= Just DiagnosticSeverity_Error + [codeAction] <- getLicenseAction "Apache-2.0" <$> getCodeActions doc (Range (Position 3 24) (Position 4 0)) + executeCodeAction codeAction + contents <- documentContents doc + liftIO $ + contents + @?= T.unlines + [ "cabal-version: 3.0" + , "name: licenseCodeAction2" + , "version: 0.1.0.0" + , "license: Apache-2.0" + , "" + , "library" + , " build-depends: base" + , " default-language: Haskell2010" + ] + , runCabalGoldenSession "Code Actions - Can fix field names" "code-actions" "FieldSuggestions" $ \doc -> do + _ <- waitForDiagnosticsFrom doc + cas <- Maybe.mapMaybe (^? _R) <$> getAllCodeActions doc + -- Filter out the code actions we want to invoke. + -- We only want to invoke Code Actions with certain titles, and + -- we want to invoke them only once, not once for each cursor request. + -- 'getAllCodeActions' iterates over each cursor position and requests code actions. + let selectedCas = nubOrdOn (^. L.title) $ filter + (\ca -> (ca ^. L.title) `elem` + [ "Replace with license" + , "Replace with build-type" + , "Replace with extra-doc-files" + , "Replace with ghc-options" + , "Replace with location" + , "Replace with default-language" + , "Replace with import" + , "Replace with build-depends" + , "Replace with main-is" + , "Replace with hs-source-dirs" + ]) cas + mapM_ executeCodeAction selectedCas + pure () + , cabalAddTests + ] where getLicenseAction :: T.Text -> [Command |? CodeAction] -> [CodeAction] getLicenseAction license codeActions = do InR action@CodeAction{_title} <- codeActions guard (_title == "Replace with " <> license) pure action + +-- ---------------------------------------------------------------------------- +-- Hover Tests +-- ---------------------------------------------------------------------------- + +hoverTests :: TestTree +hoverTests = testGroup "Hover" + [ hoverOnDependencyTests + ] + +hoverOnDependencyTests :: TestTree +hoverOnDependencyTests = testGroup "Hover Dependency" + [ hoverContainsTest "base with separated version" "hover-deps.cabal" (Position 6 25) "[Documentation](https://hackage.haskell.org/package/base)" + , hoverContainsTest "aeson with not separated version " "hover-deps.cabal" (Position 7 25) "[Documentation](https://hackage.haskell.org/package/aeson)" + , hoverContainsTest "lens no version" "hover-deps.cabal" (Position 7 42) "[Documentation](https://hackage.haskell.org/package/lens)" + + , hoverIsNullTest "name has no documentation" "hover-deps.cabal" (Position 1 25) + , hoverIsNullTest "exposed-modules has no documentation" "hover-deps.cabal" (Position 5 25) + , hoverIsNullTest "hs-source-dirs has no documentation" "hover-deps.cabal" (Position 8 25) + ] + where + hoverContainsTest :: TestName -> FilePath -> Position -> T.Text -> TestTree + hoverContainsTest testName cabalFile pos containedText = + runCabalTestCaseSession testName "hover" $ do + doc <- openDoc cabalFile "cabal" + h <- getHover doc pos + case h of + Nothing -> liftIO $ assertFailure "No hover" + Just (Hover contents _) -> case contents of + InL (MarkupContent _ txt) -> do + liftIO + $ assertBool ("Failed to find `" <> T.unpack containedText <> "` in hover message: " <> T.unpack txt) + $ containedText `T.isInfixOf` txt + _ -> liftIO $ assertFailure "Unexpected content type" + closeDoc doc + + hoverIsNullTest :: TestName -> FilePath -> Position -> TestTree + hoverIsNullTest testName cabalFile pos = + runCabalTestCaseSession testName "hover" $ do + doc <- openDoc cabalFile "cabal" + h <- getHover doc pos + liftIO $ assertBool ("Found hover `" <> show h <> "`") $ Maybe.isNothing h + closeDoc doc diff --git a/plugins/hls-cabal-plugin/test/Outline.hs b/plugins/hls-cabal-plugin/test/Outline.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/Outline.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Outline ( + outlineTests, +) where + +import Language.LSP.Protocol.Types (DocumentSymbol (..), + Position (..), Range (..)) +import qualified Test.Hls as T +import Utils + +testSymbols :: (T.HasCallStack) => T.TestName -> FilePath -> [DocumentSymbol] -> T.TestTree +testSymbols testName path expectedSymbols = + runCabalTestCaseSession testName "outline-cabal" $ do + docId <- T.openDoc path "cabal" + symbols <- T.getDocumentSymbols docId + T.liftIO $ symbols T.@?= Right expectedSymbols + +outlineTests :: T.TestTree +outlineTests = + T.testGroup + "Cabal Outline Tests" + [ testSymbols + "cabal Field outline test" + "field.cabal" + [fieldDocumentSymbol] + , testSymbols + "cabal FieldLine outline test" + "fieldline.cabal" + [fieldLineDocumentSymbol] + , testSymbols + "cabal Section outline test" + "section.cabal" + [sectionDocumentSymbol] + , testSymbols + "cabal SectionArg outline test" + "sectionarg.cabal" + [sectionArgDocumentSymbol] + ] + where + fieldDocumentSymbol :: DocumentSymbol + fieldDocumentSymbol = + ( defDocumentSymbol + ( Range { _start = Position{_line = 0, _character = 0} + , _end = Position{_line = 0, _character = 8} }) + ) + { _name = "homepage" + , _kind = T.SymbolKind_Field + , _children = Nothing + } + fieldLineDocumentSymbol :: DocumentSymbol + fieldLineDocumentSymbol = + ( defDocumentSymbol + ( Range { _start = Position{_line = 0, _character = 0} + , _end = Position{_line = 0, _character = 13} }) + ) + { _name = "cabal-version" + , _kind = T.SymbolKind_Field + , _children = Nothing -- the values of fieldLine are removed from the outline + } + sectionDocumentSymbol :: DocumentSymbol + sectionDocumentSymbol = + ( defDocumentSymbol + ( Range { _start = Position{_line = 0, _character = 2} + , _end = Position{_line = 0, _character = 15} }) + ) + { _name = "build-depends" + , _kind = T.SymbolKind_Field + , _children = Nothing -- the values of fieldLine are removed from the outline + } + sectionArgDocumentSymbol :: DocumentSymbol + sectionArgDocumentSymbol = + ( defDocumentSymbol + ( Range { _start = Position{_line = 0, _character = 2} + , _end = Position{_line = 0, _character = 19} }) + ) + { _name = "if os ( windows )" + , _kind = T.SymbolKind_Object + , _children = Just $ [sectionArgChildrenDocumentSymbol] + } + sectionArgChildrenDocumentSymbol :: DocumentSymbol + sectionArgChildrenDocumentSymbol = + ( defDocumentSymbol + ( Range { _start = Position{_line = 1, _character = 4} + , _end = Position{_line = 1, _character = 17} }) + ) + { _name = "build-depends" + , _kind = T.SymbolKind_Field + , _children = Nothing + } + +defDocumentSymbol :: Range -> DocumentSymbol +defDocumentSymbol range = + DocumentSymbol + { _detail = Nothing + , _deprecated = Nothing + , _name = "" + , _kind = T.SymbolKind_File + , _range = range + , _selectionRange = range + , _children = Nothing + , _tags = Nothing + } diff --git a/plugins/hls-cabal-plugin/test/Utils.hs b/plugins/hls-cabal-plugin/test/Utils.hs --- a/plugins/hls-cabal-plugin/test/Utils.hs +++ b/plugins/hls-cabal-plugin/test/Utils.hs @@ -1,19 +1,27 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} module Utils where +import Control.Monad (guard) import Data.List (sort) +import Data.Proxy (Proxy (Proxy)) import qualified Data.Text as T -import Ide.Plugin.Cabal (descriptor) +import Ide.Plugin.Cabal (descriptor, + haskellInteractionDescriptor) import qualified Ide.Plugin.Cabal import Ide.Plugin.Cabal.Completion.Types import System.FilePath import Test.Hls + cabalPlugin :: PluginTestDescriptor Ide.Plugin.Cabal.Log cabalPlugin = mkPluginTestDescriptor descriptor "cabal" +cabalHaskellPlugin :: PluginTestDescriptor Ide.Plugin.Cabal.Log +cabalHaskellPlugin = mkPluginTestDescriptor haskellInteractionDescriptor "cabal-haskell" + simpleCabalPrefixInfoFromPos :: Position -> T.Text -> CabalPrefixInfo simpleCabalPrefixInfoFromPos pos prefix = CabalPrefixInfo @@ -42,12 +50,34 @@ runCabalTestCaseSession :: TestName -> FilePath -> Session () -> TestTree runCabalTestCaseSession title subdir = testCase title . runCabalSession subdir +runHaskellTestCaseSession :: TestName -> FilePath -> Session () -> TestTree +runHaskellTestCaseSession title subdir = testCase title . runHaskellAndCabalSession subdir + runCabalSession :: FilePath -> Session a -> IO a runCabalSession subdir = failIfSessionTimeout . runSessionWithServer def cabalPlugin (testDataDir subdir) +runHaskellAndCabalSession :: FilePath -> Session a -> IO a +runHaskellAndCabalSession subdir = + failIfSessionTimeout . runSessionWithServer def (cabalPlugin <> cabalHaskellPlugin) (testDataDir subdir) + +runCabalGoldenSession :: TestName -> FilePath -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree +runCabalGoldenSession title subdir fp act = goldenWithCabalDoc def cabalPlugin title testDataDir (subdir fp) "golden" "cabal" act + testDataDir :: FilePath testDataDir = "plugins" "hls-cabal-plugin" "test" "testdata" + +-- | these functions are used to detect cabal kicks +-- and look at diagnostics for cabal files +-- kicks are run everytime there is a shake session run/restart +cabalKickDone :: Session () +cabalKickDone = kick (Proxy @"kick/done/cabal") >>= guard . not . null + +cabalKickStart :: Session () +cabalKickStart = kick (Proxy @"kick/start/cabal") >>= guard . not . null + +cabalCaptureKick :: Session [Diagnostic] +cabalCaptureKick = captureKickDiagnostics cabalKickStart cabalKickDone -- | list comparison where the order in the list is irrelevant (@?==) :: (HasCallStack, Ord a, Show a) => [a] -> [a] -> Assertion diff --git a/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-bench/bench/Main.hs b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-bench/bench/Main.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-bench/bench/Main.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Data.List.Split + +main :: IO () +main = putStrLn "Test suite not yet implemented." diff --git a/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-bench/cabal-add-bench.cabal b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-bench/cabal-add-bench.cabal new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-bench/cabal-add-bench.cabal @@ -0,0 +1,17 @@ +cabal-version: 2.4 +name: cabal-add-bench +version: 0.1.0.0 +license: NONE +author: George Gerasev +maintainer: george30032002@gmail.com +build-type: Simple + +common warnings + ghc-options: -Wall + +benchmark benchmark + type: exitcode-stdio-1.0 + ghc-options: -threaded + main-is: Main.hs + hs-source-dirs: bench + build-depends: base diff --git a/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-exe/cabal-add-exe.cabal b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-exe/cabal-add-exe.cabal new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-exe/cabal-add-exe.cabal @@ -0,0 +1,15 @@ +cabal-version: 2.4 +name: cabal-add-exe +version: 0.1.0.0 +build-type: Simple + +executable cabal-add-exe + main-is: Main.hs + hs-source-dirs: src + ghc-options: -Wall + build-depends: base + default-language: Haskell2010 + +library + build-depends: base >= 4 && < 5 + ghc-options: -Wall diff --git a/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-exe/src/Main.hs b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-exe/src/Main.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-exe/src/Main.hs @@ -0,0 +1,5 @@ +module Main where + +import Data.List.Split + +main = putStrLn "Hello, Haskell!" diff --git a/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-lib/cabal-add-lib.cabal b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-lib/cabal-add-lib.cabal new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-lib/cabal-add-lib.cabal @@ -0,0 +1,17 @@ +cabal-version: 2.4 +name: cabal-add-lib +version: 0.1.0.0 +license: NONE +author: George Gerasev +maintainer: george30032002@gmail.com +build-type: Simple + +common warnings + ghc-options: -Wall + +library + import: warnings + exposed-modules: MyLib + build-depends: base + hs-source-dirs: src + default-language: Haskell2010 diff --git a/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-lib/src/MyLib.hs b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-lib/src/MyLib.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-lib/src/MyLib.hs @@ -0,0 +1,6 @@ +module MyLib (someFunc) where + +import Data.List.Split + +someFunc :: IO () +someFunc = putStrLn "someFunc" diff --git a/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-multitarget/bench/Main.hs b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-multitarget/bench/Main.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-multitarget/bench/Main.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Data.List.Split + +main :: IO () +main = putStrLn "Test suite not yet implemented." diff --git a/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-multitarget/cabal-add-multitarget.cabal b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-multitarget/cabal-add-multitarget.cabal new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-multitarget/cabal-add-multitarget.cabal @@ -0,0 +1,33 @@ +cabal-version: 2.4 +name: cabal-add-multitarget +version: 0.1.0.0 +build-type: Simple + +executable cabal-add-exe + main-is: Main.hs + hs-source-dirs: src + ghc-options: -Wall + build-depends: base + default-language: Haskell2010 + +library + exposed-modules: MyLib + other-modules: InternalLib + build-depends: base >= 4 && < 5 + hs-source-dirs: lib + ghc-options: -Wall + +test-suite cabal-add-tests-test + main-is: Main.hs + hs-source-dirs: test + type: exitcode-stdio-1.0 + build-depends: base + default-language: Haskell2010 + +benchmark benchmark + main-is: Main.hs + build-depends: base + hs-source-dirs: bench + type: exitcode-stdio-1.0 + ghc-options: -threaded + diff --git a/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-multitarget/lib/InternalLib.hs b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-multitarget/lib/InternalLib.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-multitarget/lib/InternalLib.hs @@ -0,0 +1,6 @@ +module InternalLib (internalFunc) where + +import Data.List.Split + +internalFunc :: IO () +internalFunc = putStrLn "internalFunc" diff --git a/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-multitarget/lib/MyLib.hs b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-multitarget/lib/MyLib.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-multitarget/lib/MyLib.hs @@ -0,0 +1,6 @@ +module MyLib (someFunc) where + +import Data.List.Split + +someFunc :: IO () +someFunc = putStrLn "someFunc" diff --git a/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-multitarget/src/Main.hs b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-multitarget/src/Main.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-multitarget/src/Main.hs @@ -0,0 +1,5 @@ +module Main where + +import Data.List.Split + +main = putStrLn "Hello, Haskell!" diff --git a/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-multitarget/test/Main.hs b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-multitarget/test/Main.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-multitarget/test/Main.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Data.List.Split + +main :: IO () +main = putStrLn "Test suite not yet implemented." diff --git a/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-packageYaml/cabal-add-packageYaml.cabal b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-packageYaml/cabal-add-packageYaml.cabal new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-packageYaml/cabal-add-packageYaml.cabal @@ -0,0 +1,17 @@ +cabal-version: 2.4 +name: cabal-add-packageYaml +version: 0.1.0.0 +license: NONE +author: George Gerasev +maintainer: george30032002@gmail.com +build-type: Simple + +common warnings + ghc-options: -Wall + +benchmark benchmark-packageYaml + type: exitcode-stdio-1.0 + ghc-options: -threaded + main-is: Main.hs + hs-source-dirs: bench + build-depends: base diff --git a/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-packageYaml/package.yaml b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-packageYaml/package.yaml new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-packageYaml/package.yaml diff --git a/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-packageYaml/src/Main.hs b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-packageYaml/src/Main.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-packageYaml/src/Main.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Data.List.Split + +main :: IO () +main = putStrLn "Test suite not yet implemented." diff --git a/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-tests/cabal-add-tests.cabal b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-tests/cabal-add-tests.cabal new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-tests/cabal-add-tests.cabal @@ -0,0 +1,18 @@ +cabal-version: 2.4 +name: cabal-add-tests +version: 0.1.0.0 +license: NONE +author: George Gerasev +maintainer: george30032002@gmail.com +build-type: Simple + +common warnings + ghc-options: -Wall + +test-suite cabal-add-tests-test + import: warnings + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: base diff --git a/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-tests/test/Main.hs b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-tests/test/Main.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-tests/test/Main.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Data.List.Split + +main :: IO () +main = putStrLn "Test suite not yet implemented." diff --git a/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal.project b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal.project new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal.project @@ -0,0 +1,6 @@ +packages: cabal-add-exe + cabal-add-lib + cabal-add-tests + cabal-add-bench + cabal-add-multitarget + cabal-add-packageYaml diff --git a/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/hie.yaml b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/hie.yaml new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/hie.yaml @@ -0,0 +1,2 @@ +cradle: + cabal: diff --git a/plugins/hls-cabal-plugin/test/testdata/code-actions/FieldSuggestions.cabal b/plugins/hls-cabal-plugin/test/testdata/code-actions/FieldSuggestions.cabal new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/code-actions/FieldSuggestions.cabal @@ -0,0 +1,36 @@ +cabal-version: 3.0 +name: FieldSuggestions +version: 0.1.0 +licens: BSD-3-Clause + +buil-type: Simple + +extra-doc-fils: + ChangeLog + +-- Default warnings in HLS +common warnings + ghc-option: -Wall + -Wredundant-constraints + -Wunused-packages + -Wno-name-shadowing + -Wno-unticked-promoted-constructors + +source-repository head + type: git + loc: fake + +library + default-lang: Haskell2010 + -- Import isn't supported right now. + impor: warnings + build-dep: base + +executable my-exe + mains: Main.hs + +test-suite Test + type: exitcode-stdio-1.0 + main-is: Test.hs + hs-source-drs: + diff --git a/plugins/hls-cabal-plugin/test/testdata/code-actions/FieldSuggestions.golden.cabal b/plugins/hls-cabal-plugin/test/testdata/code-actions/FieldSuggestions.golden.cabal new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/code-actions/FieldSuggestions.golden.cabal @@ -0,0 +1,36 @@ +cabal-version: 3.0 +name: FieldSuggestions +version: 0.1.0 +license: BSD-3-Clause + +build-type: Simple + +extra-doc-files: + ChangeLog + +-- Default warnings in HLS +common warnings + ghc-options: -Wall + -Wredundant-constraints + -Wunused-packages + -Wno-name-shadowing + -Wno-unticked-promoted-constructors + +source-repository head + type: git + location: fake + +library + default-language: Haskell2010 + -- Import isn't supported right now. + import: warnings + build-depends: base + +executable my-exe + main-is: Main.hs + +test-suite Test + type: exitcode-stdio-1.0 + main-is: Test.hs + hs-source-dirs: + diff --git a/plugins/hls-cabal-plugin/test/testdata/goto-definition/common-section/simple-with-common.cabal b/plugins/hls-cabal-plugin/test/testdata/goto-definition/common-section/simple-with-common.cabal new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/goto-definition/common-section/simple-with-common.cabal @@ -0,0 +1,62 @@ +cabal-version: 3.0 +name: simple-cabal +version: 0.1.0.0 +license: MIT + +-- Range : (6, 0) - (7, 22) +common warnings-0 + ghc-options: -Wall + +-- Range : (10, 0) - (17, 40) +common warnings-1 + ghc-options: -Wall + -Wredundant-constraints + -Wunused-packages + + -Wno-name-shadowing + + -Wno-unticked-promoted-constructors + +-- Range : (20, 0) - (23, 34) +common warnings-2 + ghc-options: -Wall + -Wredundant-constraints + -Wunused-packages + +library + + import: warnings-0 +-- ^ Position: (27, 16), middle of identifier + + import: warnings-1 +-- ^ Position: (30, 12), left of identifier + + import: warnings-2 +-- ^ Position: (33, 22), right of identifier + + import: warnings-0 +-- ^ Position: (36, 20), left of '-' in identifier + + import: warnings-1 +-- ^ Position: (39, 19), right of "-" in identifier + + import: warnings-2,warnings-1,warnings-0 +-- ^ Position: (42, 16), identifier in identifier list + + import: warnings-2,warnings-1,warnings-0 +-- ^ Position: (45, 33), left of ',' right of identifier + + import: warnings-2,warnings-1,warnings-0 +-- ^ Position: (48, 34), right of ',' left of identifier + + import: warnings-2, warnings-1,warnings-0 +-- ^ Position: (51, 37), right of ',' left of space + + import: warnings-0 +-- ^ Position: (54, 11), right of ':' left of space + + import: warnings-0 +-- ^ Position: (57, 8), not a definition + + -- EOL +-- ^ Position: (59, 7), empty space diff --git a/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/module-examples.cabal b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/module-examples.cabal new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/module-examples.cabal @@ -0,0 +1,51 @@ +cabal-version: 3.0 +name: module-examples +version: 0.1.0.0 + + +library + exposed-modules: Library.Lib +-- ^ Position: (6, 22) +-- ^ Position: (6, 33) + other-modules: Library.Other.OtherLib +-- ^ Position: (9, 22) +-- ^ Position: (9, 44) + + build-depends: base + hs-source-dirs: src + default-language: Haskell2010 + +executable exec + hs-source-dirs: src/exe + main-is: Main.hs + build-depends: base + other-modules: + Config +-- ^ Position: (22, 8) +-- ^ Position: (22, 14) + +test-suite module-examples-test + type: exitcode-stdio-1.0 + hs-source-dirs: src/test + main-is: Main.hs + other-modules: + Config +-- ^ Position: (31, 8) +-- ^ Position: (31, 14) + Library +-- ^ Position: (34, 8) +-- ^ Position: (34, 15) + build-depends: base + +benchmark benchmark + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: src/bench + build-depends: base + other-modules: + Config +-- ^ Position: (45, 28) +-- ^ Position: (45, 34) + NotExistent +-- ^ Position: (48, 19) +-- ^ Position: (48, 30) diff --git a/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/Library/Lib.hs b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/Library/Lib.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/Library/Lib.hs @@ -0,0 +1,1 @@ +module Library.Lib where diff --git a/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/Library/Other/OtherLib.hs b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/Library/Other/OtherLib.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/Library/Other/OtherLib.hs @@ -0,0 +1,1 @@ +module Library.Other.OtherLib where diff --git a/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/bench/Config.hs b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/bench/Config.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/bench/Config.hs @@ -0,0 +1,1 @@ +module Config where diff --git a/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/bench/Main.hs b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/bench/Main.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/bench/Main.hs @@ -0,0 +1,3 @@ +module Main where + +main = undefined diff --git a/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/exe/Config.hs b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/exe/Config.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/exe/Config.hs @@ -0,0 +1,1 @@ +module Confing where diff --git a/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/exe/Main.hs b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/exe/Main.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/exe/Main.hs @@ -0,0 +1,3 @@ +module Main where + +main = undefined diff --git a/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/test/Config.hs b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/test/Config.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/test/Config.hs @@ -0,0 +1,1 @@ +module Config where diff --git a/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/test/Library.hs b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/test/Library.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/test/Library.hs @@ -0,0 +1,1 @@ +module Library where diff --git a/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/test/Main.hs b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/test/Main.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/test/Main.hs diff --git a/plugins/hls-cabal-plugin/test/testdata/goto-definition/simple-with-common.cabal b/plugins/hls-cabal-plugin/test/testdata/goto-definition/simple-with-common.cabal new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/goto-definition/simple-with-common.cabal @@ -0,0 +1,62 @@ +cabal-version: 3.0 +name: simple-cabal +version: 0.1.0.0 +license: MIT + +-- Range : (6, 0) - (7, 22) +common warnings-0 + ghc-options: -Wall + +-- Range : (10, 0) - (17, 40) +common warnings-1 + ghc-options: -Wall + -Wredundant-constraints + -Wunused-packages + + -Wno-name-shadowing + + -Wno-unticked-promoted-constructors + +-- Range : (20, 0) - (23, 34) +common warnings-2 + ghc-options: -Wall + -Wredundant-constraints + -Wunused-packages + +library + + import: warnings-0 +-- ^ Position: (27, 16), middle of identifier + + import: warnings-1 +-- ^ Position: (30, 12), left of identifier + + import: warnings-2 +-- ^ Position: (33, 22), right of identifier + + import: warnings-0 +-- ^ Position: (36, 20), left of '-' in identifier + + import: warnings-1 +-- ^ Position: (39, 19), right of "-" in identifier + + import: warnings-2,warnings-1,warnings-0 +-- ^ Position: (42, 16), identifier in identifier list + + import: warnings-2,warnings-1,warnings-0 +-- ^ Position: (45, 33), left of ',' right of identifier + + import: warnings-2,warnings-1,warnings-0 +-- ^ Position: (48, 34), right of ',' left of identifier + + import: warnings-2, warnings-1,warnings-0 +-- ^ Position: (51, 37), right of ',' left of space + + import: warnings-0 +-- ^ Position: (54, 11), right of ':' left of space + + import: warnings-0 +-- ^ Position: (57, 8), not a definition + + -- EOL +-- ^ Position: (59, 7), empty space diff --git a/plugins/hls-cabal-plugin/test/testdata/hie.yaml b/plugins/hls-cabal-plugin/test/testdata/hie.yaml new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/hie.yaml @@ -0,0 +1,3 @@ +cradle: + direct: + arguments: [] diff --git a/plugins/hls-cabal-plugin/test/testdata/hover/hover-deps.cabal b/plugins/hls-cabal-plugin/test/testdata/hover/hover-deps.cabal new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/hover/hover-deps.cabal @@ -0,0 +1,10 @@ +cabal-version: 3.0 +name: hover-deps +version: 0.1.0.0 + +library + exposed-modules: Module + build-depends: base ^>=4.14.3.0 + , aeson==1.0.0.0 , lens + hs-source-dirs: src + default-language: Haskell2010 diff --git a/plugins/hls-cabal-plugin/test/testdata/outline-cabal/field.cabal b/plugins/hls-cabal-plugin/test/testdata/outline-cabal/field.cabal new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/outline-cabal/field.cabal @@ -0,0 +1,1 @@ +homepage: diff --git a/plugins/hls-cabal-plugin/test/testdata/outline-cabal/fieldline.cabal b/plugins/hls-cabal-plugin/test/testdata/outline-cabal/fieldline.cabal new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/outline-cabal/fieldline.cabal @@ -0,0 +1,1 @@ +cabal-version: 3.0 diff --git a/plugins/hls-cabal-plugin/test/testdata/outline-cabal/section.cabal b/plugins/hls-cabal-plugin/test/testdata/outline-cabal/section.cabal new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/outline-cabal/section.cabal @@ -0,0 +1,2 @@ + build-depends: + base >=4.16 && <5 diff --git a/plugins/hls-cabal-plugin/test/testdata/outline-cabal/sectionarg.cabal b/plugins/hls-cabal-plugin/test/testdata/outline-cabal/sectionarg.cabal new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/outline-cabal/sectionarg.cabal @@ -0,0 +1,2 @@ + if os(windows) + build-depends: Win32 diff --git a/plugins/hls-cabal-plugin/test/testdata/unsupportedVersion.cabal b/plugins/hls-cabal-plugin/test/testdata/unsupportedVersion.cabal new file mode 100644 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/unsupportedVersion.cabal @@ -0,0 +1,3 @@ +cabal-version: 99999.0 +name: invalid +version: 0.1.0.0 diff --git a/plugins/hls-call-hierarchy-plugin/test/Main.hs b/plugins/hls-call-hierarchy-plugin/test/Main.hs --- a/plugins/hls-call-hierarchy-plugin/test/Main.hs +++ b/plugins/hls-call-hierarchy-plugin/test/Main.hs @@ -114,13 +114,13 @@ [ testCase "1" $ do let contents = T.unlines ["{-# LANGUAGE TypeFamilies #-}", "data family A"] -- Since GHC 9.10 the range also includes the family name (and its parameters if any) - range = mkRange 1 0 1 (if ghcVersion == GHC910 then 13 else 11) + range = mkRange 1 0 1 (if ghcVersion >= GHC910 then 13 else 11) selRange = mkRange 1 12 1 13 expected = mkCallHierarchyItemT "A" SymbolKind_Function range selRange oneCaseWithCreate contents 1 12 expected , testCase "2" $ do let contents = T.unlines [ "{-# LANGUAGE TypeFamilies #-}" , "data family A a"] - range = mkRange 1 0 1 (if ghcVersion == GHC910 then 15 else 11) + range = mkRange 1 0 1 (if ghcVersion >= GHC910 then 15 else 11) selRange = mkRange 1 12 1 13 expected = mkCallHierarchyItemT "A" SymbolKind_Function range selRange oneCaseWithCreate contents 1 12 expected diff --git a/plugins/hls-change-type-signature-plugin/test/Main.hs b/plugins/hls-change-type-signature-plugin/test/Main.hs --- a/plugins/hls-change-type-signature-plugin/test/Main.hs +++ b/plugins/hls-change-type-signature-plugin/test/Main.hs @@ -39,7 +39,7 @@ test = testGroup "changeTypeSignature" [ testRegexes , codeActionTest "TExpectedActual" 4 11 - , knownBrokenForGhcVersions [GHC92 .. GHC910] "Error Message in 9.2+ does not provide enough info" $ + , knownBrokenForGhcVersions [GHC94 .. GHC912] "Error Message in 9.2+ does not provide enough info" $ codeActionTest "TRigidType" 4 14 , codeActionTest "TRigidType2" 4 6 , codeActionTest "TLocalBinding" 7 22 diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs @@ -24,6 +24,7 @@ import qualified Data.Text as T import Development.IDE import Development.IDE.Core.Compile (sourceTypecheck) +import Development.IDE.Core.FileStore (getVersionedTextDoc) import Development.IDE.Core.PluginUtils import Development.IDE.Core.PositionMapping (fromCurrentRange) import Development.IDE.GHC.Compat @@ -80,7 +81,7 @@ -- sensitive to the format of diagnostic messages from GHC. codeAction :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Method_TextDocumentCodeAction codeAction recorder state plId (CodeActionParams _ _ docId _ context) = do - verTxtDocId <- lift $ pluginGetVersionedTextDoc docId + verTxtDocId <- liftIO $ runAction "classplugin.codeAction.getVersionedTextDoc" state $ getVersionedTextDoc docId nfp <- getNormalizedFilePathE (verTxtDocId ^. L.uri) actions <- join <$> mapM (mkActions nfp verTxtDocId) methodDiags pure $ InL actions diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/ExactPrint.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/ExactPrint.hs --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/ExactPrint.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/ExactPrint.hs @@ -30,7 +30,11 @@ pm_parsed_source pm old = T.pack $ exactPrint ps +#if MIN_VERSION_ghc_exactprint(1,10,0) + ps' = addMethodDecls ps mDecls range withSig +#else (ps', _, _) = runTransform (addMethodDecls ps mDecls range withSig) +#endif new = T.pack $ exactPrint ps' pure (old, new) @@ -40,7 +44,9 @@ sig' <- eitherToMaybe $ parseDecl df (T.unpack sig) $ T.unpack sig pure (name, sig') -#if MIN_VERSION_ghc(9,5,0) +#if MIN_VERSION_ghc_exactprint(1,10,0) +addMethodDecls :: ParsedSource -> [(LHsDecl GhcPs, LHsDecl GhcPs)] -> Range -> Bool -> Located (HsModule GhcPs) +#elif MIN_VERSION_ghc(9,5,0) addMethodDecls :: ParsedSource -> [(LHsDecl GhcPs, LHsDecl GhcPs)] -> Range -> Bool -> TransformT Identity (Located (HsModule GhcPs)) #else addMethodDecls :: ParsedSource -> [(LHsDecl GhcPs, LHsDecl GhcPs)] -> Range -> Bool -> TransformT Identity (Located HsModule) @@ -50,12 +56,20 @@ | otherwise = go (map fst mDecls) where go inserting = do +#if MIN_VERSION_ghc_exactprint(1,10,0) + let allDecls = hsDecls ps +#else allDecls <- hsDecls ps +#endif case break (inRange range . getLoc) allDecls of (before, L l inst : after) -> let instSpan = realSrcSpan $ getLoc l +#if MIN_VERSION_ghc(9,11,0) + instCol = srcSpanStartCol instSpan - 1 +#else instCol = srcSpanStartCol instSpan +#endif #if MIN_VERSION_ghc(9,9,0) instRow = srcSpanEndLine instSpan methodEpAnn = noAnnSrcSpanDP $ deltaPos 1 (instCol + defaultIndent) @@ -91,7 +105,17 @@ addWhere :: HsDecl GhcPs -> HsDecl GhcPs addWhere instd@(InstD xInstD (ClsInstD ext decl@ClsInstDecl{..})) = case cid_ext of -#if MIN_VERSION_ghc(9,9,0) +#if MIN_VERSION_ghc(9,11,0) + (warnings, anns, key) + | EpTok _ <- acid_where anns -> instd + | otherwise -> + InstD xInstD (ClsInstD ext decl { + cid_ext = ( warnings + , anns { acid_where = EpTok d1 } + , key + ) + }) +#elif MIN_VERSION_ghc(9,9,0) (warnings, anns, key) | any (\(AddEpAnn kw _ )-> kw == AnnWhere) anns -> instd | otherwise -> diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs @@ -176,7 +176,11 @@ getBindSpanWithoutSig :: ClsInstDecl GhcRn -> [BindInfo] getBindSpanWithoutSig ClsInstDecl{..} = - let bindNames = mapMaybe go (bagToList cid_binds) + let bindNames = mapMaybe go $ +#if !MIN_VERSION_ghc(9,11,0) + bagToList +#endif + cid_binds go (L l bind) = case bind of FunBind{..} -- `Generated` tagged for Template Haskell, @@ -221,5 +225,10 @@ let name = idName id whenMaybe (isBindingName name) $ do env <- tcInitTidyEnv - let (_, ty) = tidyOpenType env (idType id) +#if MIN_VERSION_ghc(9,11,0) + let ty = +#else + let (_, ty) = +#endif + tidyOpenType env (idType id) pure $ InstanceBindTypeSig name ty diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Utils.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Utils.hs --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Utils.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Utils.hs @@ -64,7 +64,7 @@ insertPragmaIfNotPresent state nfp pragma = do (hscEnv -> hsc_dflags -> sessionDynFlags, _) <- runActionE "classplugin.insertPragmaIfNotPresent.GhcSession" state $ useWithStaleE GhcSession nfp - (_, fileContents) <- liftIO $ runAction "classplugin.insertPragmaIfNotPresent.GetFileContents" state + fileContents <- liftIO $ runAction "classplugin.insertPragmaIfNotPresent.GetFileContents" state $ getFileContents nfp (pm, _) <- runActionE "classplugin.insertPragmaIfNotPresent.GetParsedModuleWithComments" state $ useWithStaleE GetParsedModuleWithComments nfp diff --git a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs @@ -29,7 +29,6 @@ maybeToExceptT) import Control.Monad.Trans.Writer.CPS import Data.Coerce (coerce) -import Data.Data (Typeable) import Data.Foldable (traverse_) import Data.Function (on, (&)) import Data.Hashable @@ -158,7 +157,7 @@ withChildrenSimplified = r { _codeRange_children = simplify <$> _codeRange_children r } data GetCodeRange = GetCodeRange - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable GetCodeRange instance NFData GetCodeRange diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs @@ -1,7 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -Wwarn -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wwarn #-} -- | Expression execution module Ide.Plugin.Eval.Code (Statement, testRanges, resultRange, propSetup, testCheck, asStatements,myExecStmt) where diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -5,7 +5,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -fno-warn-type-defaults -Wno-unused-imports #-} +{-# OPTIONS_GHC -Wno-type-defaults #-} {- | A plugin inspired by the REPLoid feature of , 's Examples and Properties and . @@ -18,13 +18,12 @@ ) where import Control.Applicative (Alternative ((<|>))) -import Control.Arrow (second, (>>>)) -import Control.Exception (bracket_, try) +import Control.Arrow (second) +import Control.Exception (bracket_) import qualified Control.Exception as E -import Control.Lens (_1, _3, ix, (%~), - (<&>), (^.)) -import Control.Monad (guard, join, - void, when) +import Control.Lens (ix, (%~), (^.)) +import Control.Monad (guard, void, + when) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Except (ExceptT (..), runExceptT) @@ -40,29 +39,23 @@ import Data.String (IsString) import Data.Text (Text) import qualified Data.Text as T -import Data.Typeable (Typeable) +import qualified Data.Text.Utf16.Rope.Mixed as Rope +import Development.IDE.Core.FileStore (getUriContents) import Development.IDE.Core.Rules (IdeState, runAction) import Development.IDE.Core.RuleTypes (LinkableResult (linkableHomeMod), - NeedsCompilation (NeedsCompilation), TypeCheck (..), tmrTypechecked) -import Development.IDE.Core.Shake (shakeExtras, - useNoFile_, - useWithStale_, - use_, uses_) +import Development.IDE.Core.Shake (useNoFile_, use_, + uses_) import Development.IDE.GHC.Compat hiding (typeKind, unitState) -import Development.IDE.GHC.Compat.Util (GhcException, - OverridingBool (..), - bagToList) +import Development.IDE.GHC.Compat.Util (OverridingBool (..)) import Development.IDE.GHC.Util (evalGhcEnv, - modifyDynFlags, - printOutputable) + modifyDynFlags) import Development.IDE.Import.DependencyInformation (transitiveDeps, transitiveModuleDeps) -import Development.IDE.Types.Location (toNormalizedFilePath', - uriToFilePath') +import Development.IDE.Types.Location (toNormalizedFilePath') import GHC (ClsInst, ExecOptions (execLineNumber, execSourceFile), FamInst, @@ -87,15 +80,12 @@ ModSummaryResult (msrModSummary)) import Development.IDE.Core.Shake (VFSModified (VFSUnmodified)) import qualified Development.IDE.GHC.Compat.Core as Compat (InteractiveImport (IIModule)) -import qualified Development.IDE.GHC.Compat.Core as SrcLoc (HasSrcSpan (getLoc), - unLoc) +import qualified Development.IDE.GHC.Compat.Core as SrcLoc (unLoc) import Development.IDE.Types.HscEnvEq (HscEnvEq (hscEnv)) import qualified GHC.LanguageExtensions.Type as LangExt (Extension (..)) -import Control.Concurrent.STM.Stats (atomically) import Development.IDE.Core.FileStore (setSomethingModified) import Development.IDE.Core.PluginUtils -import Development.IDE.Graph (ShakeOptions (shakeExtra)) import Development.IDE.Types.Shake (toKey) import GHC.Types.SrcLoc (UnhelpfulSpanReason (UnhelpfulInteractive)) import Ide.Logger (Priority (..), @@ -103,7 +93,6 @@ WithPriority, logWith) import Ide.Plugin.Error (PluginError (PluginInternalError), - handleMaybe, handleMaybeM) import Ide.Plugin.Eval.Code (Statement, asStatements, @@ -117,8 +106,7 @@ import Ide.Plugin.Eval.GHC (addImport, addPackages, hasPackage, - setSessionAndInteractiveDynFlags, - showDynFlags) + setSessionAndInteractiveDynFlags) import Ide.Plugin.Eval.Parse.Comments (commentsToSections) import Ide.Plugin.Eval.Parse.Option (parseSetFlags) import Ide.Plugin.Eval.Rules (queueForEvaluation, @@ -133,8 +121,11 @@ import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types import Language.LSP.Server -import Language.LSP.VFS (virtualFileText) +#if MIN_VERSION_ghc(9,11,0) +import GHC.Unit.Module.ModIface (IfaceTopEnv (..)) +#endif + {- | Code Lens provider NOTE: Invoked every time the document is modified, not just when the document is saved. -} @@ -151,14 +142,6 @@ dbg $ LogCodeLensFp fp (comments, _) <- runActionE "eval.GetParsedModuleWithComments" st $ useWithStaleE GetEvalComments nfp - -- dbg "excluded comments" $ show $ DL.toList $ - -- foldMap (\(L a b) -> - -- case b of - -- AnnLineComment{} -> mempty - -- AnnBlockComment{} -> mempty - -- _ -> DL.singleton (a, b) - -- ) - -- $ apiAnnComments' pm_annotations dbg $ LogCodeLensComments comments -- Extract tests from source code @@ -210,7 +193,7 @@ let TextDocumentIdentifier{_uri} = module_ fp <- uriToFilePathE _uri let nfp = toNormalizedFilePath' fp - mdlText <- moduleText _uri + mdlText <- moduleText st _uri -- enable codegen for the module which we need to evaluate. final_hscEnv <- liftIO $ bracket_ @@ -260,17 +243,22 @@ -- However, the eval plugin (setContext specifically) requires the rdr_env -- for the current module - so get it from the Typechecked Module and add -- it back to the iface for the current module. - rdr_env <- tcg_rdr_env . tmrTypechecked <$> use_ TypeCheck nfp + tm <- tmrTypechecked <$> use_ TypeCheck nfp + let rdr_env = tcg_rdr_env tm let linkable_hsc = loadModulesHome (map (addRdrEnv . linkableHomeMod) linkables) deps_hsc addRdrEnv hmi | iface <- hm_iface hmi , ms_mod ms == mi_module iface +#if MIN_VERSION_ghc(9,11,0) + = hmi { hm_iface = set_mi_top_env (Just $ IfaceTopEnv (forceGlobalRdrEnv (globalRdrEnvLocal rdr_env)) (mkIfaceImports $ tcg_import_decls tm)) iface} +#else = hmi { hm_iface = iface { mi_globals = Just $! #if MIN_VERSION_ghc(9,8,0) forceGlobalRdrEnv #endif rdr_env }} +#endif | otherwise = hmi return (ms, linkable_hsc) @@ -291,6 +279,15 @@ getSession return env2 +#if MIN_VERSION_ghc(9,11,0) +mkIfaceImports :: [ImportUserSpec] -> [IfaceImport] +mkIfaceImports = map go + where + go (ImpUserSpec decl ImpUserAll) = IfaceImport decl ImpIfaceAll + go (ImpUserSpec decl (ImpUserExplicit env)) = IfaceImport decl (ImpIfaceExplicit (forceGlobalRdrEnv env)) + go (ImpUserSpec decl (ImpUserEverythingBut ns)) = IfaceImport decl (ImpIfaceEverythingBut ns) +#endif + addFinalReturn :: Text -> [TextEdit] -> [TextEdit] addFinalReturn mdlText edits | not (null edits) && not (T.null mdlText) && T.last mdlText /= '\n' = @@ -305,12 +302,15 @@ p = Position l c in TextEdit (Range p p) "\n" -moduleText :: Uri -> ExceptT PluginError (HandlerM config) Text -moduleText uri = - handleMaybeM (PluginInternalError "mdlText") $ - (virtualFileText <$>) - <$> pluginGetVirtualFile - (toNormalizedUri uri) +moduleText :: IdeState -> Uri -> ExceptT PluginError (HandlerM config) Text +moduleText state uri = do + contents <- + handleMaybeM (PluginInternalError "mdlText") $ + liftIO $ + runAction "eval.getUriContents" state $ + getUriContents $ + toNormalizedUri uri + pure $ Rope.toText contents testsBySection :: [Section] -> [(Section, EvalId, Test)] testsBySection sections = @@ -514,7 +514,7 @@ errorLines :: String -> [Text] errorLines = dropWhileEnd T.null - . takeWhile (not . ("CallStack" `T.isPrefixOf`)) + . takeWhile (not . (\x -> "CallStack" `T.isPrefixOf` x || "HasCallStack" `T.isPrefixOf` x)) . T.lines . T.pack @@ -654,7 +654,6 @@ { ghciCmdName :: Text , ghciCmdArg :: Text } - deriving (Typeable) instance Show GhciLikeCmdException where showsPrec _ GhciLikeCmdNotImplemented{..} = diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/GHC.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/GHC.hs --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/GHC.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/GHC.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} -{-# OPTIONS_GHC -fno-warn-unused-imports -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-orphans #-} -- |GHC API utilities module Ide.Plugin.Eval.GHC ( @@ -25,12 +25,10 @@ import GHC.LanguageExtensions.Type (Extension (..)) import Ide.Plugin.Eval.Util (gStrictTry) -#if MIN_VERSION_ghc(9,3,0) import GHC (setTopSessionDynFlags, setUnitDynFlags) import GHC.Driver.Env import GHC.Driver.Session (getDynFlags) -#endif {- $setup >>> import GHC @@ -174,13 +172,9 @@ setSessionAndInteractiveDynFlags :: DynFlags -> Ghc () setSessionAndInteractiveDynFlags df = do -#if MIN_VERSION_ghc(9,3,0) _ <- setUnitDynFlags (homeUnitId_ df) df modifySession (hscUpdateLoggerFlags . hscSetActiveUnitId (homeUnitId_ df)) df' <- getDynFlags setTopSessionDynFlags df' -#else - _ <- setSessionDynFlags df -#endif sessDyns <- getSessionDynFlags setInteractiveDynFlags sessDyns diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs @@ -65,7 +65,13 @@ apiAnnComments' :: ParsedModule -> [SrcLoc.RealLocated EpaCommentTok] apiAnnComments' pm = do L span (EpaComment c _) <- getEpaComments $ pm_parsed_source pm - pure (L (anchor span) c) + pure (L ( +#if MIN_VERSION_ghc(9,11,0) + epaLocationRealSrcSpan +#else + anchor +#endif + span) c) where #if MIN_VERSION_ghc(9,5,0) getEpaComments :: Development.IDE.GHC.Compat.Located (HsModule GhcPs) -> [LEpaComment] diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs @@ -157,14 +157,14 @@ deriving (Eq, Show, Generic, FromJSON, ToJSON, NFData) data IsEvaluating = IsEvaluating - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable IsEvaluating instance NFData IsEvaluating type instance RuleResult IsEvaluating = Bool data GetEvalComments = GetEvalComments - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable GetEvalComments instance NFData GetEvalComments diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs @@ -1,9 +1,8 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# OPTIONS_GHC -Wno-orphans -Wno-unused-imports #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-orphans #-} --- |Debug utilities +-- | Debug utilities module Ide.Plugin.Eval.Util ( timed, isLiterate, @@ -15,39 +14,31 @@ import Control.Exception (SomeException, evaluate, fromException) -import Control.Monad.Error.Class (MonadError (throwError)) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Class (MonadTrans (lift)) import Control.Monad.Trans.Except (ExceptT (..), runExceptT) import Data.Aeson (Value) -import Data.Bifunctor (second) import Data.String (IsString (fromString)) -import qualified Data.Text as T -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) -import GHC.Exts (toList) -import GHC.Stack (HasCallStack, callStack, - srcLocFile, - srcLocStartCol, - srcLocStartLine) import Ide.Plugin.Error import Ide.Types (HandlerM, pluginSendRequest) import Language.LSP.Protocol.Message 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 System.Time.Extra (duration) import UnliftIO.Exception (catchAny) +#if !MIN_VERSION_ghc(9,8,0) +import qualified Data.Text as T +import Development.IDE (printOutputable) +import qualified Development.IDE.GHC.Compat.Core as Core +#endif + timed :: MonadIO m => (t -> Extra.Seconds -> m a) -> t -> m b -> m b timed out name op = do (secs, r) <- duration op @@ -77,7 +68,6 @@ showErr :: Monad m => SomeException -> m String showErr e = -#if MIN_VERSION_ghc(9,3,0) case fromException e of -- On GHC 9.4+, the show instance adds the error message span -- We don't want this for the plugin @@ -93,7 +83,6 @@ . errMsgDiagnostic) $ getMessages msgs _ -> -#endif return . show $ e #if MIN_VERSION_ghc(9,8,0) @@ -109,6 +98,6 @@ prettyWarn :: Core.Warn -> String prettyWarn Core.Warn{..} = - T.unpack (printOutputable $ SrcLoc.getLoc warnMsg) <> ": warning:\n" - <> " " <> SrcLoc.unLoc warnMsg + T.unpack (printOutputable $ Core.getLoc warnMsg) <> ": warning:\n" + <> " " <> Core.unLoc warnMsg #endif diff --git a/plugins/hls-eval-plugin/test/Main.hs b/plugins/hls-eval-plugin/test/Main.hs --- a/plugins/hls-eval-plugin/test/Main.hs +++ b/plugins/hls-eval-plugin/test/Main.hs @@ -75,7 +75,7 @@ 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" "-- >>> \"" (if ghcVersion >= GHC912 then "-- lexical error at end of input" else "-- 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" @@ -89,8 +89,8 @@ , 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" + -- TODO: known issue - see a note in P.R. #361 + , 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", @@ -126,14 +126,14 @@ , 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" - , knownBrokenInEnv [HostOS Windows] "The output has path separators in it, which on Windows look different. Just skip it there" $ + , knownBrokenInWindowsBeforeGHC912 "The output has path separators in it, which on Windows look different. Just skip it there" $ goldenWithEvalAndFs' "Property checking with exception" cabalProjectFS "TPropertyError" "hs" $ case ghcVersion of + GHC912 -> "ghc912.expected" GHC910 -> "ghc910.expected" GHC98 -> "ghc98.expected" GHC96 -> "ghc96.expected" GHC94 -> "ghc94.expected" - GHC92 -> "ghc92.expected" , goldenWithEval "Prelude has no special treatment, it is imported as stated in the module" "TPrelude" "hs" , goldenWithEval "Don't panic on {-# UNPACK #-} pragma" "TUNPACK" "hs" , goldenWithEval "Can handle eval inside nested comment properly" "TNested" "hs" @@ -210,6 +210,12 @@ let ifaceKeys = filter ("GetModIface" `T.isPrefixOf`) keys liftIO $ ifaceKeys @?= [] ] + where + knownBrokenInWindowsBeforeGHC912 msg = + foldl (.) id + [ knownBrokenInSpecificEnv [GhcVer ghcVer, HostOS Windows] msg + | ghcVer <- [GHC94 .. GHC910] + ] goldenWithEval :: TestName -> FilePath -> FilePath -> TestTree goldenWithEval title path ext = diff --git a/plugins/hls-eval-plugin/test/testdata/T20.expected.hs b/plugins/hls-eval-plugin/test/testdata/T20.expected.hs --- a/plugins/hls-eval-plugin/test/testdata/T20.expected.hs +++ b/plugins/hls-eval-plugin/test/testdata/T20.expected.hs @@ -4,4 +4,4 @@ default (Word) -- >>> :type +d 40+ 2 --- 40+ 2 :: Word +-- 40+ 2 :: Integer diff --git a/plugins/hls-eval-plugin/test/testdata/TPropertyError.ghc912.expected.hs b/plugins/hls-eval-plugin/test/testdata/TPropertyError.ghc912.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TPropertyError.ghc912.expected.hs @@ -0,0 +1,6 @@ +-- Support for property checking +module TProperty where + +-- prop> \(l::[Bool]) -> head l +-- *** Failed! Exception: 'Prelude.head: empty list' (after 1 test): +-- [] diff --git a/plugins/hls-eval-plugin/test/testdata/TPropertyError.ghc92.expected.hs b/plugins/hls-eval-plugin/test/testdata/TPropertyError.ghc92.expected.hs deleted file mode 100644 --- a/plugins/hls-eval-plugin/test/testdata/TPropertyError.ghc92.expected.hs +++ /dev/null @@ -1,6 +0,0 @@ --- Support for property checking -module TProperty where - --- prop> \(l::[Bool]) -> head l --- *** Failed! Exception: 'Prelude.head: empty list' (after 1 test): --- [] diff --git a/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs b/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs --- a/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs +++ b/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} @@ -59,7 +61,11 @@ in Just $ Hover (InL (mkPlainText contents')) Nothing fixityText :: (Name, Fixity) -> T.Text +#if MIN_VERSION_GLASGOW_HASKELL(9,12,0,0) + fixityText (name, Fixity precedence direction) = +#else fixityText (name, Fixity _ precedence direction) = +#endif printOutputable direction <> " " <> printOutputable precedence <> " `" <> printOutputable name <> "`" newtype FixityMap = FixityMap (M.Map Name Fixity) diff --git a/plugins/hls-explicit-fixity-plugin/test/Main.hs b/plugins/hls-explicit-fixity-plugin/test/Main.hs --- a/plugins/hls-explicit-fixity-plugin/test/Main.hs +++ b/plugins/hls-explicit-fixity-plugin/test/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} module Main where @@ -40,16 +41,29 @@ , hoverTest "signature" (Position 35 2) "infixr 9 `>>>:`" , hoverTest "operator" (Position 36 2) "infixr 9 `>>>:`" , hoverTest "escape" (Position 39 2) "infixl 3 `~\\:`" - -- Ensure that there is no one extra new line in import statement - , expectFail $ hoverTest "import" (Position 2 18) "Control.Monad***" - -- Known issue, See https://github.com/haskell/haskell-language-server/pull/2973/files#r916535742 - , expectFail $ hoverTestImport "import" (Position 4 7) "infixr 9 `>>>:`" + -- TODO: Ensure that there is no one extra new line in import statement + , hoverTestExpectFail + "import" + (Position 2 18) + (BrokenIdeal "Control.Monad***") + (BrokenCurrent "Control.Monad\n\n") + , hoverTestImport "import" (Position 4 7) "infixr 9 `>>>:`" ] hoverTest :: TestName -> Position -> T.Text -> TestTree hoverTest = hoverTest' "Hover.hs" + hoverTestImport :: TestName -> Position -> T.Text -> TestTree hoverTestImport = hoverTest' "HoverImport.hs" + +hoverTestExpectFail + :: TestName + -> Position + -> ExpectBroken 'Ideal T.Text + -> ExpectBroken 'Current T.Text + -> TestTree +hoverTestExpectFail title pos _ = + hoverTest title pos . unCurrent hoverTest' :: String -> TestName -> Position -> T.Text -> TestTree hoverTest' docName title pos expected = testCase title $ runSessionWithServer def plugin testDataDir $ do diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -6,15 +6,17 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} + module Ide.Plugin.ExplicitImports ( descriptor , descriptorForModules , abbreviateImportTitle + , abbreviateImportTitleWithoutModule , Log(..) ) where import Control.DeepSeq -import Control.Lens ((&), (?~)) +import Control.Lens (_Just, (&), (?~), (^?)) import Control.Monad.Error.Class (MonadError (throwError)) import Control.Monad.IO.Class import Control.Monad.Trans.Class (lift) @@ -22,14 +24,19 @@ import Control.Monad.Trans.Maybe import qualified Data.Aeson as A (ToJSON (toJSON)) import Data.Aeson.Types (FromJSON) +import Data.Char (isSpace) +import Data.Functor ((<&>)) import qualified Data.IntMap as IM (IntMap, elems, fromList, (!?)) import Data.IORef (readIORef) +import Data.List (singleton) import qualified Data.Map.Strict as Map -import Data.Maybe (isNothing, mapMaybe) +import Data.Maybe (isJust, isNothing, + mapMaybe) import qualified Data.Set as S import Data.String (fromString) import qualified Data.Text as T +import qualified Data.Text as Text import Data.Traversable (for) import qualified Data.Unique as U (hashUnique, newUnique) @@ -44,11 +51,14 @@ import Ide.Plugin.Error (PluginError (..), getNormalizedFilePathE, handleMaybe) -import Ide.Plugin.RangeMap (filterByRange) -import qualified Ide.Plugin.RangeMap as RM (RangeMap, fromList) +import qualified Ide.Plugin.RangeMap as RM (RangeMap, + filterByRange, + fromList) import Ide.Plugin.Resolve import Ide.PluginUtils import Ide.Types +import Language.LSP.Protocol.Lens (HasInlayHint (inlayHint), + HasTextDocument (textDocument)) import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types @@ -76,7 +86,7 @@ descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder = -- (almost) no one wants to see an explicit import list for Prelude - descriptorForModules recorder (/= moduleName pRELUDE) + descriptorForModules recorder (/= pRELUDE_NAME) descriptorForModules :: Recorder (WithPriority Log) @@ -97,17 +107,23 @@ -- This plugin provides code lenses mkPluginHandler SMethod_TextDocumentCodeLens (lensProvider recorder) <> mkResolveHandler SMethod_CodeLensResolve (lensResolveProvider recorder) - -- This plugin provides code actions + -- This plugin provides inlay hints + <> mkPluginHandler SMethod_TextDocumentInlayHint (inlayHintProvider recorder) + -- This plugin provides code actions <> codeActionHandlers - } +isInlayHintsSupported :: IdeState -> Bool +isInlayHintsSupported ideState = + let clientCaps = Shake.clientCapabilities $ shakeExtras ideState + in isJust $ clientCaps ^? textDocument . _Just . inlayHint . _Just + -- | The actual command handler runImportCommand :: Recorder (WithPriority Log) -> CommandFunction IdeState IAResolveData runImportCommand recorder ideState _ eird@(ResolveOne _ _) = do wedit <- resolveWTextEdit ideState eird _ <- lift $ pluginSendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) logErrors - return $ InR Null + return $ InR Null where logErrors (Left re) = do logWith recorder Error (LogWAEResponseError re) pure () @@ -129,12 +145,18 @@ -- the provider should produce one code lens associated to the import statement: -- > Refine imports to import Control.Monad.IO.Class (liftIO) lensProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentCodeLens -lensProvider _ state _ CodeLensParams {_textDocument = TextDocumentIdentifier {_uri}} = do +lensProvider _ state _ CodeLensParams {_textDocument = TextDocumentIdentifier {_uri}} = do nfp <- getNormalizedFilePathE _uri (ImportActionsResult{forLens}, pm) <- runActionE "ImportActions" state $ useWithStaleE ImportActions nfp let lens = [ generateLens _uri newRange int - | (range, int) <- forLens - , Just newRange <- [toCurrentRange pm range]] + -- provide ExplicitImport only if the client does not support inlay hints + | not (isInlayHintsSupported state) + , (range, (int, ExplicitImport)) <- forLens + , Just newRange <- [toCurrentRange pm range]] <> + -- RefineImport is always provided because inlay hints cannot + [ generateLens _uri newRange int + | (range, (int, RefineImport)) <- forLens + , Just newRange <- [toCurrentRange pm range]] pure $ InL lens where -- because these are non resolved lenses we only need the range and a -- unique id to later resolve them with. These are for both refine @@ -145,12 +167,13 @@ , _range = range , _command = Nothing } + lensResolveProvider :: Recorder (WithPriority Log) -> ResolveFunction IdeState IAResolveData 'Method_CodeLensResolve lensResolveProvider _ ideState plId cl uri rd@(ResolveOne _ uid) = do nfp <- getNormalizedFilePathE uri (ImportActionsResult{forResolve}, _) <- runActionE "ImportActions" ideState $ useWithStaleE ImportActions nfp target <- handleMaybe PluginStaleResolve $ forResolve IM.!? uid - let updatedCodeLens = cl & L.command ?~ mkCommand plId target + let updatedCodeLens = cl & L.command ?~ mkCommand plId target pure updatedCodeLens where mkCommand :: PluginId -> ImportEdit -> Command mkCommand pId (ImportEdit{ieResType, ieText}) = @@ -165,6 +188,53 @@ lensResolveProvider _ _ _ _ _ rd = do throwError $ PluginInvalidParams (T.pack $ "Unexpected argument for lens resolve handler: " <> show rd) + +-- | Provide explicit imports in inlay hints. +-- Applying textEdits can make the import explicit. +-- There is currently no need to resolve inlay hints, +-- as no tooltips or commands are provided in the label. +inlayHintProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentInlayHint +inlayHintProvider _ state _ InlayHintParams {_textDocument = TextDocumentIdentifier {_uri}, _range = visibleRange} = + if isInlayHintsSupported state + then do + nfp <- getNormalizedFilePathE _uri + (ImportActionsResult {forLens, forResolve}, pm) <- runActionE "ImportActions" state $ useWithStaleE ImportActions nfp + let inlayHints = [ inlayHint + | (range, (int, _)) <- forLens + , Just newRange <- [toCurrentRange pm range] + , isSubrangeOf newRange visibleRange + , Just ie <- [forResolve IM.!? int] + , Just inlayHint <- [generateInlayHints newRange ie pm]] + pure $ InL inlayHints + -- When the client does not support inlay hints, fallback to the code lens, + -- so there is nothing to response here. + -- `[]` is no different from `null`, we chose to use all `[]` to indicate "no information" + else pure $ InL [] + where + -- The appropriate and intended position for the hint hints to begin + -- is the end of the range for the code lens. + -- import Data.Char (isSpace) + -- |--- range ----|-- IH ---| + -- |^-_paddingLeft + -- ^-_position + generateInlayHints :: Range -> ImportEdit -> PositionMapping -> Maybe InlayHint + generateInlayHints (Range _ end) ie pm = mkLabel ie <&> \label -> + InlayHint { _position = end + , _label = InL label + , _kind = Nothing -- neither a type nor a parameter + , _textEdits = fmap singleton $ toTEdit pm ie + , _tooltip = Just $ InL "Make this import explicit" -- simple enough, no need to resolve + , _paddingLeft = Just True -- show an extra space before the inlay hint + , _paddingRight = Nothing + , _data_ = Nothing + } + mkLabel :: ImportEdit -> Maybe T.Text + mkLabel (ImportEdit{ieResType, ieText}) = + let title ExplicitImport = Just $ abbreviateImportTitleWithoutModule ieText + title RefineImport = Nothing -- does not provide imports statements that can be refined via inlay hints + in title ieResType + + -- |For explicit imports: If there are any implicit imports, provide both one -- code action per import to make that specific import explicit, and one code -- action to turn them all into explicit imports. For refine imports: If there @@ -175,7 +245,7 @@ nfp <- getNormalizedFilePathE _uri (ImportActionsResult{forCodeActions}, pm) <- runActionE "ImportActions" ideState $ useWithStaleE ImportActions nfp newRange <- toCurrentRangeE pm range - let relevantCodeActions = filterByRange newRange forCodeActions + let relevantCodeActions = RM.filterByRange newRange forCodeActions allExplicit = [InR $ mkCodeAction "Make all imports explicit" (Just $ A.toJSON $ ExplicitAll _uri) -- We should only provide this code action if there are any code @@ -231,13 +301,15 @@ pure $ mkWorkspaceEdit uri edits pm mkWorkspaceEdit :: Uri -> [ImportEdit] -> PositionMapping -> WorkspaceEdit mkWorkspaceEdit uri edits pm = - WorkspaceEdit {_changes = Just $ Map.singleton uri (mapMaybe toWEdit edits) + WorkspaceEdit {_changes = Just $ Map.singleton uri (mapMaybe (toTEdit pm) edits) , _documentChanges = Nothing , _changeAnnotations = Nothing} - where toWEdit ImportEdit{ieRange, ieText} = - let newRange = toCurrentRange pm ieRange - in (\r -> TextEdit r ieText) <$> newRange +toTEdit :: PositionMapping -> ImportEdit -> Maybe TextEdit +toTEdit pm ImportEdit{ieRange, ieText} = + let newRange = toCurrentRange pm ieRange + in (\r -> TextEdit r ieText) <$> newRange + data ImportActions = ImportActions deriving (Show, Generic, Eq, Ord) @@ -254,7 +326,7 @@ { -- |For providing the code lenses we need to have a range, and a unique id -- that is later resolved to the new text for each import. It is stored in -- a list, because we always need to provide all the code lens in a file. - forLens :: [(Range, Int)] + forLens :: [(Range, (Int, ResultType))] -- |For the code actions we have the same data as for the code lenses, but -- we store it in a RangeMap, because that allows us to filter on a specific -- range with better performance, and code actions are almost always only @@ -331,7 +403,7 @@ -- for every minimal imports | (location, origImport, minImport@(ImportDecl{ideclName = L _ mn})) <- locationImportWithMinimal -- (almost) no one wants to see an refine import list for Prelude - , mn /= moduleName pRELUDE + , mn /= pRELUDE_NAME -- we check for the inner imports , Just innerImports <- [Map.lookup mn import2Map] -- and only get those symbols used @@ -346,7 +418,7 @@ pure (u, rt) let rangeAndUnique = [ ImportAction r u rt | (u, (r, (_, rt))) <- uniqueAndRangeAndText ] pure ImportActionsResult - { forLens = (\ImportAction{..} -> (iaRange, iaUniqueId)) <$> rangeAndUnique + { forLens = (\ImportAction{..} -> (iaRange, (iaUniqueId, iaResType))) <$> rangeAndUnique , forCodeActions = RM.fromList iaRange rangeAndUnique , forResolve = IM.fromList ((\(u, (r, (te, ty))) -> (u, ImportEdit r te ty)) <$> uniqueAndRangeAndText) } @@ -413,8 +485,6 @@ maxColumns :: Int maxColumns = 120 - --- | The title of the command is ideally the minimal explicit import decl, but -- we don't want to create a really massive code lens (and the decl can be extremely large!). -- So we abbreviate it to fit a max column size, and indicate how many more items are in the list -- after the abbreviation @@ -422,7 +492,8 @@ abbreviateImportTitle input = let -- For starters, we only want one line in the title - oneLineText = T.unwords $ T.lines input + -- we also need to compress multiple spaces into one + oneLineText = T.unwords $ filter (not . T.null) $ T.split isSpace input -- Now, split at the max columns, leaving space for the summary text we're going to add -- (conservatively assuming we won't need to print a number larger than 100) (prefix, suffix) = T.splitAt (maxColumns - T.length (summaryText 100)) oneLineText @@ -447,6 +518,11 @@ else actualPrefix <> suffixText in title +-- Create an import abbreviate title without module for inlay hints +abbreviateImportTitleWithoutModule :: Text.Text -> Text.Text +abbreviateImportTitleWithoutModule = abbreviateImportTitle . T.dropWhile (/= '(') + +-- | The title of the command is ideally the minimal explicit import decl, but -------------------------------------------------------------------------------- @@ -464,11 +540,7 @@ then Just res else Nothing where importedNames = S.fromList $ map (ieName . unLoc) names - res = flip Map.filter avails $ \a -> - any (`S.member` importedNames) - $ concatMap - getAvailNames - a + res = Map.filter (any (any (`S.member` importedNames) . getAvailNames)) avails allFilteredAvailsNames = S.fromList $ concatMap getAvailNames $ mconcat diff --git a/plugins/hls-explicit-imports-plugin/test/Main.hs b/plugins/hls-explicit-imports-plugin/test/Main.hs --- a/plugins/hls-explicit-imports-plugin/test/Main.hs +++ b/plugins/hls-explicit-imports-plugin/test/Main.hs @@ -7,6 +7,7 @@ ) where import Control.Lens ((^.)) +import Control.Monad (unless) import Data.Either.Extra import Data.Foldable (find) import Data.Text (Text) @@ -26,18 +27,33 @@ [testGroup "Refine Imports" [ codeActionGoldenTest "RefineWithOverride" 3 1 - , codeLensGoldenTest isRefineImports "RefineUsualCase" 1 - , codeLensGoldenTest isRefineImports "RefineQualified" 0 - , codeLensGoldenTest isRefineImports "RefineQualifiedExplicit" 0 + -- Although the client has inlay hints caps, refine is always provided by the code lens + , codeLensGoldenTest codeActionNoResolveCaps isRefineImports "RefineUsualCase" 1 + , codeLensGoldenTest codeActionNoResolveCaps isRefineImports "RefineQualified" 0 + , codeLensGoldenTest codeActionNoResolveCaps isRefineImports "RefineQualifiedExplicit" 0 ], testGroup "Make imports explicit" [ codeActionAllGoldenTest "ExplicitUsualCase" 3 0 , codeActionAllResolveGoldenTest "ExplicitUsualCase" 3 0 + , inlayHintsTestWithCap "ExplicitUsualCase" 2 $ (@=?) + [mkInlayHint (Position 2 16) "( a1 )" + (TextEdit (Range (Position 2 0) (Position 2 16)) "import ExplicitA ( a1 )")] + , inlayHintsTestWithoutCap "ExplicitUsualCase" 2 $ (@=?) [] , codeActionOnlyGoldenTest "ExplicitOnlyThis" 3 0 , codeActionOnlyResolveGoldenTest "ExplicitOnlyThis" 3 0 - , codeLensGoldenTest notRefineImports "ExplicitUsualCase" 0 + , inlayHintsTestWithCap "ExplicitOnlyThis" 3 $ (@=?) + [mkInlayHint (Position 3 16) "( b1 )" + (TextEdit (Range (Position 3 0) (Position 3 16)) "import ExplicitB ( b1 )")] + , inlayHintsTestWithoutCap "ExplicitOnlyThis" 3 $ (@=?) [] + -- Only when the client does not support inlay hints, explicit will be provided by code lens + , codeLensGoldenTest codeActionNoInlayHintsCaps notRefineImports "ExplicitUsualCase" 0 + , noCodeLensTest codeActionNoResolveCaps "ExplicitUsualCase" , codeActionBreakFile "ExplicitBreakFile" 4 0 + , inlayHintsTestWithCap "ExplicitBreakFile" 3 $ (@=?) + [mkInlayHint (Position 3 16) "( a1 )" + (TextEdit (Range (Position 3 0) (Position 3 16)) "import ExplicitA ( a1 )")] + , inlayHintsTestWithoutCap "ExplicitBreakFile" 3 $ (@=?) [] , codeActionStaleAction "ExplicitStaleAction" 4 0 , testCase "No CodeAction when exported" $ runSessionWithServer def explicitImportsPlugin testDataDir $ do @@ -49,6 +65,11 @@ doc <- openDoc "ExplicitExported.hs" "haskell" lenses <- getCodeLenses doc liftIO $ lenses @?= [] + , testCase "No InlayHints when exported" $ + runSessionWithServer def explicitImportsPlugin testDataDir $ do + doc <- openDoc "ExplicitExported.hs" "haskell" + inlayHints <- getInlayHints doc (pointRange 3 0) + liftIO $ inlayHints @?= [] , testGroup "Title abbreviation" [ testCase "not abbreviated" $ let i = "import " <> T.replicate 70 "F" <> " (Athing, Bthing, Cthing)" @@ -72,6 +93,20 @@ o = "import " <> T.replicate 80 "F" <> " (Athing, Bthing, ... (3 items))" in ExplicitImports.abbreviateImportTitle i @?= o ] + , testGroup "Title abbreviation without module" + [ testCase "not abbreviated" $ + let i = "import M (" <> T.replicate 70 "F" <> ", Athing, Bthing, Cthing)" + o = "(FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF, Athing, Bthing, Cthing)" + in ExplicitImports.abbreviateImportTitleWithoutModule i @?= o + , testCase "abbreviated that drop module name" $ + let i = "import " <> T.replicate 120 "F" <> " (Athing, Bthing, Cthing)" + o = "(Athing, Bthing, Cthing)" + in ExplicitImports.abbreviateImportTitleWithoutModule i @?= o + , testCase "abbreviated in import list" $ + let i = "import M (Athing, Bthing, " <> T.replicate 100 "F" <> ", Cthing, Dthing, Ething)" + o = "(Athing, Bthing, ... (4 items))" + in ExplicitImports.abbreviateImportTitleWithoutModule i @?= o + ] ]] -- code action tests @@ -84,7 +119,9 @@ _ -> liftIO $ assertFailure "Unable to find CodeAction" codeActionBreakFile :: FilePath -> Int -> Int -> TestTree -codeActionBreakFile fp l c = goldenWithImportActions " code action" fp codeActionNoResolveCaps $ \doc -> do +-- If use `codeActionNoResolveCaps` instead of `codeActionNoInlayHintsCaps` here, +-- we will get a puzzling error: https://github.com/haskell/haskell-language-server/pull/4235#issuecomment-2189048997 +codeActionBreakFile fp l c = goldenWithImportActions " code action" fp codeActionNoInlayHintsCaps $ \doc -> do _ <- getCodeLenses doc changeDoc doc [edit] actions <- getCodeActions doc (pointRange l c) @@ -150,17 +187,70 @@ -- code lens tests -codeLensGoldenTest :: (CodeLens -> Bool) -> FilePath -> Int -> TestTree -codeLensGoldenTest predicate fp i = goldenWithImportActions " code lens" fp codeActionNoResolveCaps $ \doc -> do +codeLensGoldenTest :: ClientCapabilities -> (CodeLens -> Bool) -> FilePath -> Int -> TestTree +codeLensGoldenTest caps predicate fp i = goldenWithImportActions " code lens" fp caps $ \doc -> do codeLenses <- getCodeLenses doc resolvedCodeLenses <- for codeLenses resolveCodeLens (CodeLens {_command = Just c}) <- pure (filter predicate resolvedCodeLenses !! i) executeCmd c +noCodeLensTest :: ClientCapabilities -> FilePath -> TestTree +noCodeLensTest caps fp = do + testCase (fp ++ " no code lens") $ run $ \_ -> do + doc <- openDoc (fp ++ ".hs") "haskell" + codeLenses <- getCodeLenses doc + resolvedCodeLenses <- for codeLenses resolveCodeLens + unless (null resolvedCodeLenses) $ + liftIO (assertFailure "Unexpected code lens") + where + run = runSessionWithTestConfig def + { testDirLocation = Left testDataDir + , testConfigCaps = caps + , testLspConfig = def + , testPluginDescriptor = explicitImportsPlugin + } + + notRefineImports :: CodeLens -> Bool notRefineImports (CodeLens _ (Just (Command text _ _)) _) | "Refine imports to" `T.isPrefixOf` text = False notRefineImports _ = True + +-- inlay hints tests + +inlayHintsTest :: ClientCapabilities -> String -> FilePath -> UInt -> ([InlayHint] -> Assertion) -> TestTree +inlayHintsTest configCaps postfix fp line assert = testCase (fp ++ postfix) $ run $ \_ -> do + doc <- openDoc (fp ++ ".hs") "haskell" + inlayHints <- getInlayHints doc (lineRange line) + liftIO $ assert inlayHints + where + -- zero-based position + lineRange line = Range (Position line 0) (Position line 1000) + run = runSessionWithTestConfig def + { testDirLocation = Left testDataDir + , testPluginDescriptor = explicitImportsPlugin + , testConfigCaps = configCaps + } + +inlayHintsTestWithCap :: FilePath -> UInt -> ([InlayHint] -> Assertion) -> TestTree +inlayHintsTestWithCap = inlayHintsTest fullLatestClientCaps " inlay hints with client caps" + +inlayHintsTestWithoutCap :: FilePath -> UInt -> ([InlayHint] -> Assertion) -> TestTree +inlayHintsTestWithoutCap = inlayHintsTest codeActionNoInlayHintsCaps " inlay hints without client caps" + + +mkInlayHint :: Position -> Text -> TextEdit -> InlayHint +mkInlayHint pos label textEdit = + InlayHint + { _position = pos + , _label = InL label + , _kind = Nothing + , _textEdits = Just [textEdit] + , _tooltip = Just $ InL "Make this import explicit" + , _paddingLeft = Just True + , _paddingRight = Nothing + , _data_ = Nothing + } -- Execute command and wait for result executeCmd :: Command -> Session () diff --git a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs --- a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs +++ b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs @@ -1,90 +1,123 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} module Ide.Plugin.ExplicitFields ( descriptor , Log ) where -import Control.Lens ((&), (?~), (^.)) -import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Arrow ((&&&)) +import Control.Lens ((&), (?~), (^.)) +import Control.Monad (replicateM) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe -import Data.Aeson (toJSON) -import Data.Generics (GenericQ, everything, - everythingBut, extQ, mkQ) -import qualified Data.IntMap.Strict as IntMap -import qualified Data.Map as Map -import Data.Maybe (fromMaybe, isJust, - maybeToList) -import Data.Text (Text) -import Data.Unique (hashUnique, newUnique) - -import Control.Monad (replicateM) -import Development.IDE (IdeState, Pretty (..), Range, - Recorder (..), Rules, - WithPriority (..), - defineNoDiagnostics, - realSrcSpanToRange, viaShow) +import Data.Aeson (ToJSON (toJSON)) +import Data.Generics (GenericQ, everything, + everythingBut, extQ, mkQ) +import qualified Data.IntMap.Strict as IntMap +import Data.List (find, intersperse) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe, isJust, + mapMaybe, maybeToList) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Unique (hashUnique, newUnique) +import Development.IDE (IdeState, + Location (Location), + Pretty (..), + Range (Range, _end, _start), + Recorder (..), Rules, + WithPriority (..), + defineNoDiagnostics, + getDefinition, hsep, + printName, + realSrcSpanToRange, + shakeExtras, + srcSpanToLocation, + srcSpanToRange, viaShow) import Development.IDE.Core.PluginUtils -import Development.IDE.Core.RuleTypes (TcModuleResult (..), - TypeCheck (..)) -import qualified Development.IDE.Core.Shake as Shake -import Development.IDE.GHC.Compat (HsConDetails (RecCon), - HsExpr (XExpr), - HsRecFields (..), LPat, - Outputable, getLoc, - recDotDot, unLoc) -import Development.IDE.GHC.Compat.Core (Extension (NamedFieldPuns), - GhcPass, - HsExpr (RecordCon, rcon_flds), - HsRecField, LHsExpr, - LocatedA, Name, Pass (..), - Pat (..), RealSrcSpan, - UniqFM, conPatDetails, - emptyUFM, hfbPun, hfbRHS, - hs_valds, lookupUFM, - mapConPatDetail, mapLoc, - pattern RealSrcSpan, - plusUFM_C, unitUFM) -import Development.IDE.GHC.Util (getExtensions, - printOutputable) -import Development.IDE.Graph (RuleResult) -import Development.IDE.Graph.Classes (Hashable, NFData) -import Development.IDE.Spans.Pragmas (NextPragmaInfo (..), - getFirstPragma, - insertNewPragma) -import GHC.Generics (Generic) -import Ide.Logger (Priority (..), cmapWithPrio, - logWith, (<+>)) -import Ide.Plugin.Error (PluginError (PluginInternalError, PluginStaleResolve), - getNormalizedFilePathE, - handleMaybe) -import Ide.Plugin.RangeMap (RangeMap) -import qualified Ide.Plugin.RangeMap as RangeMap -import Ide.Plugin.Resolve (mkCodeActionWithResolveAndCommand) -import Ide.Types (PluginDescriptor (..), - PluginId (..), - PluginMethodHandler, - ResolveFunction, - defaultPluginDescriptor) -import qualified Language.LSP.Protocol.Lens as L -import Language.LSP.Protocol.Message (Method (..)) -import Language.LSP.Protocol.Types (CodeAction (..), - CodeActionKind (CodeActionKind_RefactorRewrite), - CodeActionParams (..), - Command, TextEdit (..), - WorkspaceEdit (WorkspaceEdit), - type (|?) (InL, InR)) +import Development.IDE.Core.PositionMapping (toCurrentRange) +import Development.IDE.Core.RuleTypes (TcModuleResult (..), + TypeCheck (..)) +import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.GHC.Compat (FieldLabel (flSelector), + FieldOcc (FieldOcc), + GenLocated (L), GhcPass, + GhcTc, + HasSrcSpan (getLoc), + HsConDetails (RecCon), + HsExpr (HsApp, HsVar, XExpr), + HsFieldBind (hfbLHS), + HsRecFields (..), + HsWrap (HsWrap), + Identifier, LPat, + Located, + NamedThing (getName), + Outputable, + TcGblEnv (tcg_binds), + Var (varName), + XXExprGhcTc (..), + conLikeFieldLabels, + nameSrcSpan, + pprNameUnqualified, + recDotDot, unLoc) +import Development.IDE.GHC.Compat.Core (Extension (NamedFieldPuns), + HsExpr (RecordCon, rcon_flds), + HsRecField, LHsExpr, + LocatedA, Name, Pat (..), + RealSrcSpan, UniqFM, + conPatDetails, emptyUFM, + hfbPun, hfbRHS, + lookupUFM, + mapConPatDetail, mapLoc, + pattern RealSrcSpan, + plusUFM_C, unitUFM) +import Development.IDE.GHC.Util (getExtensions, + printOutputable) +import Development.IDE.Graph (RuleResult) +import Development.IDE.Graph.Classes (Hashable, NFData) +import Development.IDE.Spans.Pragmas (NextPragmaInfo (..), + getFirstPragma, + insertNewPragma) +import GHC.Generics (Generic) +import Ide.Logger (Priority (..), + cmapWithPrio, logWith, + (<+>)) +import Ide.Plugin.Error (PluginError (PluginInternalError, PluginStaleResolve), + getNormalizedFilePathE, + handleMaybe) +import Ide.Plugin.RangeMap (RangeMap) +import qualified Ide.Plugin.RangeMap as RangeMap +import Ide.Plugin.Resolve (mkCodeActionWithResolveAndCommand) +import Ide.Types (PluginDescriptor (..), + PluginId (..), + PluginMethodHandler, + ResolveFunction, + defaultPluginDescriptor, + mkPluginHandler) +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message (Method (..), + SMethod (SMethod_TextDocumentInlayHint)) +import Language.LSP.Protocol.Types (CodeAction (..), + CodeActionKind (CodeActionKind_RefactorRewrite), + CodeActionParams (CodeActionParams), + Command, InlayHint (..), + InlayHintLabelPart (InlayHintLabelPart), + InlayHintParams (InlayHintParams, _range, _textDocument), + TextDocumentIdentifier (TextDocumentIdentifier), + TextEdit (TextEdit), + WorkspaceEdit (WorkspaceEdit), + type (|?) (InL, InR)) #if __GLASGOW_HASKELL__ < 910 -import Development.IDE.GHC.Compat (HsExpansion (HsExpanded)) -#else -import Development.IDE.GHC.Compat (XXExprGhcRn (..)) +import Development.IDE.GHC.Compat (HsExpansion (HsExpanded)) #endif data Log @@ -105,8 +138,10 @@ descriptor recorder plId = let resolveRecorder = cmapWithPrio LogResolve recorder (carCommands, caHandlers) = mkCodeActionWithResolveAndCommand resolveRecorder plId codeActionProvider codeActionResolveProvider + ihDotdotHandler = mkPluginHandler SMethod_TextDocumentInlayHint (inlayHintDotdotProvider recorder) + ihPosRecHandler = mkPluginHandler SMethod_TextDocumentInlayHint (inlayHintPosRecProvider recorder) in (defaultPluginDescriptor plId "Provides a code action to make record wildcards explicit") - { pluginHandlers = caHandlers + { pluginHandlers = caHandlers <> ihDotdotHandler <> ihPosRecHandler , pluginCommands = carCommands , pluginRules = collectRecordsRule recorder *> collectNamesRule } @@ -120,12 +155,9 @@ let actions = map (mkCodeAction enabledExtensions) (RangeMap.filterByRange range crCodeActions) pure $ InL actions where - mkCodeAction :: [Extension] -> Int -> Command |? CodeAction - mkCodeAction exts uid = InR CodeAction - { _title = "Expand record wildcard" - <> if NamedFieldPuns `elem` exts - then mempty - else " (needs extension: NamedFieldPuns)" + mkCodeAction :: [Extension] -> Int -> Command |? CodeAction + mkCodeAction exts uid = InR CodeAction + { _title = mkTitle exts -- TODO: `Expand positional record` without NamedFieldPuns if RecordInfoApp , _kind = Just CodeActionKind_RefactorRewrite , _diagnostics = Nothing , _isPreferred = Nothing @@ -144,18 +176,115 @@ -- that this resolve is stale. record <- handleMaybe PluginStaleResolve $ IntMap.lookup uid crCodeActionResolve -- We should never fail to render - rendered <- handleMaybe (PluginInternalError "Failed to render") $ renderRecordInfo nameMap record - let edits = [rendered] - <> maybeToList (pragmaEdit enabledExtensions pragma) + rendered <- handleMaybe (PluginInternalError "Failed to render") $ renderRecordInfoAsTextEdit nameMap record + let shouldInsertNamedFieldPuns (RecordInfoApp _ _) = False + shouldInsertNamedFieldPuns _ = True + whenMaybe True x = x + whenMaybe False _ = Nothing + edits = [rendered] + <> maybeToList (whenMaybe (shouldInsertNamedFieldPuns record) (pragmaEdit enabledExtensions pragma)) pure $ ca & L.edit ?~ mkWorkspaceEdit edits where mkWorkspaceEdit ::[TextEdit] -> WorkspaceEdit mkWorkspaceEdit edits = WorkspaceEdit (Just $ Map.singleton uri edits) Nothing Nothing - pragmaEdit :: [Extension] -> NextPragmaInfo -> Maybe TextEdit - pragmaEdit exts pragma = if NamedFieldPuns `elem` exts - then Nothing - else Just $ insertNewPragma pragma NamedFieldPuns +inlayHintDotdotProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentInlayHint +inlayHintDotdotProvider _ state pId InlayHintParams {_textDocument = TextDocumentIdentifier uri, _range = visibleRange} = do + nfp <- getNormalizedFilePathE uri + pragma <- getFirstPragma pId state nfp + runIdeActionE "ExplicitFields.CollectRecords" (shakeExtras state) $ do + (crr@CRR {crCodeActions, crCodeActionResolve}, pm) <- useWithStaleFastE CollectRecords nfp + let -- Get all records with dotdot in current nfp + records = [ record + | Just range <- [toCurrentRange pm visibleRange] + , uid <- RangeMap.elementsInRange range crCodeActions + , Just record <- [IntMap.lookup uid crCodeActionResolve] ] + -- Get the definition of each dotdot of record + locations = [ fmap (,record) (getDefinition nfp pos) + | record <- records + , pos <- maybeToList $ fmap _start $ recordInfoToDotDotRange record ] + defnLocsList <- lift $ sequence locations + pure $ InL $ mapMaybe (mkInlayHint crr pragma) defnLocsList + where + mkInlayHint :: CollectRecordsResult -> NextPragmaInfo -> (Maybe [(Location, Identifier)], RecordInfo) -> Maybe InlayHint + mkInlayHint CRR {enabledExtensions, nameMap} pragma (defnLocs, record) = + let range = recordInfoToDotDotRange record + textEdits = maybeToList (renderRecordInfoAsTextEdit nameMap record) + <> maybeToList (pragmaEdit enabledExtensions pragma) + names = renderRecordInfoAsDotdotLabelName record + in do + end <- fmap _end range + names' <- names + defnLocs' <- defnLocs + let excludeDotDot (Location _ (Range _ end')) = end' /= end + -- find location from dotdot definitions that name equal to label name + findLocation name locations = + let -- filter locations not within dotdot range + filteredLocations = filter (excludeDotDot . fst) locations + -- checks if 'a' is equal to 'Name' if the 'Either' is 'Right a', otherwise return 'False' + nameEq = either (const False) ((==) name) + in fmap fst $ find (nameEq . snd) filteredLocations + valueWithLoc = [ (T.pack $ printName name, findLocation name defnLocs') | name <- names' ] + -- use `, ` to separate labels with definition location + label = intersperse (mkInlayHintLabelPart (", ", Nothing)) $ fmap mkInlayHintLabelPart valueWithLoc + pure $ InlayHint { _position = end -- at the end of dotdot + , _label = InR label + , _kind = Nothing -- neither a type nor a parameter + , _textEdits = Just textEdits -- same as CodeAction + , _tooltip = Just $ InL (mkTitle enabledExtensions) -- same as CodeAction + , _paddingLeft = Just True -- padding after dotdot + , _paddingRight = Nothing + , _data_ = Nothing + } + mkInlayHintLabelPart (value, loc) = InlayHintLabelPart value Nothing loc Nothing + + +inlayHintPosRecProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentInlayHint +inlayHintPosRecProvider _ state _pId InlayHintParams {_textDocument = TextDocumentIdentifier uri, _range = visibleRange} = do + nfp <- getNormalizedFilePathE uri + runIdeActionE "ExplicitFields.CollectRecords" (shakeExtras state) $ do + (CRR {crCodeActions, nameMap, crCodeActionResolve}, pm) <- useWithStaleFastE CollectRecords nfp + let records = [ record + | Just range <- [toCurrentRange pm visibleRange] + , uid <- RangeMap.elementsInRange range crCodeActions + , Just record <- [IntMap.lookup uid crCodeActionResolve] ] + pure $ InL (concatMap (mkInlayHints nameMap) records) + where + mkInlayHints :: UniqFM Name [Name] -> RecordInfo -> [InlayHint] + mkInlayHints nameMap record@(RecordInfoApp _ (RecordAppExpr _ fla)) = + let textEdits = renderRecordInfoAsTextEdit nameMap record + in mapMaybe (mkInlayHint textEdits) fla + mkInlayHints _ _ = [] + mkInlayHint :: Maybe TextEdit -> (Located FieldLabel, HsExpr GhcTc) -> Maybe InlayHint + mkInlayHint te (label, _) = + let (name, loc) = ((flSelector . unLoc) &&& (srcSpanToLocation . getLoc)) label + fieldDefLoc = srcSpanToLocation (nameSrcSpan name) + in do + (Location _ recRange) <- loc + pure InlayHint { _position = _start recRange + , _label = InR $ pure (mkInlayHintLabelPart name fieldDefLoc) + , _kind = Nothing -- neither a type nor a parameter + , _textEdits = Just (maybeToList te) -- same as CodeAction + , _tooltip = Just $ InL "Expand positional record" -- same as CodeAction + , _paddingLeft = Nothing + , _paddingRight = Nothing + , _data_ = Nothing + } + mkInlayHintLabelPart name loc = InlayHintLabelPart (printOutputable (pprNameUnqualified name) <> "=") Nothing loc Nothing + +mkTitle :: [Extension] -> Text +mkTitle exts = "Expand record wildcard" + <> if NamedFieldPuns `elem` exts + then mempty + else " (needs extension: NamedFieldPuns)" + + +pragmaEdit :: [Extension] -> NextPragmaInfo -> Maybe TextEdit +pragmaEdit exts pragma = if NamedFieldPuns `elem` exts + then Nothing + else Just $ insertNewPragma pragma NamedFieldPuns + + collectRecordsRule :: Recorder (WithPriority Log) -> Rules () collectRecordsRule recorder = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \CollectRecords nfp -> runMaybeT $ do @@ -176,15 +305,11 @@ pure CRR {crCodeActions, crCodeActionResolve, nameMap, enabledExtensions} where getEnabledExtensions :: TcModuleResult -> [Extension] - getEnabledExtensions = getExtensions . tmrParsed + getEnabledExtensions = getExtensions . tmrParsed toRangeAndUnique (uid, recordInfo) = (recordInfoToRange recordInfo, uid) getRecords :: TcModuleResult -> [RecordInfo] -#if __GLASGOW_HASKELL__ < 910 -getRecords (tmrRenamed -> (hs_valds -> valBinds,_,_,_)) = collectRecords valBinds -#else -getRecords (tmrRenamed -> (hs_valds -> valBinds,_,_,_, _)) = collectRecords valBinds -#endif +getRecords (tcg_binds . tmrTypechecked -> valBinds) = collectRecords valBinds collectNamesRule :: Rules () collectNamesRule = defineNoDiagnostics mempty $ \CollectNames nfp -> runMaybeT $ do @@ -226,6 +351,7 @@ instance NFData CollectRecordsResult instance NFData RecordInfo +instance NFData RecordAppExpr instance Show CollectRecordsResult where show _ = "" @@ -248,23 +374,42 @@ type instance RuleResult CollectNames = CollectNamesResult +data RecordAppExpr = RecordAppExpr (LHsExpr GhcTc) [(Located FieldLabel, HsExpr GhcTc)] + deriving (Generic) + data RecordInfo - = RecordInfoPat RealSrcSpan (Pat (GhcPass 'Renamed)) - | RecordInfoCon RealSrcSpan (HsExpr (GhcPass 'Renamed)) + = RecordInfoPat RealSrcSpan (Pat GhcTc) + | RecordInfoCon RealSrcSpan (HsExpr GhcTc) + | RecordInfoApp RealSrcSpan RecordAppExpr deriving (Generic) instance Pretty RecordInfo where pretty (RecordInfoPat ss p) = pretty (printOutputable ss) <> ":" <+> pretty (printOutputable p) pretty (RecordInfoCon ss e) = pretty (printOutputable ss) <> ":" <+> pretty (printOutputable e) + pretty (RecordInfoApp ss (RecordAppExpr _ fla)) + = pretty (printOutputable ss) <> ":" <+> hsep (map (pretty . printOutputable) fla) recordInfoToRange :: RecordInfo -> Range recordInfoToRange (RecordInfoPat ss _) = realSrcSpanToRange ss recordInfoToRange (RecordInfoCon ss _) = realSrcSpanToRange ss +recordInfoToRange (RecordInfoApp ss _) = realSrcSpanToRange ss -renderRecordInfo :: UniqFM Name [Name] -> RecordInfo -> Maybe TextEdit -renderRecordInfo names (RecordInfoPat ss pat) = TextEdit (realSrcSpanToRange ss) <$> showRecordPat names pat -renderRecordInfo _ (RecordInfoCon ss expr) = TextEdit (realSrcSpanToRange ss) <$> showRecordCon expr +recordInfoToDotDotRange :: RecordInfo -> Maybe Range +recordInfoToDotDotRange (RecordInfoPat _ (ConPat _ _ (RecCon flds))) = srcSpanToRange . getLoc =<< rec_dotdot flds +recordInfoToDotDotRange (RecordInfoCon _ (RecordCon _ _ flds)) = srcSpanToRange . getLoc =<< rec_dotdot flds +recordInfoToDotDotRange _ = Nothing +renderRecordInfoAsTextEdit :: UniqFM Name [Name] -> RecordInfo -> Maybe TextEdit +renderRecordInfoAsTextEdit names (RecordInfoPat ss pat) = TextEdit (realSrcSpanToRange ss) <$> showRecordPat names pat +renderRecordInfoAsTextEdit _ (RecordInfoCon ss expr) = TextEdit (realSrcSpanToRange ss) <$> showRecordCon expr +renderRecordInfoAsTextEdit _ (RecordInfoApp ss appExpr) = TextEdit (realSrcSpanToRange ss) <$> showRecordApp appExpr + +renderRecordInfoAsDotdotLabelName :: RecordInfo -> Maybe [Name] +renderRecordInfoAsDotdotLabelName (RecordInfoPat _ pat) = showRecordPatFlds pat +renderRecordInfoAsDotdotLabelName (RecordInfoCon _ expr) = showRecordConFlds expr +renderRecordInfoAsDotdotLabelName _ = Nothing + + -- | Checks if a 'Name' is referenced in the given map of names. The -- 'hasNonBindingOcc' check is necessary in order to make sure that only the -- references at the use-sites are considered (i.e. the binding occurence @@ -281,16 +426,16 @@ filterReferenced :: (a -> Maybe Name) -> UniqFM Name [Name] -> [a] -> [a] filterReferenced getName names = filter (\x -> maybe True (`referencedIn` names) (getName x)) + preprocessRecordPat - :: p ~ GhcPass 'Renamed + :: p ~ GhcTc => UniqFM Name [Name] -> HsRecFields p (LPat p) -> HsRecFields p (LPat p) -preprocessRecordPat = preprocessRecord (getFieldName . unLoc) - where - getFieldName x = case unLoc (hfbRHS x) of - VarPat _ x' -> Just $ unLoc x' - _ -> Nothing +preprocessRecordPat = preprocessRecord (fmap varName . getFieldName . unLoc) + where getFieldName x = case unLoc (hfbRHS x) of + VarPat _ x' -> Just $ unLoc x' + _ -> Nothing -- No need to check the name usage in the record construction case preprocessRecordCon :: HsRecFields (GhcPass c) arg -> HsRecFields (GhcPass c) arg @@ -333,17 +478,65 @@ punsUsed = filterReferenced getName names puns' rec_flds' = no_puns <> punsUsed -showRecordPat :: Outputable (Pat (GhcPass 'Renamed)) => UniqFM Name [Name] -> Pat (GhcPass 'Renamed) -> Maybe Text +processRecordFlds + :: p ~ GhcPass c + => HsRecFields p arg + -> HsRecFields p arg +processRecordFlds flds = flds { rec_dotdot = Nothing , rec_flds = puns' } + where + no_pun_count = fromMaybe (length (rec_flds flds)) (recDotDot flds) + -- Field binds of the explicit form (e.g. `{ a = a' }`) should be drop + puns = drop no_pun_count (rec_flds flds) + -- `hsRecPun` is set to `True` in order to pretty-print the fields as field + -- puns (since there is similar mechanism in the `Outputable` instance as + -- explained above). + puns' = map (mapLoc (\fld -> fld { hfbPun = True })) puns + + +showRecordPat :: Outputable (Pat GhcTc) => UniqFM Name [Name] -> Pat GhcTc -> Maybe Text showRecordPat names = fmap printOutputable . mapConPatDetail (\case RecCon flds -> Just $ RecCon (preprocessRecordPat names flds) _ -> Nothing) +showRecordPatFlds :: Pat GhcTc -> Maybe [Name] +showRecordPatFlds (ConPat _ _ args) = do + fields <- processRecCon args + names <- mapM getFieldName (rec_flds fields) + pure names + where + processRecCon (RecCon flds) = Just $ processRecordFlds flds + processRecCon _ = Nothing +#if __GLASGOW_HASKELL__ < 911 + getOccName (FieldOcc x _) = Just $ getName x +#else + getOccName (FieldOcc _ x) = Just $ getName (unLoc x) +#endif + getOccName _ = Nothing + getFieldName = getOccName . unLoc . hfbLHS . unLoc +showRecordPatFlds _ = Nothing + showRecordCon :: Outputable (HsExpr (GhcPass c)) => HsExpr (GhcPass c) -> Maybe Text showRecordCon expr@(RecordCon _ _ flds) = Just $ printOutputable $ expr { rcon_flds = preprocessRecordCon flds } showRecordCon _ = Nothing +showRecordConFlds :: p ~ GhcTc => HsExpr p -> Maybe [Name] +showRecordConFlds (RecordCon _ _ flds) = + mapM getFieldName (rec_flds $ processRecordFlds flds) + where + getVarName (HsVar _ lidp) = Just $ getName lidp + getVarName _ = Nothing + getFieldName = getVarName . unLoc . hfbRHS . unLoc +showRecordConFlds _ = Nothing + +showRecordApp :: RecordAppExpr -> Maybe Text +showRecordApp (RecordAppExpr recConstr fla) + = Just $ printOutputable recConstr <> " { " + <> T.intercalate ", " (showFieldWithArg <$> fla) + <> " }" + where showFieldWithArg (field, arg) = printOutputable field <> " = " <> printOutputable arg + collectRecords :: GenericQ [RecordInfo] collectRecords = everythingBut (<>) (([], False) `mkQ` getRecPatterns `extQ` getRecCons) @@ -360,7 +553,7 @@ collectNames :: GenericQ (UniqFM Name [Name]) collectNames = everything (plusUFM_C (<>)) (emptyUFM `mkQ` (\x -> unitUFM x [x])) -getRecCons :: LHsExpr (GhcPass 'Renamed) -> ([RecordInfo], Bool) +getRecCons :: LHsExpr GhcTc -> ([RecordInfo], Bool) -- When we stumble upon an occurrence of HsExpanded, we only want to follow a -- single branch. We do this here, by explicitly returning occurrences from -- traversing the original branch, and returning True, which keeps syb from @@ -369,25 +562,50 @@ -- branch #if __GLASGOW_HASKELL__ >= 910 -getRecCons (unLoc -> XExpr (ExpandedThingRn a _)) = (collectRecords a, True) +getRecCons (unLoc -> XExpr (ExpandedThingTc a _)) = (collectRecords a, False) #else -getRecCons (unLoc -> XExpr (HsExpanded a _)) = (collectRecords a, True) +getRecCons (unLoc -> XExpr (ExpansionExpr (HsExpanded _ a))) = (collectRecords a, True) #endif getRecCons e@(unLoc -> RecordCon _ _ flds) | isJust (rec_dotdot flds) = (mkRecInfo e, False) where - mkRecInfo :: LHsExpr (GhcPass 'Renamed) -> [RecordInfo] + mkRecInfo :: LHsExpr GhcTc -> [RecordInfo] mkRecInfo expr = [ RecordInfoCon realSpan' (unLoc expr) | RealSrcSpan realSpan' _ <- [ getLoc expr ]] +getRecCons expr@(unLoc -> app@(HsApp _ _ _)) = + let fieldss = maybeToList $ getFields app [] + recInfo = concatMap mkRecInfo fieldss + in (recInfo, not (null recInfo)) + where + mkRecInfo :: RecordAppExpr -> [RecordInfo] + mkRecInfo appExpr = + [ RecordInfoApp realSpan' appExpr | RealSrcSpan realSpan' _ <- [ getLoc expr ] ] + + getFields :: HsExpr GhcTc -> [LHsExpr GhcTc] -> Maybe RecordAppExpr + getFields (HsApp _ constr@(unLoc -> expr) arg) args + | not (null fls) + = Just (RecordAppExpr constr labelWithArgs) + where fls = getExprFields expr + labelWithArgs = zipWith mkLabelWithArg fls (arg : args) + mkLabelWithArg label arg = (L (getLoc arg) label, unLoc arg) + getFields (HsApp _ constr arg) args = getFields (unLoc constr) (arg : args) + getFields _ _ = Nothing + + getExprFields :: HsExpr GhcTc -> [FieldLabel] + getExprFields (XExpr (ConLikeTc (conLikeFieldLabels -> fls) _ _)) = fls +#if __GLASGOW_HASKELL__ >= 911 + getExprFields (XExpr (WrapExpr _ expr)) = getExprFields expr +#else + getExprFields (XExpr (WrapExpr (HsWrap _ expr))) = getExprFields expr +#endif + getExprFields _ = [] getRecCons _ = ([], False) -getRecPatterns :: LPat (GhcPass 'Renamed) -> ([RecordInfo], Bool) +getRecPatterns :: LPat GhcTc -> ([RecordInfo], Bool) getRecPatterns conPat@(conPatDetails . unLoc -> Just (RecCon flds)) | isJust (rec_dotdot flds) = (mkRecInfo conPat, False) where - mkRecInfo :: LPat (GhcPass 'Renamed) -> [RecordInfo] + mkRecInfo :: LPat GhcTc -> [RecordInfo] mkRecInfo pat = [ RecordInfoPat realSpan' (unLoc pat) | RealSrcSpan realSpan' _ <- [ getLoc pat ]] getRecPatterns _ = ([], False) - - diff --git a/plugins/hls-explicit-record-fields-plugin/test/Main.hs b/plugins/hls-explicit-record-fields-plugin/test/Main.hs --- a/plugins/hls-explicit-record-fields-plugin/test/Main.hs +++ b/plugins/hls-explicit-record-fields-plugin/test/Main.hs @@ -4,7 +4,11 @@ module Main ( main ) where import Data.Either (rights) +import Data.Text (Text) import qualified Data.Text as T +import Development.IDE (filePathToUri', + toNormalizedFilePath') +import Development.IDE.Test (canonicalizeUri) import qualified Ide.Plugin.ExplicitFields as ExplicitFields import System.FilePath ((<.>), ()) import Test.Hls @@ -17,21 +21,236 @@ test :: TestTree test = testGroup "explicit-fields" - [ mkTest "WildcardOnly" "WildcardOnly" 12 10 12 20 - , mkTest "Unused" "Unused" 12 10 12 20 - , mkTest "Unused2" "Unused2" 12 10 12 20 - , mkTest "WithPun" "WithPun" 13 10 13 25 - , mkTest "WithExplicitBind" "WithExplicitBind" 12 10 12 32 - , mkTest "Mixed" "Mixed" 14 10 14 37 - , mkTest "Construction" "Construction" 16 5 16 15 - , mkTest "HsExpanded1" "HsExpanded1" 17 10 17 20 - , mkTest "HsExpanded2" "HsExpanded2" 23 10 23 22 - , mkTestNoAction "ExplicitBinds" "ExplicitBinds" 11 10 11 52 - , mkTestNoAction "Puns" "Puns" 12 10 12 31 - , mkTestNoAction "Infix" "Infix" 11 11 11 31 - , mkTestNoAction "Prefix" "Prefix" 10 11 10 28 + [ testGroup "code actions" + [ mkTest "WildcardOnly" "WildcardOnly" 12 10 12 20 + , mkTest "Unused" "Unused" 12 10 12 20 + , mkTest "Unused2" "Unused2" 12 10 12 20 + , mkTest "WithPun" "WithPun" 13 10 13 25 + , mkTest "WithExplicitBind" "WithExplicitBind" 12 10 12 32 + , mkTest "Mixed" "Mixed" 14 10 14 37 + , mkTest "Construction" "Construction" 16 5 16 15 + , mkTest "PositionalConstruction" "PositionalConstruction" 15 5 15 15 + , mkTest "HsExpanded1" "HsExpanded1" 17 10 17 20 + , mkTest "HsExpanded2" "HsExpanded2" 23 10 23 22 + , mkTestNoAction "ExplicitBinds" "ExplicitBinds" 11 10 11 52 + , mkTestNoAction "Puns" "Puns" 12 10 12 31 + , mkTestNoAction "Infix" "Infix" 11 11 11 31 + , mkTestNoAction "Prefix" "Prefix" 10 11 10 28 + , mkTest "PolymorphicRecordConstruction" "PolymorphicRecordConstruction" 15 5 15 15 + ] + , testGroup "inlay hints" + [ mkInlayHintsTest "Construction" Nothing 16 $ \ih -> do + let mkLabelPart' = mkLabelPartOffsetLength "Construction" + foo <- mkLabelPart' 13 6 "foo" + bar <- mkLabelPart' 14 6 "bar" + baz <- mkLabelPart' 15 6 "baz" + (@?=) ih + [defInlayHint { _position = Position 16 14 + , _label = InR [ foo, commaPart + , bar, commaPart + , baz + ] + , _textEdits = Just [ mkLineTextEdit "MyRec {foo, bar, baz}" 16 5 15 + , mkPragmaTextEdit 2 + ] + , _tooltip = Just $ InL "Expand record wildcard (needs extension: NamedFieldPuns)" + , _paddingLeft = Just True + }] + , mkInlayHintsTest "PositionalConstruction" Nothing 15 $ \ih -> do + let mkLabelPart' = mkLabelPartOffsetLengthSub1 "PositionalConstruction" + foo <- mkLabelPart' 5 4 "foo=" + bar <- mkLabelPart' 6 4 "bar=" + baz <- mkLabelPart' 7 4 "baz=" + (@?=) ih + [ defInlayHint { _position = Position 15 11 + , _label = InR [ foo ] + , _textEdits = Just [ mkLineTextEdit "MyRec { foo = a, bar = b, baz = c }" 15 5 16 ] + , _tooltip = Just $ InL "Expand positional record" + , _paddingLeft = Nothing + } + , defInlayHint { _position = Position 15 13 + , _label = InR [ bar ] + , _textEdits = Just [ mkLineTextEdit "MyRec { foo = a, bar = b, baz = c }" 15 5 16 ] + , _tooltip = Just $ InL "Expand positional record" + , _paddingLeft = Nothing + } + , defInlayHint { _position = Position 15 15 + , _label = InR [ baz ] + , _textEdits = Just [ mkLineTextEdit "MyRec { foo = a, bar = b, baz = c }" 15 5 16 ] + , _tooltip = Just $ InL "Expand positional record" + , _paddingLeft = Nothing + } + ] + , mkInlayHintsTest "HsExpanded1" Nothing 17 $ \ih -> do + let mkLabelPart' = mkLabelPartOffsetLength "HsExpanded1" + foo <- mkLabelPart' 11 4 "foo" + (@?=) ih + [defInlayHint { _position = Position 17 19 + , _label = InR [ foo ] + , _textEdits = Just [ mkLineTextEdit "MyRec {foo}" 17 10 20 ] + , _tooltip = Just $ InL "Expand record wildcard" + , _paddingLeft = Just True + }] + , mkInlayHintsTest "HsExpanded1" (Just " (positional)") 13 $ \ih -> do + let mkLabelPart' = mkLabelPartOffsetLengthSub1 "HsExpanded1" + foo <- mkLabelPart' 11 4 "foo=" + (@?=) ih + [defInlayHint { _position = Position 13 21 + , _label = InR [ foo ] + , _textEdits = Just [ mkLineTextEdit "MyRec { foo = 5 }" 13 15 22 ] + , _tooltip = Just $ InL "Expand positional record" + , _paddingLeft = Nothing + }] + , mkInlayHintsTest "HsExpanded2" Nothing 23 $ \ih -> do + let mkLabelPart' = mkLabelPartOffsetLength "HsExpanded2" + bar <- mkLabelPart' 14 4 "bar" + (@?=) ih + [defInlayHint { _position = Position 23 21 + , _label = InR [ bar ] + , _textEdits = Just [ mkLineTextEdit "YourRec {bar}" 23 10 22 ] + , _tooltip = Just $ InL "Expand record wildcard" + , _paddingLeft = Just True + }] + , mkInlayHintsTest "HsExpanded2" (Just " (positional)") 16 $ \ih -> do + let mkLabelPart' = mkLabelPartOffsetLengthSub1 "HsExpanded2" + foo <- mkLabelPart' 11 4 "foo=" + (@?=) ih + [defInlayHint { _position = Position 16 21 + , _label = InR [ foo ] + , _textEdits = Just [ mkLineTextEdit "MyRec { foo = 5 }" 16 15 22 ] + , _tooltip = Just $ InL "Expand positional record" + , _paddingLeft = Nothing + }] + , mkInlayHintsTest "Mixed" Nothing 14 $ \ih -> do + let mkLabelPart' = mkLabelPartOffsetLength "Mixed" + baz <- mkLabelPart' 9 4 "baz" + quux <- mkLabelPart' 10 4 "quux" + (@?=) ih + [defInlayHint { _position = Position 14 36 + , _label = InR [ baz, commaPart + , quux + ] + , _textEdits = Just [ mkLineTextEdit "MyRec {foo, bar = bar', baz}" 14 10 37 ] + , _tooltip = Just $ InL "Expand record wildcard" + , _paddingLeft = Just True + }] + , mkInlayHintsTest "Unused" Nothing 12 $ \ih -> do + let mkLabelPart' = mkLabelPartOffsetLength "Unused" + foo <- mkLabelPart' 6 4 "foo" + bar <- mkLabelPart' 7 4 "bar" + baz <- mkLabelPart' 8 4 "baz" + (@?=) ih + [defInlayHint { _position = Position 12 19 + , _label = InR [ foo, commaPart + , bar, commaPart + , baz + ] + , _textEdits = Just [ mkLineTextEdit "MyRec {foo, bar}" 12 10 20 + , mkPragmaTextEdit 2 + ] + , _tooltip = Just $ InL "Expand record wildcard (needs extension: NamedFieldPuns)" + , _paddingLeft = Just True + }] + , mkInlayHintsTest "Unused2" Nothing 12 $ \ih -> do + let mkLabelPart' = mkLabelPartOffsetLength "Unused2" + foo <- mkLabelPart' 6 4 "foo" + bar <- mkLabelPart' 7 4 "bar" + baz <- mkLabelPart' 8 4 "baz" + (@?=) ih + [defInlayHint { _position = Position 12 19 + , _label = InR [ foo, commaPart + , bar, commaPart + , baz + ] + , _textEdits = Just [ mkLineTextEdit "MyRec {foo, bar}" 12 10 20 + , mkPragmaTextEdit 2 + ] + , _tooltip = Just $ InL "Expand record wildcard (needs extension: NamedFieldPuns)" + , _paddingLeft = Just True + }] + , mkInlayHintsTest "WildcardOnly" Nothing 12 $ \ih -> do + let mkLabelPart' = mkLabelPartOffsetLength "WildcardOnly" + foo <- mkLabelPart' 6 4 "foo" + bar <- mkLabelPart' 7 4 "bar" + baz <- mkLabelPart' 8 4 "baz" + (@?=) ih + [defInlayHint { _position = Position 12 19 + , _label = InR [ foo, commaPart + , bar, commaPart + , baz + ] + , _textEdits = Just [ mkLineTextEdit "MyRec {foo, bar, baz}" 12 10 20 + , mkPragmaTextEdit 2 + ] + , _tooltip = Just $ InL "Expand record wildcard (needs extension: NamedFieldPuns)" + , _paddingLeft = Just True + }] + , mkInlayHintsTest "WithExplicitBind" Nothing 12 $ \ih -> do + let mkLabelPart' = mkLabelPartOffsetLength "WithExplicitBind" + bar <- mkLabelPart' 7 4 "bar" + baz <- mkLabelPart' 8 4 "baz" + (@?=) ih + [defInlayHint { _position = Position 12 31 + , _label = InR [ bar, commaPart + , baz + ] + , _textEdits = Just [ mkLineTextEdit "MyRec {foo = foo', bar, baz}" 12 10 32 + , mkPragmaTextEdit 2 + ] + , _tooltip = Just $ InL "Expand record wildcard (needs extension: NamedFieldPuns)" + , _paddingLeft = Just True + }] + , mkInlayHintsTest "WithPun" Nothing 13 $ \ih -> do + let mkLabelPart' = mkLabelPartOffsetLength "WithPun" + bar <- mkLabelPart' 8 4 "bar" + baz <- mkLabelPart' 9 4 "baz" + (@?=) ih + [defInlayHint { _position = Position 13 24 + , _label = InR [ bar, commaPart + , baz + ] + , _textEdits = Just [ mkLineTextEdit "MyRec {foo, bar, baz}" 13 10 25 ] + , _tooltip = Just $ InL "Expand record wildcard" + , _paddingLeft = Just True + }] + , mkInlayHintsTest "PolymorphicRecordConstruction" Nothing 15 $ \ih -> do + let mkLabelPart' = mkLabelPartOffsetLengthSub1 "PolymorphicRecordConstruction" + foo <- mkLabelPart' 5 4 "foo=" + bar <- mkLabelPart' 6 4 "bar=" + baz <- mkLabelPart' 7 4 "baz=" + (@?=) ih + [ defInlayHint { _position = Position 15 11 + , _label = InR [ foo ] + , _textEdits = Just [ mkLineTextEdit "MyRec { foo = a, bar = b, baz = c }" 15 5 16 ] + , _tooltip = Just $ InL "Expand positional record" + , _paddingLeft = Nothing + } + , defInlayHint { _position = Position 15 13 + , _label = InR [ bar ] + , _textEdits = Just [ mkLineTextEdit "MyRec { foo = a, bar = b, baz = c }" 15 5 16 ] + , _tooltip = Just $ InL "Expand positional record" + , _paddingLeft = Nothing + } + , defInlayHint { _position = Position 15 15 + , _label = InR [ baz ] + , _textEdits = Just [ mkLineTextEdit "MyRec { foo = a, bar = b, baz = c }" 15 5 16 ] + , _tooltip = Just $ InL "Expand positional record" + , _paddingLeft = Nothing + } + ] + ] ] +mkInlayHintsTest :: FilePath -> Maybe TestName -> UInt -> ([InlayHint] -> Assertion) -> TestTree +mkInlayHintsTest fp postfix line assert = + testCase (fp ++ concat postfix) $ + runSessionWithServer def plugin testDataDir $ do + doc <- openDoc (fp ++ ".hs") "haskell" + inlayHints <- getInlayHints doc (lineRange line) + liftIO $ assert inlayHints + where + lineRange line = Range (Position line 0) (Position line 1000) + mkTestNoAction :: TestName -> FilePath -> UInt -> UInt -> UInt -> UInt -> TestTree mkTestNoAction title fp x1 y1 x2 y2 = testCase title $ @@ -65,6 +284,61 @@ isExplicitFieldsCodeAction :: CodeAction -> Bool isExplicitFieldsCodeAction CodeAction {_title} = "Expand record wildcard" `T.isPrefixOf` _title + +defInlayHint :: InlayHint +defInlayHint = + InlayHint + { _position = Position 0 0 + , _label = InR [] + , _kind = Nothing + , _textEdits = Nothing + , _tooltip = Nothing + , _paddingLeft = Nothing + , _paddingRight = Nothing + , _data_ = Nothing + } + +mkLabelPart :: (Text -> UInt) -> FilePath -> UInt -> UInt -> Text -> IO InlayHintLabelPart +mkLabelPart offset fp line start value = do + uri' <- uri + pure $ InlayHintLabelPart { _location = Just (location uri' line start) + , _value = value + , _tooltip = Nothing + , _command = Nothing + } + where + toUri = fromNormalizedUri . filePathToUri' . toNormalizedFilePath' + uri = canonicalizeUri $ toUri (testDataDir (fp ++ ".hs")) + location uri line char = Location uri (Range (Position line char) (Position line (char + offset value))) + +mkLabelPartOffsetLength :: FilePath -> UInt -> UInt -> Text -> IO InlayHintLabelPart +mkLabelPartOffsetLength = mkLabelPart (fromIntegral . T.length) + +mkLabelPartOffsetLengthSub1 :: FilePath -> UInt -> UInt -> Text -> IO InlayHintLabelPart +mkLabelPartOffsetLengthSub1 = mkLabelPart (fromIntegral . subtract 1 . T.length) + +commaPart :: InlayHintLabelPart +commaPart = + InlayHintLabelPart + { _location = Nothing + , _value = ", " + , _tooltip = Nothing + , _command = Nothing + } + +mkLineTextEdit :: Text -> UInt -> UInt -> UInt -> TextEdit +mkLineTextEdit newText line x y = + TextEdit + { _range = Range (Position line x) (Position line y) + , _newText = newText + } + +mkPragmaTextEdit :: UInt -> TextEdit +mkPragmaTextEdit line = + TextEdit + { _range = Range (Position line 0) (Position line 0) + , _newText = "{-# LANGUAGE NamedFieldPuns #-}\n" + } testDataDir :: FilePath testDataDir = "plugins" "hls-explicit-record-fields-plugin" "test" "testdata" diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/PolymorphicRecordConstruction.expected.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/PolymorphicRecordConstruction.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/PolymorphicRecordConstruction.expected.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE Haskell2010 #-} + +module PolymorphicRecordConstruction where + +data MyRec m = MyRec + { foo :: Int + , bar :: Int + , baz :: Char + } + +convertMe :: () -> MyRec () +convertMe _ = + let a = 3 + b = 5 + c = 'a' + in MyRec { foo = a, bar = b, baz = c } diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/PolymorphicRecordConstruction.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/PolymorphicRecordConstruction.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/PolymorphicRecordConstruction.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE Haskell2010 #-} + +module PolymorphicRecordConstruction where + +data MyRec m = MyRec + { foo :: Int + , bar :: Int + , baz :: Char + } + +convertMe :: () -> MyRec () +convertMe _ = + let a = 3 + b = 5 + c = 'a' + in MyRec a b c diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/PositionalConstruction.expected.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/PositionalConstruction.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/PositionalConstruction.expected.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE Haskell2010 #-} + +module PositionalConstruction where + +data MyRec = MyRec + { foo :: Int + , bar :: Int + , baz :: Char + } + +convertMe :: () -> MyRec +convertMe _ = + let a = 3 + b = 5 + c = 'a' + in MyRec { foo = a, bar = b, baz = c } diff --git a/plugins/hls-explicit-record-fields-plugin/test/testdata/PositionalConstruction.hs b/plugins/hls-explicit-record-fields-plugin/test/testdata/PositionalConstruction.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-explicit-record-fields-plugin/test/testdata/PositionalConstruction.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE Haskell2010 #-} + +module PositionalConstruction where + +data MyRec = MyRec + { foo :: Int + , bar :: Int + , baz :: Char + } + +convertMe :: () -> MyRec +convertMe _ = + let a = 3 + b = 5 + c = 'a' + in MyRec a b c diff --git a/plugins/hls-floskell-plugin/src/Ide/Plugin/Floskell.hs b/plugins/hls-floskell-plugin/src/Ide/Plugin/Floskell.hs --- a/plugins/hls-floskell-plugin/src/Ide/Plugin/Floskell.hs +++ b/plugins/hls-floskell-plugin/src/Ide/Plugin/Floskell.hs @@ -6,12 +6,13 @@ , provider ) where -import Control.Monad.Except (throwError) +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) +import Data.List (find) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import Development.IDE hiding (pluginHandlers) +import Development.IDE.Core.PluginUtils (mkFormattingHandlers) import Floskell import Ide.Plugin.Error import Ide.PluginUtils diff --git a/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs b/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs --- a/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs +++ b/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs @@ -12,42 +12,44 @@ ) where import Control.Exception -import Control.Lens ((^.)) -import Control.Monad (guard) -import Control.Monad.Error.Class (MonadError (throwError)) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Trans.Class (MonadTrans (lift)) -import Control.Monad.Trans.Except (ExceptT (..), runExceptT) -import Data.Bifunctor (bimap) -import Data.List (intercalate) -import Data.Maybe (catMaybes) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Version (showVersion) -import Development.IDE hiding (pluginHandlers) -import Development.IDE.GHC.Compat as Compat hiding (Cpp, Warning, - hang, vcat) -import qualified Development.IDE.GHC.Compat.Util as S -import GHC.LanguageExtensions.Type (Extension (Cpp)) +import Control.Lens ((^.)) +import Control.Monad (guard) +import Control.Monad.Error.Class (MonadError (throwError)) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Control.Monad.Trans.Except (ExceptT (..), runExceptT) +import Data.Bifunctor (bimap) +import Data.List (intercalate) +import Data.Maybe (catMaybes) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Version (showVersion) +import Development.IDE hiding (pluginHandlers) +import Development.IDE.Core.PluginUtils (mkFormattingHandlers) +import Development.IDE.GHC.Compat as Compat hiding (Cpp, + Warning, hang, + vcat) +import qualified Development.IDE.GHC.Compat.Util as S +import GHC.LanguageExtensions.Type (Extension (Cpp)) import Ide.Plugin.Error import Ide.Plugin.Properties -import Ide.PluginUtils (makeDiffTextEdit) +import Ide.PluginUtils (makeDiffTextEdit) import Ide.Types -import Language.LSP.Protocol.Lens (HasTabSize (tabSize)) +import Language.LSP.Protocol.Lens (HasTabSize (tabSize)) import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types -import Language.LSP.Server hiding (defaultConfig) +import Language.LSP.Server hiding (defaultConfig) import Ormolu import Ormolu.Config -import qualified Paths_fourmolu as Fourmolu +import qualified Paths_fourmolu as Fourmolu import System.Exit import System.FilePath -import System.Process.Run (cwd, proc) -import System.Process.Text (readCreateProcessWithExitCode) -import Text.Read (readMaybe) +import System.Process.Run (cwd, proc) +import System.Process.Text (readCreateProcessWithExitCode) +import Text.Read (readMaybe) #if MIN_VERSION_fourmolu(0,16,0) -import qualified Data.Yaml as Yaml +import qualified Data.Yaml as Yaml #endif descriptor :: Recorder (WithPriority LogEvent) -> PluginId -> PluginDescriptor IdeState diff --git a/plugins/hls-gadt-plugin/src/Ide/Plugin/GHC.hs b/plugins/hls-gadt-plugin/src/Ide/Plugin/GHC.hs --- a/plugins/hls-gadt-plugin/src/Ide/Plugin/GHC.hs +++ b/plugins/hls-gadt-plugin/src/Ide/Plugin/GHC.hs @@ -133,10 +133,8 @@ #endif #if MIN_VERSION_ghc(9,9,0) renderDetails (RecCon recs) = RecConGADT NoEpUniTok recs -#elif MIN_VERSION_ghc(9,3,0) - renderDetails (RecCon recs) = RecConGADT recs noHsUniTok #else - renderDetails (RecCon recs) = RecConGADT recs + renderDetails (RecCon recs) = RecConGADT recs noHsUniTok #endif @@ -206,11 +204,7 @@ adjustTyClD = \case Right (L _ (TyClD _ tycld)) -> Right $ adjustDataDecl tycld Right x -> Left $ "Expect TyClD but got " <> showAst x -#if MIN_VERSION_ghc(9,3,0) Left err -> Left $ printWithoutUniques err -#else - Left err -> Left $ show err -#endif adjustDataDecl DataDecl{..} = DataDecl { tcdDExt = adjustWhere tcdDExt diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -13,11 +13,6 @@ {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-orphans #-} --- On 9.4 we get a new redundant constraint warning, but deleting the --- constraint breaks the build on earlier versions. Rather than apply --- lots of CPP, we just disable the warning until later. -{-# OPTIONS_GHC -Wno-redundant-constraints #-} - #ifdef GHC_LIB #define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc_lib_parser(x,y,z) #else @@ -34,10 +29,8 @@ import Control.DeepSeq import Control.Exception import Control.Lens ((?~), (^.)) -import Control.Monad import Control.Monad.Error.Class (MonadError (throwError)) import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Trans.Class (MonadTrans (lift)) import Control.Monad.Trans.Except (ExceptT (..), runExceptT) import Data.Aeson.Types (FromJSON (..), @@ -50,11 +43,14 @@ import Data.Maybe import qualified Data.Text as T import qualified Data.Text.Encoding as T +import Data.Text.Utf16.Rope.Mixed (Rope) +import qualified Data.Text.Utf16.Rope.Mixed as Rope import Data.Typeable import Development.IDE hiding (Error, getExtensions) import Development.IDE.Core.Compile (sourceParser) +import Development.IDE.Core.FileStore (getVersionedTextDoc) import Development.IDE.Core.Rules (defineNoFile, getParsedModuleWithComments) import Development.IDE.Core.Shake (getDiagnostics) @@ -124,6 +120,7 @@ #endif import Development.IDE.Core.PluginUtils as PluginUtils import Text.Regex.TDFA.Text () + -- --------------------------------------------------------------------- data Log @@ -139,7 +136,7 @@ LogShake log -> pretty log LogApplying fp res -> "Applying hint(s) for" <+> viaShow fp <> ":" <+> viaShow res LogGeneratedIdeas fp ideas -> "Generated hlint ideas for for" <+> viaShow fp <> ":" <+> viaShow ideas - LogUsingExtensions fp exts -> "Using extensions for " <+> viaShow fp <> ":" <+> pretty exts + LogUsingExtensions fp exts -> "Using extensions for " <+> viaShow fp <> ":" <> line <> indent 4 (pretty exts) LogGetIdeas fp -> "Getting hlint ideas for " <+> viaShow fp LogResolve msg -> pretty msg @@ -181,19 +178,19 @@ -- This rule only exists for generating file diagnostics -- so the RuleResult is empty data GetHlintDiagnostics = GetHlintDiagnostics - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable GetHlintDiagnostics instance NFData GetHlintDiagnostics type instance RuleResult GetHlintDiagnostics = () -- | Hlint rules to generate file diagnostics based on hlint hints --- | This rule is recomputed when: --- | - A file has been edited via --- | - `getIdeas` -> `getParsedModule` in any case --- | - `getIdeas` -> `getFileContents` if the hls ghc does not match the hlint default ghc --- | - The client settings have changed, to honour the `hlintOn` setting, via `getClientConfigAction` --- | - The hlint specific settings have changed, via `getHlintSettingsRule` +-- This rule is recomputed when: +-- - A file has been edited via +-- - `getIdeas` -> `getParsedModule` in any case +-- - `getIdeas` -> `getFileContents` if the hls ghc does not match the hlint default ghc +-- - The client settings have changed, to honour the `hlintOn` setting, via `getClientConfigAction` +-- - The hlint specific settings have changed, via `getHlintSettingsRule` rules :: Recorder (WithPriority Log) -> PluginId -> Rules () rules recorder plugin = do define (cmapWithPrio LogShake recorder) $ \GetHlintDiagnostics file -> do @@ -207,16 +204,16 @@ liftIO $ argsSettings flags action $ do - files <- getFilesOfInterestUntracked - void $ uses GetHlintDiagnostics $ Map.keys files + files <- Map.keys <$> getFilesOfInterestUntracked + Shake.runWithSignal (Proxy @"kick/start/hlint") (Proxy @"kick/done/hlint") files GetHlintDiagnostics where diagnostics :: NormalizedFilePath -> Either ParseError [Idea] -> [FileDiagnostic] diagnostics file (Right ideas) = - (file, ShowDiag,) <$> catMaybes [ideaToDiagnostic i | i <- ideas] + [ideErrorFromLspDiag diag file Nothing | i <- ideas, Just diag <- [ideaToDiagnostic i]] diagnostics file (Left parseErr) = - [(file, ShowDiag, parseErrorToDiagnostic parseErr)] + [ideErrorFromLspDiag (parseErrorToDiagnostic parseErr) file Nothing] ideaToDiagnostic :: Idea -> Maybe Diagnostic @@ -305,9 +302,9 @@ then return Nothing else do flags' <- setExtensions flags - (_, contents) <- getFileContents nfp + contents <- getFileContents nfp let fp = fromNormalizedFilePath nfp - let contents' = T.unpack <$> contents + let contents' = T.unpack . Rope.toText <$> contents Just <$> liftIO (parseModuleEx flags' fp contents') setExtensions flags = do @@ -334,7 +331,7 @@ -- --------------------------------------------------------------------- data GetHlintSettings = GetHlintSettings - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable GetHlintSettings instance NFData GetHlintSettings instance NFData Hint where rnf = rwhnf @@ -366,14 +363,19 @@ | let TextDocumentIdentifier uri = documentId , Just docNormalizedFilePath <- uriToNormalizedFilePath (toNormalizedUri uri) = do - verTxtDocId <- lift $ pluginGetVersionedTextDoc documentId + verTxtDocId <- + liftIO $ + runAction "Hlint.getVersionedTextDoc" ideState $ + getVersionedTextDoc documentId liftIO $ fmap (InL . map LSP.InR) $ do allDiagnostics <- atomically $ getDiagnostics ideState let numHintsInDoc = length - [diagnostic | (diagnosticNormalizedFilePath, _, diagnostic) <- allDiagnostics - , validCommand diagnostic - , diagnosticNormalizedFilePath == docNormalizedFilePath + [lspDiagnostic + | diag <- allDiagnostics + , let lspDiagnostic = fdLspDiagnostic diag + , validCommand lspDiagnostic + , fdFilePath diag == docNormalizedFilePath ] let numHintsInContext = length [diagnostic | diagnostic <- diags @@ -445,7 +447,7 @@ , _data_ = data_ } -mkSuppressHintTextEdits :: DynFlags -> T.Text -> T.Text -> [LSP.TextEdit] +mkSuppressHintTextEdits :: DynFlags -> Rope -> T.Text -> [LSP.TextEdit] mkSuppressHintTextEdits dynFlags fileContents hint = let NextPragmaInfo{ nextPragmaLine, lineSplitTextEdits } = getNextPragmaInfo dynFlags (Just fileContents) @@ -516,7 +518,7 @@ let commands = map ideaRefactoring ideas' logWith recorder Debug $ LogGeneratedIdeas nfp commands let fp = fromNormalizedFilePath nfp - (_, mbOldContent) <- liftIO $ runAction' $ getFileContents nfp + mbOldContent <- fmap (fmap Rope.toText) $ liftIO $ runAction' $ getFileContents nfp oldContent <- maybe (liftIO $ fmap T.decodeUtf8 (BS.readFile fp)) return mbOldContent modsum <- liftIO $ runAction' $ use_ GetModSummary nfp let dflags = ms_hspp_opts $ msrModSummary modsum diff --git a/plugins/hls-hlint-plugin/test/Main.hs b/plugins/hls-hlint-plugin/test/Main.hs --- a/plugins/hls-hlint-plugin/test/Main.hs +++ b/plugins/hls-hlint-plugin/test/Main.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Main @@ -5,19 +7,21 @@ ) where import Control.Lens ((^.)) -import Control.Monad (when) +import Control.Monad (guard, when) import Data.Aeson (Value (..), object, (.=)) import Data.Functor (void) import Data.List (find) import qualified Data.Map as Map import Data.Maybe (fromJust, isJust) +import Data.Proxy (Proxy (Proxy)) import qualified Data.Text as T import Ide.Plugin.Config (Config (..)) import qualified Ide.Plugin.Config as Plugin import qualified Ide.Plugin.Hlint as HLint import qualified Language.LSP.Protocol.Lens as L -import System.FilePath (()) +import System.FilePath ((<.>), ()) import Test.Hls +import Test.Hls.FileSystem main :: IO () main = defaultTestRunner tests @@ -86,7 +90,7 @@ testGroup "hlint suggestions" [ testCase "provides 3.8 code actions including apply all" $ runHlintSession "" $ do doc <- openDoc "Base.hs" "haskell" - diags@(reduceDiag:_) <- waitForDiagnosticsFromSource doc "hlint" + diags@(reduceDiag:_) <- hlintCaptureKick liftIO $ do length diags @?= 2 -- "Eta Reduce" and "Redundant Id" @@ -124,7 +128,7 @@ , testShiftRoot = True} $ const $ do doc <- openDoc "Base.hs" "haskell" - _ <- waitForDiagnosticsFromSource doc "hlint" + _ <- hlintCaptureKick cars <- getAllCodeActions doc etaReduce <- liftIO $ inspectCommand cars ["Eta reduce"] @@ -136,7 +140,7 @@ , testCase ".hlint.yaml fixity rules are applied" $ runHlintSession "fixity" $ do doc <- openDoc "FixityUse.hs" "haskell" - expectNoMoreDiagnostics 3 doc "hlint" + testNoHlintDiagnostics doc , testCase "changing document contents updates hlint diagnostics" $ runHlintSession "" $ do doc <- openDoc "Base.hs" "haskell" @@ -150,7 +154,8 @@ } changeDoc doc [change] - expectNoMoreDiagnostics 3 doc "hlint" + -- We need to wait until hlint has been rerun and clears the diagnostic + [] <- waitForDiagnosticsFrom doc let change' = TextDocumentContentChangeEvent $ InL TextDocumentContentChangePartial @@ -166,7 +171,7 @@ testHlintDiagnostics doc , knownBrokenForHlintOnGhcLib "hlint doesn't take in account cpp flag as ghc -D argument" $ - testCase "[#554] hlint diagnostics works with CPP via language pragma" $ runHlintSession "" $ do + testCase "[#554] hlint diagnostics works with CPP via language pragma" $ runHlintSession "cpp" $ do doc <- openDoc "CppCond.hs" "haskell" testHlintDiagnostics doc @@ -186,27 +191,27 @@ testRefactor "LambdaCase.hs" "Redundant bracket" ("{-# LANGUAGE LambdaCase #-}" : expectedLambdaCase) - , expectFailBecause "apply-refact doesn't work with cpp" $ + , ignoreTestBecause "apply-refact doesn't work with cpp" $ testCase "apply hints works with CPP via -XCPP argument" $ runHlintSession "cpp" $ do testRefactor "CppCond.hs" "Redundant bracket" expectedCPP - , expectFailBecause "apply-refact doesn't work with cpp" $ + , ignoreTestBecause "apply-refact doesn't work with cpp" $ testCase "apply hints works with CPP via language pragma" $ runHlintSession "" $ do testRefactor "CppCond.hs" "Redundant bracket" ("{-# LANGUAGE CPP #-}" : expectedCPP) , testCase "hlint diagnostics ignore hints honouring .hlint.yaml" $ runHlintSession "ignore" $ do doc <- openDoc "CamelCase.hs" "haskell" - expectNoMoreDiagnostics 3 doc "hlint" + testNoHlintDiagnostics doc , testCase "hlint diagnostics ignore hints honouring ANN annotations" $ runHlintSession "" $ do doc <- openDoc "IgnoreAnn.hs" "haskell" - expectNoMoreDiagnostics 3 doc "hlint" + testNoHlintDiagnostics doc , testCase "hlint diagnostics ignore hints honouring HLINT annotations" $ runHlintSession "" $ do doc <- openDoc "IgnoreAnnHlint.hs" "haskell" - expectNoMoreDiagnostics 3 doc "hlint" + testNoHlintDiagnostics doc , testCase "apply-refact preserve regular comments" $ runHlintSession "" $ do testRefactor "Comments.hs" "Redundant bracket" expectedComments @@ -216,7 +221,7 @@ , testCase "applyAll is shown only when there is at least one diagnostic in range" $ runHlintSession "" $ do doc <- openDoc "TwoHints.hs" "haskell" - _ <- waitForDiagnosticsFromSource doc "hlint" + _ <- hlintCaptureKick firstLine <- map fromAction <$> getCodeActions doc (mkRange 0 0 0 0) secondLine <- map fromAction <$> getCodeActions doc (mkRange 1 0 1 0) @@ -231,22 +236,20 @@ liftIO $ hasApplyAll multiLine @? "Missing apply all code action" , testCase "hlint should warn about unused extensions" $ runHlintSession "unusedext" $ do - doc <- openDoc "UnusedExtension.hs" "haskell" - diags@(unusedExt:_) <- waitForDiagnosticsFromSource doc "hlint" + _ <- openDoc "UnusedExtension.hs" "haskell" + diags@(unusedExt:_) <- hlintCaptureKick liftIO $ do length diags @?= 1 unusedExt ^. L.code @?= Just (InR "refact:Unused LANGUAGE pragma") - , testCase "[#1279] hlint should not activate extensions like PatternSynonyms" $ runHlintSession "" $ do + , testCase "[#1279] hlint should not activate extensions like PatternSynonyms" $ runHlintSession "" $ do doc <- openDoc "PatternKeyword.hs" "haskell" - -- hlint will report a parse error if PatternSynonyms is enabled - expectNoMoreDiagnostics 3 doc "hlint" + testNoHlintDiagnostics doc , testCase "hlint should not warn about redundant irrefutable pattern with LANGUAGE Strict" $ runHlintSession "" $ do doc <- openDoc "StrictData.hs" "haskell" - - expectNoMoreDiagnostics 3 doc "hlint" + testNoHlintDiagnostics doc ] where testRefactor file caTitle expected = do @@ -301,9 +304,7 @@ disableHlint - diags' <- waitForDiagnosticsFrom doc - - liftIO $ noHlintDiagnostics diags' + testNoHlintDiagnostics doc , testCase "adding hlint flags to plugin configuration removes hlint diagnostics" $ runHlintSession "" $ do setIgnoringConfigurationRequests False @@ -315,9 +316,7 @@ let config' = hlintConfigWithFlags ["--ignore=Redundant id", "--hint=test-hlint-config.yaml"] setHlsConfig config' - diags' <- waitForDiagnosticsFrom doc - - liftIO $ noHlintDiagnostics diags' + testNoHlintDiagnostics doc , testCase "adding hlint flags to plugin configuration adds hlint diagnostics" $ runHlintSession "" $ do setIgnoringConfigurationRequests False @@ -325,12 +324,12 @@ doc <- openDoc "Generalise.hs" "haskell" - expectNoMoreDiagnostics 3 doc "hlint" + testNoHlintDiagnostics doc let config' = hlintConfigWithFlags ["--with-group=generalise"] setHlsConfig config' - diags' <- waitForDiagnosticsFromSource doc "hlint" + diags' <- hlintCaptureKick d <- liftIO $ inspectDiagnostic diags' ["Use <>"] liftIO $ do @@ -352,15 +351,40 @@ } . const -noHlintDiagnostics :: [Diagnostic] -> Assertion +hlintKickDone :: Session () +hlintKickDone = kick (Proxy @"kick/done/hlint") >>= guard . not . null + +hlintKickStart :: Session () +hlintKickStart = kick (Proxy @"kick/start/hlint") >>= guard . not . null + +hlintCaptureKick :: Session [Diagnostic] +hlintCaptureKick = captureKickDiagnostics hlintKickStart hlintKickDone + +noHlintDiagnostics :: HasCallStack => [Diagnostic] -> Assertion noHlintDiagnostics diags = - Just "hlint" `notElem` map (^. L.source) diags @? "There are no hlint diagnostics" + all (not . isHlintDiagnostic) diags @? "There are hlint diagnostics" -testHlintDiagnostics :: TextDocumentIdentifier -> Session () +isHlintDiagnostic :: Diagnostic -> Bool +isHlintDiagnostic diag = + Just "hlint" == diag ^. L.source + +testHlintDiagnostics :: HasCallStack => TextDocumentIdentifier -> Session () testHlintDiagnostics doc = do - diags <- waitForDiagnosticsFromSource doc "hlint" - liftIO $ length diags > 0 @? "There are hlint diagnostics" + diags <- captureKickNonEmptyDiagnostics doc + liftIO $ length diags > 0 @? "There are no hlint diagnostics" +captureKickNonEmptyDiagnostics :: HasCallStack => TextDocumentIdentifier -> Session [Diagnostic] +captureKickNonEmptyDiagnostics doc = do + diags <- hlintCaptureKick + if null diags + then captureKickNonEmptyDiagnostics doc + else pure diags + +testNoHlintDiagnostics :: HasCallStack => TextDocumentIdentifier -> Session () +testNoHlintDiagnostics _doc = do + diags <- hlintCaptureKick + liftIO $ noHlintDiagnostics diags + hlintConfigWithFlags :: [T.Text] -> Config hlintConfigWithFlags flags = def @@ -385,7 +409,7 @@ -- Although a given hlint version supports one direct ghc, we could use several versions of hlint -- each one supporting a different ghc version. It should be a temporary situation though. knownBrokenForHlintOnGhcLib :: String -> TestTree -> TestTree -knownBrokenForHlintOnGhcLib = expectFailBecause +knownBrokenForHlintOnGhcLib = ignoreTestBecause -- 1's based data Point = Point { @@ -408,6 +432,10 @@ makeCodeActionNotFoundAtString Point {..} = "CodeAction not found at line: " <> show line <> ", column: " <> show column +-- ------------------------------------------------------------------------ +-- Test runner helpers +-- ------------------------------------------------------------------------ + ignoreHintGoldenTest :: TestName -> FilePath -> Point -> T.Text -> TestTree ignoreHintGoldenTest testCaseName goldenFilename point hintName = goldenTest testCaseName goldenFilename point (getIgnoreHintText hintName) @@ -418,8 +446,8 @@ goldenTest :: TestName -> FilePath -> Point -> T.Text -> TestTree goldenTest testCaseName goldenFilename point hintText = - setupGoldenHlintTest testCaseName goldenFilename $ \document -> do - _ <- waitForDiagnosticsFromSource document "hlint" + setupGoldenHlintTest testCaseName goldenFilename codeActionNoResolveCaps $ \document -> do + _ <- hlintCaptureKick actions <- getCodeActions document $ pointToRange point case find ((== Just hintText) . getCodeActionTitle) actions of Just (InR codeAction) -> do @@ -429,16 +457,15 @@ _ -> liftIO $ assertFailure $ makeCodeActionNotFoundAtString point -setupGoldenHlintTest :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree -setupGoldenHlintTest testName path = +setupGoldenHlintTest :: TestName -> FilePath -> ClientCapabilities -> (TextDocumentIdentifier -> Session ()) -> TestTree +setupGoldenHlintTest testName path config = goldenWithTestConfig def - { testConfigCaps = codeActionNoResolveCaps + { testConfigCaps = config , testShiftRoot = True , testPluginDescriptor = hlintPlugin - , testDirLocation = Left testDir - } - testName testDir path "expected" "hs" - + , testDirLocation = Right tree + } testName tree path "expected" "hs" + where tree = mkVirtualFileTree testDir (directProject (path <.> "hs")) ignoreHintGoldenResolveTest :: TestName -> FilePath -> Point -> T.Text -> TestTree ignoreHintGoldenResolveTest testCaseName goldenFilename point hintName = @@ -450,19 +477,9 @@ goldenResolveTest :: TestName -> FilePath -> Point -> T.Text -> TestTree goldenResolveTest testCaseName goldenFilename point hintText = - setupGoldenHlintResolveTest testCaseName goldenFilename $ \document -> do - _ <- waitForDiagnosticsFromSource document "hlint" + setupGoldenHlintTest testCaseName goldenFilename codeActionResolveCaps $ \document -> do + _ <- hlintCaptureKick actions <- getAndResolveCodeActions document $ pointToRange point case find ((== Just hintText) . getCodeActionTitle) actions of Just (InR codeAction) -> executeCodeAction codeAction _ -> liftIO $ assertFailure $ makeCodeActionNotFoundAtString point - -setupGoldenHlintResolveTest :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree -setupGoldenHlintResolveTest testName path = - goldenWithTestConfig def - { testConfigCaps = codeActionResolveCaps - , testShiftRoot = True - , testPluginDescriptor = hlintPlugin - , testDirLocation = Left testDir - } - testName testDir path "expected" "hs" diff --git a/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs b/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs --- a/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs +++ b/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs @@ -4,8 +4,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -Wwarn -fno-warn-type-defaults #-} - {- | Keep the module name in sync with its file path. Provide CodeLenses to: @@ -32,17 +30,18 @@ import Data.Ord (comparing) import Data.String (IsString) import qualified Data.Text as T +import qualified Data.Text.Utf16.Rope.Mixed as Rope import Development.IDE (GetParsedModule (GetParsedModule), GhcSession (GhcSession), IdeState, Pretty, Priority (Debug), Recorder, WithPriority, colon, evalGhcEnv, - hscEnvWithImportPaths, - logWith, + hscEnv, logWith, realSrcSpanToRange, rootDir, runAction, useWithStale, (<+>)) +import Development.IDE.Core.FileStore (getFileContents) import Development.IDE.Core.PluginUtils import Development.IDE.Core.PositionMapping (toCurrentRange) import Development.IDE.GHC.Compat (GenLocated (L), @@ -57,7 +56,6 @@ import Ide.Types import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types -import Language.LSP.VFS (virtualFileText) import System.FilePath (dropExtension, normalise, pathSeparator, splitDirectories, @@ -112,8 +110,8 @@ nfp <- getNormalizedFilePathE uri fp <- uriToFilePathE uri - contents <- lift . pluginGetVirtualFile $ toNormalizedUri uri - let emptyModule = maybe True (T.null . T.strip . virtualFileText) contents + contents <- liftIO $ runAction "ModuleName.getFileContents" state $ getFileContents nfp + let emptyModule = maybe True (T.null . T.strip . Rope.toText) contents correctNames <- mapExceptT liftIO $ pathModuleNames recorder state nfp fp logWith recorder Debug (CorrectNames correctNames) @@ -140,7 +138,7 @@ | firstLetter isLower $ takeFileName filePath = return ["Main"] | otherwise = do (session, _) <- runActionE "ModuleName.ghcSession" state $ useWithStaleE GhcSession normFilePath - srcPaths <- liftIO $ evalGhcEnv (hscEnvWithImportPaths session) $ importPaths <$> getSessionDynFlags + srcPaths <- liftIO $ evalGhcEnv (hscEnv session) $ importPaths <$> getSessionDynFlags logWith recorder Debug (SrcPaths srcPaths) -- Append a `pathSeparator` to make the path looks like a directory, diff --git a/plugins/hls-notes-plugin/src/Ide/Plugin/Notes.hs b/plugins/hls-notes-plugin/src/Ide/Plugin/Notes.hs --- a/plugins/hls-notes-plugin/src/Ide/Plugin/Notes.hs +++ b/plugins/hls-notes-plugin/src/Ide/Plugin/Notes.hs @@ -3,7 +3,6 @@ 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 @@ -25,7 +24,6 @@ import Language.LSP.Protocol.Message (Method (Method_TextDocumentDefinition), SMethod (SMethod_TextDocumentDefinition)) import Language.LSP.Protocol.Types -import Language.LSP.VFS (VirtualFile (..)) import Text.Regex.TDFA (Regex, caseSensitive, defaultCompOpt, defaultExecOpt, @@ -79,8 +77,9 @@ | Just nfp <- uriToNormalizedFilePath uriOrig = do let Position l c = param ^. L.position - contents <- fmap _file_text . err "Error getting file contents" - =<< lift (pluginGetVirtualFile uriOrig) + contents <- + err "Error getting file contents" + =<< liftIO (runAction "notes.getfileContents" state (getFileContents nfp)) 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 @@ -110,7 +109,7 @@ -- the user. If not, we need to read it from disk. contentOpt <- (snd =<<) <$> use GetFileContents file content <- case contentOpt of - Just x -> pure x + Just x -> pure $ Rope.toText x Nothing -> liftIO $ readFileUtf8 $ fromNormalizedFilePath file let matches = (A.! 1) <$> matchAllText noteRegex content m = toPositions matches content diff --git a/plugins/hls-ormolu-plugin/src/Ide/Plugin/Ormolu.hs b/plugins/hls-ormolu-plugin/src/Ide/Plugin/Ormolu.hs --- a/plugins/hls-ormolu-plugin/src/Ide/Plugin/Ormolu.hs +++ b/plugins/hls-ormolu-plugin/src/Ide/Plugin/Ormolu.hs @@ -10,36 +10,37 @@ ) where -import Control.Exception (Handler (..), IOException, - SomeException (..), catches, - handle) -import Control.Monad.Except (runExceptT, throwError) +import Control.Exception (Handler (..), IOException, + SomeException (..), catches, + handle) +import Control.Monad.Except (runExceptT, throwError) import Control.Monad.Extra import Control.Monad.Trans -import Control.Monad.Trans.Except (ExceptT (..), mapExceptT) -import Data.Functor ((<&>)) -import Data.List (intercalate) -import Data.Maybe (catMaybes) -import Data.Text (Text) -import qualified Data.Text as T -import Development.IDE hiding (pluginHandlers) -import Development.IDE.GHC.Compat (hsc_dflags, moduleNameString) -import qualified Development.IDE.GHC.Compat as D -import qualified Development.IDE.GHC.Compat.Util as S +import Control.Monad.Trans.Except (ExceptT (..), mapExceptT) +import Data.Functor ((<&>)) +import Data.List (intercalate) +import Data.Maybe (catMaybes) +import Data.Text (Text) +import qualified Data.Text as T +import Development.IDE hiding (pluginHandlers) +import Development.IDE.Core.PluginUtils (mkFormattingHandlers) +import Development.IDE.GHC.Compat (hsc_dflags, moduleNameString) +import qualified Development.IDE.GHC.Compat as D +import qualified Development.IDE.GHC.Compat.Util as S import GHC.LanguageExtensions.Type -import Ide.Plugin.Error (PluginError (PluginInternalError)) +import Ide.Plugin.Error (PluginError (PluginInternalError)) import Ide.Plugin.Properties import Ide.PluginUtils -import Ide.Types hiding (Config) -import qualified Ide.Types as Types +import Ide.Types hiding (Config) +import qualified Ide.Types as Types import Language.LSP.Protocol.Types -import Language.LSP.Server hiding (defaultConfig) +import Language.LSP.Server hiding (defaultConfig) import Ormolu import System.Exit import System.FilePath -import System.Process.Run (cwd, proc) -import System.Process.Text (readCreateProcessWithExitCode) -import Text.Read (readMaybe) +import System.Process.Run (cwd, proc) +import System.Process.Text (readCreateProcessWithExitCode) +import Text.Read (readMaybe) -- --------------------------------------------------------------------- diff --git a/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs b/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs --- a/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs +++ b/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs @@ -289,27 +289,25 @@ #else getRecSels (unLoc -> XExpr (HsExpanded a _)) = (collectRecordSelectors a, True) #endif -#if __GLASGOW_HASKELL__ >= 903 -- applied record selection: "selector record" or "selector (record)" or -- "selector selector2.record2" +#if __GLASGOW_HASKELL__ >= 911 +getRecSels e@(unLoc -> HsApp _ se@(unLoc -> XExpr (HsRecSelRn _)) re) = +#else getRecSels e@(unLoc -> HsApp _ se@(unLoc -> HsRecSel _ _) re) = +#endif ( [ RecordSelectorExpr (realSrcSpanToRange realSpan') se re | RealSrcSpan realSpan' _ <- [ getLoc e ] ], False ) -- Record selection where the field is being applied with the "$" operator: -- "selector $ record" -getRecSels e@(unLoc -> OpApp _ se@(unLoc -> HsRecSel _ _) - (unLoc -> HsVar _ (unLoc -> d)) re) | d == dollarName = - ( [ RecordSelectorExpr (realSrcSpanToRange realSpan') se re - | RealSrcSpan realSpan' _ <- [ getLoc e ] ], False ) +#if __GLASGOW_HASKELL__ >= 911 +getRecSels e@(unLoc -> OpApp _ se@(unLoc -> XExpr (HsRecSelRn _)) #else -getRecSels e@(unLoc -> HsApp _ se@(unLoc -> HsRecFld _ _) re) = - ( [ RecordSelectorExpr (realSrcSpanToRange realSpan') se re - | RealSrcSpan realSpan' _ <- [ getLoc e ] ], False ) -getRecSels e@(unLoc -> OpApp _ se@(unLoc -> HsRecFld _ _) +getRecSels e@(unLoc -> OpApp _ se@(unLoc -> HsRecSel _ _) +#endif (unLoc -> HsVar _ (unLoc -> d)) re) | d == dollarName = ( [ RecordSelectorExpr (realSrcSpanToRange realSpan') se re | RealSrcSpan realSpan' _ <- [ getLoc e ] ], False ) -#endif getRecSels _ = ([], False) collectRecSelResult :: MonadIO m => IdeState -> NormalizedFilePath diff --git a/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs b/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs --- a/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs +++ b/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs @@ -17,8 +17,9 @@ import Control.Lens hiding (List) import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Trans.Class (lift) +import qualified Data.Aeson as JSON import Data.Char (isAlphaNum) +import qualified Data.Foldable as Foldable import Data.List.Extra (nubOrdOn) import qualified Data.Map as M import Data.Maybe (mapMaybe) @@ -29,7 +30,7 @@ import Development.IDE.Core.PluginUtils import Development.IDE.GHC.Compat import Development.IDE.Plugin.Completions (ghcideCompletionsPluginPriority) -import Development.IDE.Plugin.Completions.Logic (getCompletionPrefix) +import Development.IDE.Plugin.Completions.Logic (getCompletionPrefixFromRope) import Development.IDE.Plugin.Completions.Types (PosPrefixInfo (..)) import qualified Development.IDE.Spans.Pragmas as Pragmas import Ide.Plugin.Error @@ -80,7 +81,7 @@ -- ghc session to get some dynflags even if module isn't parsed (hscEnv -> hsc_dflags -> sessionDynFlags, _) <- runActionE "Pragmas.GhcSession" state $ useWithStaleE GhcSession normalizedFilePath - (_, fileContents) <- liftIO $ runAction "Pragmas.GetFileContents" state $ getFileContents normalizedFilePath + fileContents <- liftIO $ runAction "Pragmas.GetFileContents" state $ getFileContents normalizedFilePath parsedModule <- liftIO $ runAction "Pragmas.GetParsedModule" state $ getParsedModule normalizedFilePath let parsedModuleDynFlags = ms_hspp_opts . pm_mod_summary <$> parsedModule nextPragmaInfo = Pragmas.getNextPragmaInfo sessionDynFlags fileContents @@ -121,15 +122,23 @@ -- --------------------------------------------------------------------- suggestDisableWarning :: Diagnostic -> [PragmaEdit] -suggestDisableWarning Diagnostic {_code} - | Just (LSP.InR (T.stripPrefix "-W" -> Just w)) <- _code - , w `notElem` warningBlacklist = - pure ("Disable \"" <> w <> "\" warnings", OptGHC w) +suggestDisableWarning diagnostic + | Just (Just (JSON.Array attachedReasons)) <- diagnostic ^? attachedReason + = + [ ("Disable \"" <> w <> "\" warnings", OptGHC w) + | JSON.String attachedReason <- Foldable.toList attachedReasons + , Just w <- [T.stripPrefix "-W" attachedReason] + , w `notElem` warningBlacklist + ] | otherwise = [] --- Don't suggest disabling type errors as a solution to all type errors warningBlacklist :: [T.Text] -warningBlacklist = ["deferred-type-errors"] +warningBlacklist = + -- Don't suggest disabling type errors as a solution to all type errors. + [ "deferred-type-errors" + -- Don't suggest disabling out of scope errors as a solution to all out of scope errors. + , "deferred-out-of-scope-variables" + ] -- --------------------------------------------------------------------- @@ -195,13 +204,13 @@ flags = map T.pack $ flagsForCompletion False completion :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCompletion -completion _ide _ complParams = do +completion ide _ complParams = do let (LSP.TextDocumentIdentifier uri) = complParams ^. L.textDocument position@(Position ln col) = complParams ^. L.position - contents <- lift $ pluginGetVirtualFile $ toNormalizedUri uri + contents <- liftIO $ runAction "Pragmas.GetUriContents" ide $ getUriContents $ toNormalizedUri uri fmap LSP.InL $ case (contents, uriToFilePath' uri) of (Just cnts, Just _path) -> - pure $ result $ getCompletionPrefix position cnts + pure $ result $ getCompletionPrefixFromRope position cnts where result pfix | "{-# language" `T.isPrefixOf` line diff --git a/plugins/hls-pragmas-plugin/test/Main.hs b/plugins/hls-pragmas-plugin/test/Main.hs --- a/plugins/hls-pragmas-plugin/test/Main.hs +++ b/plugins/hls-pragmas-plugin/test/Main.hs @@ -73,10 +73,10 @@ , codeActionTestWithPragmasSuggest "adds TypeApplications pragma" "TypeApplications" [("Add \"TypeApplications\"", "Contains TypeApplications code action")] , codeActionTestWithPragmasSuggest "after shebang" "AfterShebang" [("Add \"NamedFieldPuns\"", "Contains NamedFieldPuns code action")] , codeActionTestWithPragmasSuggest "append to existing pragmas" "AppendToExisting" [("Add \"NamedFieldPuns\"", "Contains NamedFieldPuns code action")] - , codeActionTestWithPragmasSuggest "before doc comments" "BeforeDocComment" [("Add \"NamedFieldPuns\"", "Contains NamedFieldPuns code action")] + , codeActionTestWithPragmasSuggest "before doc comments NamedFieldPuns" "BeforeDocComment" [("Add \"NamedFieldPuns\"", "Contains NamedFieldPuns code action")] , codeActionTestWithPragmasSuggest "adds TypeSynonymInstances pragma" "NeedsPragmas" [("Add \"TypeSynonymInstances\"", "Contains TypeSynonymInstances code action"), ("Add \"FlexibleInstances\"", "Contains FlexibleInstances code action")] - , codeActionTestWithDisableWarning "before doc comments" "MissingSignatures" [("Disable \"missing-signatures\" warnings", "Contains missing-signatures code action")] - , codeActionTestWithDisableWarning "before doc comments" "UnusedImports" [("Disable \"unused-imports\" warnings", "Contains unused-imports code action")] + , codeActionTestWithDisableWarning "before doc comments missing-signatures" "MissingSignatures" [("Disable \"missing-signatures\" warnings", "Contains missing-signatures code action")] + , codeActionTestWithDisableWarning "before doc comments unused-imports" "UnusedImports" [("Disable \"unused-imports\" warnings", "Contains unused-imports code action")] ] codeActionTestWithPragmasSuggest :: String -> FilePath -> [(T.Text, String)] -> TestTree @@ -109,10 +109,15 @@ _ -> assertFailure $ "Expected one code action, but got: " <> show cas liftIO $ (ca ^. L.title == "Add \"NamedFieldPuns\"") @? "NamedFieldPuns code action" executeCodeAction ca - , goldenWithPragmas pragmasSuggestPlugin "doesn't suggest disabling type errors" "DeferredTypeErrors" $ \doc -> do + , goldenWithPragmas pragmasDisableWarningPlugin "doesn't suggest disabling type errors" "DeferredTypeErrors" $ \doc -> do _ <- waitForDiagnosticsFrom doc cas <- map fromAction <$> getAllCodeActions doc liftIO $ "Disable \"deferred-type-errors\" warnings" `notElem` map (^. L.title) cas @? "Doesn't contain deferred-type-errors code action" + liftIO $ length cas == 0 @? "Expected no code actions, but got: " <> show cas + , goldenWithPragmas pragmasDisableWarningPlugin "doesn't suggest disabling out of scope variables" "DeferredOutOfScopeVariables" $ \doc -> do + _ <- waitForDiagnosticsFrom doc + cas <- map fromAction <$> getAllCodeActions doc + liftIO $ "Disable \"deferred-out-of-scope-variables\" warnings" `notElem` map (^. L.title) cas @? "Doesn't contain deferred-out-of-scope-variables code action" liftIO $ length cas == 0 @? "Expected no code actions, but got: " <> show cas ] diff --git a/plugins/hls-pragmas-plugin/test/testdata/DeferredOutOfScopeVariables.expected.hs b/plugins/hls-pragmas-plugin/test/testdata/DeferredOutOfScopeVariables.expected.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/DeferredOutOfScopeVariables.expected.hs @@ -0,0 +1,5 @@ +module DeferredOutOfScopeVariables where + +f :: () +f = let x = Doesn'tExist + in undefined diff --git a/plugins/hls-pragmas-plugin/test/testdata/DeferredOutOfScopeVariables.hs b/plugins/hls-pragmas-plugin/test/testdata/DeferredOutOfScopeVariables.hs new file mode 100644 --- /dev/null +++ b/plugins/hls-pragmas-plugin/test/testdata/DeferredOutOfScopeVariables.hs @@ -0,0 +1,5 @@ +module DeferredOutOfScopeVariables where + +f :: () +f = let x = Doesn'tExist + in undefined diff --git a/plugins/hls-qualify-imported-names-plugin/src/Ide/Plugin/QualifyImportedNames.hs b/plugins/hls-qualify-imported-names-plugin/src/Ide/Plugin/QualifyImportedNames.hs --- a/plugins/hls-qualify-imported-names-plugin/src/Ide/Plugin/QualifyImportedNames.hs +++ b/plugins/hls-qualify-imported-names-plugin/src/Ide/Plugin/QualifyImportedNames.hs @@ -21,6 +21,9 @@ import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as Text +import qualified Data.Text.Lines as Text.Lines +import Data.Text.Utf16.Rope.Mixed (Rope) +import qualified Data.Text.Utf16.Rope.Mixed as Rope import Development.IDE (spanContainsRange) import Development.IDE.Core.PluginUtils import Development.IDE.Core.RuleTypes (GetFileContents (GetFileContents), @@ -178,10 +181,12 @@ | row == lineOffset = colOffset | otherwise = 0 -usedIdentifiersToTextEdits :: Range -> NameEnv [ImportedBy] -> Text -> [UsedIdentifier] -> [TextEdit] -usedIdentifiersToTextEdits range nameToImportedByMap sourceText usedIdentifiers +usedIdentifiersToTextEdits :: Range -> NameEnv [ImportedBy] -> Rope -> [UsedIdentifier] -> [TextEdit] +usedIdentifiersToTextEdits range nameToImportedByMap source usedIdentifiers | let sortedUsedIdentifiers = sortOn usedIdentifierSpan usedIdentifiers = - State.evalState (makeStateComputation sortedUsedIdentifiers) (Text.lines sourceText, 0, 0) + State.evalState + (makeStateComputation sortedUsedIdentifiers) + (Text.Lines.lines (Rope.toTextLines source), 0, 0) where folder :: [TextEdit] -> UsedIdentifier -> State ([Text], Int, Int) [TextEdit] folder prevTextEdits UsedIdentifier{usedIdentifierName, usedIdentifierSpan} @@ -227,12 +232,12 @@ if isJust (findLImportDeclAt range tmrParsed) then do HAR {..} <- runActionE "QualifyImportedNames.GetHieAst" ideState (useE GetHieAst normalizedFilePath) - (_, sourceTextM) <- runActionE "QualifyImportedNames.GetFileContents" ideState (useE GetFileContents normalizedFilePath) - sourceText <- handleMaybe (PluginRuleFailed "GetFileContents") sourceTextM + (_, sourceM) <- runActionE "QualifyImportedNames.GetFileContents" ideState (useE GetFileContents normalizedFilePath) + source <- handleMaybe (PluginRuleFailed "GetFileContents") sourceM let globalRdrEnv = tcg_rdr_env tmrTypechecked nameToImportedByMap = globalRdrEnvToNameToImportedByMap globalRdrEnv usedIdentifiers = refMapToUsedIdentifiers refMap - textEdits = usedIdentifiersToTextEdits range nameToImportedByMap sourceText usedIdentifiers + textEdits = usedIdentifiersToTextEdits range nameToImportedByMap source usedIdentifiers pure $ InL (makeCodeActions (documentId ^. L.uri) textEdits) else pure $ InL [] diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Compat/ExactPrint.hs b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Compat/ExactPrint.hs --- a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Compat/ExactPrint.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Compat/ExactPrint.hs @@ -7,7 +7,7 @@ , transformA ) where -import Language.Haskell.GHC.ExactPrint as ExactPrint +import Language.Haskell.GHC.ExactPrint as ExactPrint printA :: (ExactPrint ast) => ast -> String printA ast = exactPrint ast @@ -16,4 +16,4 @@ :: Monad m => ast1 -> (ast1 -> TransformT m ast2) -> m ast2 transformA ast f = do (ast',_ ,_) <- runTransformFromT 0 (f ast) - return $ ast' + return ast' diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs --- a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs @@ -32,9 +32,6 @@ li = tag "li" caret x = tag' [("class", text "caret")] "span" "" <+> x nested foo cts -#if !MIN_VERSION_ghc(9,3,0) - | cts == empty = foo -#endif | otherwise = foo $$ (caret $ ul cts) body cts = tag "body" $ cts $$ tag "script" (text js) header = tag "head" $ tag "style" $ text css @@ -45,9 +42,13 @@ generic `ext1Q` list `extQ` string `extQ` fastString `extQ` srcSpan `extQ` realSrcSpan +#if !MIN_VERSION_ghc(9,11,0) `extQ` annotation +#endif `extQ` annotationModule +#if !MIN_VERSION_ghc(9,11,0) `extQ` annotationAddEpAnn +#endif `extQ` annotationGrhsAnn `extQ` annotationEpAnnHsCase `extQ` annotationEpAnnHsLet @@ -56,7 +57,9 @@ `extQ` annotationAnnParen `extQ` annotationTrailingAnn `extQ` annotationEpaLocation +#if !MIN_VERSION_ghc(9,11,0) `extQ` addEpAnn +#endif `extQ` lit `extQ` litr `extQ` litt `extQ` sourceText `extQ` deltaPos @@ -138,7 +141,11 @@ #else epaAnchor (EpaSpan r) = text "EpaSpan" <+> realSrcSpan r #endif +#if MIN_VERSION_ghc(9,11,0) + epaAnchor (EpaDelta s d cs) = text "EpaDelta" <+> srcSpan s <+> deltaPos d <+> showAstDataHtml' cs +#else epaAnchor (EpaDelta d cs) = text "EpaDelta" <+> deltaPos d <+> showAstDataHtml' cs +#endif #if !MIN_VERSION_ghc(9,9,0) anchorOp :: AnchorOperation -> SDoc @@ -172,8 +179,10 @@ -- TODO: show annotations here (text "") +#if !MIN_VERSION_ghc(9,11,0) addEpAnn :: AddEpAnn -> SDoc addEpAnn (AddEpAnn a s) = text "AddEpAnn" <+> ppr a <+> epaAnchor s +#endif var :: Var -> SDoc var v = braces $ text "Var:" <+> ppr v @@ -211,14 +220,18 @@ -- ------------------------- +#if !MIN_VERSION_ghc(9,11,0) annotation :: EpAnn [AddEpAnn] -> SDoc annotation = annotation' (text "EpAnn [AddEpAnn]") +#endif annotationModule :: EpAnn AnnsModule -> SDoc annotationModule = annotation' (text "EpAnn AnnsModule") +#if !MIN_VERSION_ghc(9,11,0) annotationAddEpAnn :: EpAnn AddEpAnn -> SDoc annotationAddEpAnn = annotation' (text "EpAnn AddEpAnn") +#endif annotationGrhsAnn :: EpAnn GrhsAnn -> SDoc annotationGrhsAnn = annotation' (text "EpAnn GrhsAnn") @@ -234,7 +247,11 @@ annotationEpAnnHsLet = annotation' (text "EpAnn AnnsLet") #endif +#if MIN_VERSION_ghc(9,11,0) + annotationAnnList :: EpAnn (AnnList ()) -> SDoc +#else annotationAnnList :: EpAnn AnnList -> SDoc +#endif annotationAnnList = annotation' (text "EpAnn AnnList") annotationEpAnnImportDecl :: EpAnn EpAnnImportDecl -> SDoc @@ -259,7 +276,11 @@ srcSpanAnnA :: EpAnn AnnListItem -> SDoc srcSpanAnnA = locatedAnn'' (text "SrcSpanAnnA") +#if MIN_VERSION_ghc(9,11,0) + srcSpanAnnL :: EpAnn (AnnList ()) -> SDoc +#else srcSpanAnnL :: EpAnn AnnList -> SDoc +#endif srcSpanAnnL = locatedAnn'' (text "SrcSpanAnnL") srcSpanAnnP :: EpAnn AnnPragma -> SDoc diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs --- a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs @@ -90,7 +90,7 @@ #if !MIN_VERSION_ghc(9,9,0) import Data.Default (Default) -import GHC (Anchor (..), +import GHC ( Anchor (..), AnchorOperation, EpAnn (..), NameAdornment (NameParens), @@ -108,7 +108,10 @@ #endif #if MIN_VERSION_ghc(9,9,0) -import GHC (Anchor, +import GHC ( +#if !MIN_VERSION_ghc(9,11,0) + Anchor, +#endif AnnContext (..), EpAnn (..), EpaLocation, @@ -137,7 +140,7 @@ LogShake shakeLog -> pretty shakeLog data GetAnnotatedParsedSource = GetAnnotatedParsedSource - deriving (Eq, Show, Typeable, GHC.Generic) + deriving (Eq, Show, GHC.Generic) instance Hashable GetAnnotatedParsedSource instance NFData GetAnnotatedParsedSource @@ -158,7 +161,7 @@ return ([], fmap annotateParsedSource pm) annotateParsedSource :: ParsedModule -> ParsedSource -annotateParsedSource (ParsedModule _ ps _ _) = +annotateParsedSource (ParsedModule _ ps _) = #if MIN_VERSION_ghc(9,9,0) ps #else @@ -578,9 +581,17 @@ => ([LHsDecl GhcPs] -> m ([LHsDecl GhcPs], r)) -> t -> m (t, r) modifyDeclsT' action t = do +#if MIN_VERSION_ghc_exactprint(1,10,0) + decls <- pure $ hsDecls t +#else decls <- liftT $ hsDecls t +#endif (decls', r) <- action decls +#if MIN_VERSION_ghc_exactprint(1,10,0) + t' <- pure $ replaceDecls t decls' +#else t' <- liftT $ replaceDecls t decls' +#endif pure (t', r) -- | Modify each LMatch in a MatchGroup diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -23,7 +23,6 @@ import Control.Concurrent.STM.Stats (atomically) import Control.Monad.Extra import Control.Monad.IO.Class -import Control.Monad.Trans import Control.Monad.Trans.Except (ExceptT (ExceptT)) import Control.Monad.Trans.Maybe import Data.Char @@ -41,13 +40,14 @@ import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Encoding as T +import qualified Data.Text.Utf16.Rope.Mixed as Rope +import Development.IDE.Core.FileStore (getUriContents) import Development.IDE.Core.Rules import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service import Development.IDE.Core.Shake hiding (Log) import Development.IDE.GHC.Compat hiding (ImplicitPrelude) -import Development.IDE.GHC.Compat.ExactPrint import Development.IDE.GHC.Compat.Util import Development.IDE.GHC.Error import Development.IDE.GHC.ExactPrint @@ -65,6 +65,7 @@ import Development.IDE.Plugin.Plugins.FillTypeWildcard (suggestFillTypeWildcard) import Development.IDE.Plugin.Plugins.ImportUtils import Development.IDE.Plugin.TypeLenses (suggestSignature) +import Development.IDE.Types.Diagnostics import Development.IDE.Types.Exports import Development.IDE.Types.Location import Development.IDE.Types.Options @@ -87,7 +88,6 @@ CodeActionKind (CodeActionKind_QuickFix), CodeActionParams (CodeActionParams), Command, - Diagnostic (..), MessageType (..), Null (Null), ShowMessageParams (..), @@ -97,7 +97,6 @@ WorkspaceEdit (WorkspaceEdit, _changeAnnotations, _changes, _documentChanges), type (|?) (InL, InR), uriToFilePath) -import Language.LSP.VFS (virtualFileText) import qualified Text.Fuzzy.Parallel as TFP import qualified Text.Regex.Applicative as RE import Text.Regex.TDFA ((=~), (=~~)) @@ -105,6 +104,7 @@ -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] #if !MIN_VERSION_ghc(9,9,0) +import Development.IDE.GHC.Compat.ExactPrint (makeDeltaAst) import GHC (Anchor (anchor_op), AnchorOperation (..), EpaLocation (..)) @@ -122,15 +122,15 @@ -- | Generate code actions. codeAction :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction codeAction state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) range _) = do - contents <- lift $ pluginGetVirtualFile $ toNormalizedUri uri + contents <- liftIO $ runAction "hls-refactor-plugin.codeAction.getUriContents" state $ getUriContents $ toNormalizedUri uri liftIO $ do - let text = virtualFileText <$> contents - mbFile = toNormalizedFilePath' <$> uriToFilePath uri - allDiags <- atomically $ fmap (\(_, _, d) -> d) . filter (\(p, _, _) -> mbFile == Just p) <$> getDiagnostics state + let mbFile = toNormalizedFilePath' <$> uriToFilePath uri + allDiags <- atomically $ fmap fdLspDiagnostic . filter (\d -> mbFile == Just (fdFilePath d)) <$> getDiagnostics state (join -> parsedModule) <- runAction "GhcideCodeActions.getParsedModule" state $ getParsedModule `traverse` mbFile let - actions = caRemoveRedundantImports parsedModule text allDiags range uri - <> caRemoveInvalidExports parsedModule text allDiags range uri + textContents = fmap Rope.toText contents + actions = caRemoveRedundantImports parsedModule textContents allDiags range uri + <> caRemoveInvalidExports parsedModule textContents allDiags range uri pure $ InL actions ------------------------------------------------------------------------------------------------- @@ -249,7 +249,7 @@ it = case thingParent of Nothing -> newThing Just p -> p <> "(" <> newThing <> ")" - t <- liftMaybe $ snd <$> newImportToEdit n ps (fromMaybe "" contents) + t <- liftMaybe $ snd <$> newImportToEdit n ps (Rope.toText (fromMaybe mempty contents)) return (nfp, WorkspaceEdit {_changes=Just (M.singleton doc [t]), _documentChanges=Nothing, _changeAnnotations=Nothing}) | otherwise = mzero @@ -312,11 +312,7 @@ msum [findSigOfBinds range (grhssLocalBinds grhs) -- where clause , do -#if MIN_VERSION_ghc(9,3,0) grhs <- findDeclContainingLoc (_start range) (grhssGRHSs grhs) -#else - grhs <- findDeclContainingLoc (_start range) (map reLocA $ grhssGRHSs grhs) -#endif case unLoc grhs of GRHS _ _ bd -> findSigOfExpr (unLoc bd) ] @@ -324,7 +320,7 @@ findSigOfExpr :: HsExpr p -> Maybe (Sig p) findSigOfExpr = go where -#if MIN_VERSION_ghc(9,3,0) && !MIN_VERSION_ghc(9,9,0) +#if !MIN_VERSION_ghc(9,9,0) go (HsLet _ _ binds _ _) = findSigOfBinds range binds #else go (HsLet _ binds _) = findSigOfBinds range binds @@ -567,7 +563,7 @@ suggestRemoveRedundantExport ParsedModule{pm_parsed_source = L _ HsModule{..}} Diagnostic{..} | msg <- unifySpaces _message , Just export <- hsmodExports - , Just exportRange <- getLocatedRange $ export + , Just exportRange <- getLocatedRange export , exports <- unLoc export , Just (removeFromExport, !ranges) <- fmap (getRanges exports . notInScope) (extractNotInScopeName msg) <|> (,[_range]) <$> matchExportItem msg @@ -773,7 +769,7 @@ printExport :: ExportsAs -> T.Text -> T.Text printExport ExportName x = parenthesizeIfNeeds False x - printExport ExportPattern x = "pattern " <> x + printExport ExportPattern x = "pattern " <> parenthesizeIfNeeds False x printExport ExportFamily x = parenthesizeIfNeeds True x printExport ExportAll x = parenthesizeIfNeeds True x <> "(..)" @@ -951,7 +947,7 @@ | "Could not find module" `T.isInfixOf` _message = case T.splitOn "Perhaps you meant" _message of [_, stuff] -> - [ ("replace with " <> modul, TextEdit _range modul) + [ ("Replace with " <> modul, TextEdit _range modul) | modul <- mapMaybe extractModule (T.lines stuff) ] _ -> [] @@ -1629,7 +1625,7 @@ -- which would lead to an unlawful Ord instance. simpleCompareImportSuggestion :: ImportSuggestion -> ImportSuggestion -> Ordering simpleCompareImportSuggestion (ImportSuggestion s1 _ i1) (ImportSuggestion s2 _ i2) - = flip compare s1 s2 <> compare i1 i2 + = compare s2 s1 <> compare i1 i2 newtype NewImport = NewImport {unNewImport :: T.Text} deriving (Show, Eq, Ord) @@ -1995,11 +1991,19 @@ where unqualify = snd . breakOnEnd "." b' = wrapOperatorInParens $ unqualify b + ranges' + ( L + _ + ( IEThingWith + _ + thing + _ + inners #if MIN_VERSION_ghc(9,9,0) - ranges' (L _ (IEThingWith _ thing _ inners _)) -#else - ranges' (L _ (IEThingWith _ thing _ inners)) + _ #endif + ) + ) | T.unpack (printOutputable thing) == b' = [] | otherwise = [ locA l' | L l' x <- inners, T.unpack (printOutputable x) == b'] diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs @@ -24,6 +24,7 @@ import qualified Data.Map as Map import Data.Maybe (fromMaybe) import qualified Data.Text as T +import qualified Data.Text.Utf16.Rope.Mixed as Rope import Development.IDE hiding (pluginHandlers) import Development.IDE.Core.Shake @@ -69,7 +70,7 @@ caaContents <- onceIO $ runRule GetFileContents <&> \case - Just (_, txt) -> txt + Just (_, mbContents) -> fmap Rope.toText mbContents Nothing -> Nothing caaDf <- onceIO $ fmap (ms_hspp_opts . pm_mod_summary) <$> caaParsedModule caaAnnSource <- onceIO $ runRule GetAnnotatedParsedSource diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/RuleTypes.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/RuleTypes.hs --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/RuleTypes.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/RuleTypes.hs @@ -5,7 +5,6 @@ import Control.DeepSeq (NFData) import Data.Hashable (Hashable) -import Data.Typeable (Typeable) import Development.IDE.Graph (RuleResult) import Development.IDE.Types.Exports import Development.IDE.Types.HscEnvEq (HscEnvEq) @@ -15,7 +14,7 @@ type instance RuleResult PackageExports = ExportsMap newtype PackageExports = PackageExports HscEnvEq - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable PackageExports instance NFData PackageExports diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs @@ -126,7 +126,7 @@ -- -- TODO instead of inserting a typed hole; use GHC's suggested type from the error addArgumentAction :: ParsedModule -> Range -> T.Text -> Maybe T.Text -> Either PluginError [(T.Text, [TextEdit])] -addArgumentAction (ParsedModule _ moduleSrc _ _) range name _typ = do +addArgumentAction (ParsedModule _ moduleSrc _) range name _typ = do (newSource, _, _) <- runTransformT $ do (moduleSrc', join -> matchedDeclNameMay) <- addNameAsLastArgOfMatchingDecl #if MIN_VERSION_ghc(9,9,0) diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillHole.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillHole.hs --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillHole.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillHole.hs @@ -29,7 +29,7 @@ Just (firstChr, _) -> let isInfixOperator = firstChr == '(' name' = getOperatorNotation isInfixHole isInfixOperator name in - ( "replace " <> holeName <> " with " <> name + ( "Replace " <> holeName <> " with " <> name , TextEdit _range (if parenthise then addParens name' else name') ) getOperatorNotation True False name = addBackticks name diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -21,7 +21,6 @@ import Data.List.Extra import Data.Maybe import qualified Data.Text as T -import Data.Tuple.Extra import Development.IDE.GHC.Util import Development.IDE.Plugin.Completions.Types (extendImportCommandId) import Development.IDE.Test @@ -39,7 +38,6 @@ import System.IO.Extra hiding (withTempDir) import System.Time.Extra import Test.Tasty -import Test.Tasty.ExpectedFailure import Test.Tasty.HUnit import Text.Regex.TDFA ((=~)) @@ -337,68 +335,62 @@ "WhereDeclLowerInFileWithCommentsBeforeIt.hs" "WhereDeclLowerInFileWithCommentsBeforeIt.expected.hs" "import Data.Int" - , expectFailBecause - "'findNextPragmaPosition' function doesn't account for case when shebang is not placed at top of file" - (checkImport - "Shebang not at top with spaces" - "ShebangNotAtTopWithSpaces.hs" - "ShebangNotAtTopWithSpaces.expected.hs" - "import Data.Monoid") - , expectFailBecause - "'findNextPragmaPosition' function doesn't account for case when shebang is not placed at top of file" - (checkImport - "Shebang not at top no space" - "ShebangNotAtTopNoSpace.hs" - "ShebangNotAtTopNoSpace.expected.hs" - "import Data.Monoid") - , expectFailBecause - ("'findNextPragmaPosition' function doesn't account for case " - ++ "when OPTIONS_GHC pragma is not placed at top of file") - (checkImport - "OPTIONS_GHC pragma not at top with spaces" - "OptionsNotAtTopWithSpaces.hs" - "OptionsNotAtTopWithSpaces.expected.hs" - "import Data.Monoid") - , expectFailBecause - ("'findNextPragmaPosition' function doesn't account for " - ++ "case when shebang is not placed at top of file") - (checkImport - "Shebang not at top of file" - "ShebangNotAtTop.hs" - "ShebangNotAtTop.expected.hs" - "import Data.Monoid") - , expectFailBecause - ("'findNextPragmaPosition' function doesn't account for case " - ++ "when OPTIONS_GHC is not placed at top of file") - (checkImport - "OPTIONS_GHC pragma not at top of file" - "OptionsPragmaNotAtTop.hs" - "OptionsPragmaNotAtTop.expected.hs" - "import Data.Monoid") - , expectFailBecause - ("'findNextPragmaPosition' function doesn't account for case when " - ++ "OPTIONS_GHC pragma is not placed at top of file") - (checkImport - "pragma not at top with comment at top" - "PragmaNotAtTopWithCommentsAtTop.hs" - "PragmaNotAtTopWithCommentsAtTop.expected.hs" - "import Data.Monoid") - , expectFailBecause - ("'findNextPragmaPosition' function doesn't account for case when " - ++ "OPTIONS_GHC pragma is not placed at top of file") - (checkImport - "pragma not at top multiple comments" - "PragmaNotAtTopMultipleComments.hs" - "PragmaNotAtTopMultipleComments.expected.hs" - "import Data.Monoid") - , expectFailBecause - "'findNextPragmaPosition' function doesn't account for case of multiline pragmas" - (checkImport - "after multiline language pragmas" - "MultiLinePragma.hs" - "MultiLinePragma.expected.hs" - "import Data.Monoid") + -- TODO: 'findNextPragmaPosition' function doesn't account for case when shebang is not + -- placed at top of file" , checkImport + "Shebang not at top with spaces" + "ShebangNotAtTopWithSpaces.hs" + "ShebangNotAtTopWithSpaces.expected.hs" + "import Data.Monoid" + -- TODO: 'findNextPragmaPosition' function doesn't account for case when shebang is not + -- placed at top of file" + , checkImport + "Shebang not at top no space" + "ShebangNotAtTopNoSpace.hs" + "ShebangNotAtTopNoSpace.expected.hs" + "import Data.Monoid" + -- TODO: 'findNextPragmaPosition' function doesn't account for case when OPTIONS_GHC pragma is + -- not placed at top of file + , checkImport + "OPTIONS_GHC pragma not at top with spaces" + "OptionsNotAtTopWithSpaces.hs" + "OptionsNotAtTopWithSpaces.expected.hs" + "import Data.Monoid" + -- TODO: findNextPragmaPosition' function doesn't account for case when shebang is not placed + -- at top of file + , checkImport + "Shebang not at top of file" + "ShebangNotAtTop.hs" + "ShebangNotAtTop.expected.hs" + "import Data.Monoid" + -- TODO: findNextPragmaPosition' function doesn't account for case when OPTIONS_GHC is not + -- placed at top of file + , checkImport + "OPTIONS_GHC pragma not at top of file" + "OptionsPragmaNotAtTop.hs" + "OptionsPragmaNotAtTop.expected.hs" + "import Data.Monoid" + -- TODO: findNextPragmaPosition' function doesn't account for case when OPTIONS_GHC pragma is + -- not placed at top of file + , checkImport + "pragma not at top with comment at top" + "PragmaNotAtTopWithCommentsAtTop.hs" + "PragmaNotAtTopWithCommentsAtTop.expected.hs" + "import Data.Monoid" + -- TODO: findNextPragmaPosition' function doesn't account for case when OPTIONS_GHC pragma is + -- not placed at top of file + , checkImport + "pragma not at top multiple comments" + "PragmaNotAtTopMultipleComments.hs" + "PragmaNotAtTopMultipleComments.expected.hs" + "import Data.Monoid" + -- TODO: 'findNextPragmaPosition' function doesn't account for case of multiline pragmas + , checkImport + "after multiline language pragmas" + "MultiLinePragma.hs" + "MultiLinePragma.expected.hs" + "import Data.Monoid" + , checkImport "pragmas not at top with module declaration" "PragmaNotAtTopWithModuleDecl.hs" "PragmaNotAtTopWithModuleDecl.expected.hs" @@ -1347,8 +1339,7 @@ , "b :: A" , "b = ConstructorFoo" ]) - , brokenForGHC92 "On GHC 9.2, the error doesn't contain \"perhaps you want ...\" part from which import suggestion can be extracted." $ - testSession "extend single line import in presence of extra parens" $ template + , testSession "extend single line import in presence of extra parens" $ template [] ("Main.hs", T.unlines [ "import Data.Monoid (First)" @@ -1514,27 +1505,48 @@ , "x :: (:~:) [] []" , "x = Refl" ]) - , expectFailBecause "importing pattern synonyms is unsupported" - $ testSession "extend import list with pattern synonym" $ template - [("ModuleA.hs", T.unlines - [ "{-# LANGUAGE PatternSynonyms #-}" - , "module ModuleA where" - , "pattern Some x = Just x" - ]) - ] - ("ModuleB.hs", T.unlines - [ "module ModuleB where" - , "import A ()" - , "k (Some x) = x" - ]) - (Range (Position 2 3) (Position 2 7)) - ["Add pattern Some to the import list of A"] - (T.unlines - [ "module ModuleB where" - , "import A (pattern Some)" - , "k (Some x) = x" - ]) - , ignoreForGhcVersions [GHC92, GHC94] "Diagnostic message has no suggestions" $ + -- TODO: importing pattern synonyms is unsupported + , testSessionExpectFail "extend import list with pattern synonym" + (BrokenIdeal $ + template + [("ModuleA.hs", T.unlines + [ "{-# LANGUAGE PatternSynonyms #-}" + , "module ModuleA where" + , "pattern Some x = Just x" + ]) + ] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import A ()" + , "k (Some x) = x" + ] + ) + (Range (Position 2 3) (Position 2 7)) + ["Add pattern Some to the import list of A"] + (T.unlines + [ "module ModuleB where" + , "import A (pattern Some)" + , "k (Some x) = x" + ] + ) + ) + (BrokenCurrent $ + noCodeActionsTemplate + [("ModuleA.hs", T.unlines + [ "{-# LANGUAGE PatternSynonyms #-}" + , "module ModuleA where" + , "pattern Some x = Just x" + ]) + ] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import A ()" + , "k (Some x) = x" + ] + ) + (Range (Position 2 3) (Position 2 7)) + ) + , ignoreForGhcVersions [GHC94] "Diagnostic message has no suggestions" $ testSession "type constructor name same as data constructor name" $ template [("ModuleA.hs", T.unlines [ "module ModuleA where" @@ -1602,19 +1614,10 @@ codeActionTitle CodeAction{_title=x} = x template setUpModules moduleUnderTest range expectedTitles expectedContentB = do - configureCheckProject overrideCheckProject + docB <- evalProject setUpModules moduleUnderTest + codeActions <- codeActions docB range + let actualTitles = codeActionTitle <$> codeActions - mapM_ (\(fileName, contents) -> createDoc fileName "haskell" contents) setUpModules - docB <- createDoc (fst moduleUnderTest) "haskell" (snd moduleUnderTest) - _ <- waitForDiagnostics - waitForProgressDone - actionsOrCommands <- getCodeActions docB range - let codeActions = - [ ca | InR ca <- actionsOrCommands - , let title = codeActionTitle ca - , "Add" `T.isPrefixOf` title && not ("Add argument" `T.isPrefixOf` title) - ] - actualTitles = codeActionTitle <$> codeActions -- Note that we are not testing the order of the actions, as the -- order of the expected actions indicates which one we'll execute -- in this test, i.e., the first one. @@ -1629,12 +1632,36 @@ contentAfterAction <- documentContents docB liftIO $ expectedContentB @=? contentAfterAction + noCodeActionsTemplate setUpModules moduleUnderTest range = do + docB <- evalProject setUpModules moduleUnderTest + codeActions' <- codeActions docB range + let actualTitles = codeActionTitle <$> codeActions' + liftIO $ [] @=? actualTitles + + evalProject setUpModules moduleUnderTest = do + configureCheckProject overrideCheckProject + + mapM_ (\(fileName, contents) -> createDoc fileName "haskell" contents) setUpModules + docB <- createDoc (fst moduleUnderTest) "haskell" (snd moduleUnderTest) + _ <- waitForDiagnostics + waitForProgressDone + + pure docB + + codeActions docB range = do + actionsOrCommands <- getCodeActions docB range + pure $ + [ ca | InR ca <- actionsOrCommands + , let title = codeActionTitle ca + , "Add" `T.isPrefixOf` title && not ("Add argument" `T.isPrefixOf` title) + ] + fixModuleImportTypoTests :: TestTree fixModuleImportTypoTests = testGroup "fix module import typo" [ testSession "works when single module suggested" $ do doc <- createDoc "A.hs" "haskell" "import Data.Cha" _ <- waitForDiagnostics - action <- pickActionWithTitle "replace with Data.Char" =<< getCodeActions doc (R 0 0 0 10) + action <- pickActionWithTitle "Replace with Data.Char" =<< getCodeActions doc (R 0 0 0 10) executeCodeAction action contentAfterAction <- documentContents doc liftIO $ contentAfterAction @?= "import Data.Char" @@ -1643,11 +1670,11 @@ _ <- waitForDiagnostics actions <- getCodeActions doc (R 0 0 0 10) traverse_ (assertActionWithTitle actions) - [ "replace with Data.Eq" - , "replace with Data.Int" - , "replace with Data.Ix" + [ "Replace with Data.Eq" + , "Replace with Data.Int" + , "Replace with Data.Ix" ] - replaceWithDataEq <- pickActionWithTitle "replace with Data.Eq" actions + replaceWithDataEq <- pickActionWithTitle "Replace with Data.Eq" actions executeCodeAction replaceWithDataEq contentAfterAction <- documentContents doc liftIO $ contentAfterAction @?= "import Data.Eq" @@ -1788,7 +1815,8 @@ , test True [] "f = (.|.)" [] "import Data.Bits (Bits(..))" , test True [] "f = empty" [] "import Control.Applicative (Alternative(..))" ] - , expectFailBecause "importing pattern synonyms is unsupported" $ test True [] "k (Some x) = x" [] "import B (pattern Some)" + -- TODO: Importing pattern synonyms is unsupported + , test False [] "k (Some x) = x" [] "import B (pattern Some)" ] where test = test' False @@ -1967,7 +1995,7 @@ compareHideFunctionTo = compareTwo "HideFunction.hs" withTarget file locs k = runWithExtraFiles "hiding" $ \dir -> do doc <- openDoc file "haskell" - void $ expectDiagnostics [(file, [(DiagnosticSeverity_Error, loc, "Ambiguous occurrence") | loc <- locs])] + void $ expectDiagnostics [(file, [(DiagnosticSeverity_Error, loc, "Ambiguous occurrence", Nothing) | loc <- locs])] -- Since GHC 9.8: GHC-87110 actions <- getAllCodeActions doc k dir doc actions withHideFunction = withTarget ("HideFunction" <.> "hs") @@ -2426,7 +2454,7 @@ where testFor sourceLines pos@(l,c) expectedTitle expectedLines = do docId <- createDoc "A.hs" "haskell" $ T.unlines sourceLines - expectDiagnostics [ ("A.hs", [(DiagnosticSeverity_Warning, pos, "not used")]) ] + expectDiagnostics [ ("A.hs", [(DiagnosticSeverity_Warning, pos, "not used", Nothing)]) ] action <- pickActionWithTitle expectedTitle =<< getCodeActions docId (R l c l c) executeCodeAction action contentAfterAction <- documentContents docId @@ -2442,8 +2470,8 @@ , "f = 1" ] (if ghcVersion >= GHC94 - then [ (DiagnosticSeverity_Warning, (3, 4), "Defaulting the type variable") ] - else [ (DiagnosticSeverity_Warning, (3, 4), "Defaulting the following constraint") ]) + then [ (DiagnosticSeverity_Warning, (3, 4), "Defaulting the type variable", Nothing) ] + else [ (DiagnosticSeverity_Warning, (3, 4), "Defaulting the following constraint", Nothing) ]) "Add type annotation ‘Integer’ to ‘1’" [ "{-# OPTIONS_GHC -Wtype-defaults #-}" , "module A (f) where" @@ -2461,8 +2489,8 @@ , " in x" ] (if ghcVersion >= GHC94 - then [ (DiagnosticSeverity_Warning, (4, 12), "Defaulting the type variable") ] - else [ (DiagnosticSeverity_Warning, (4, 12), "Defaulting the following constraint") ]) + then [ (DiagnosticSeverity_Warning, (4, 12), "Defaulting the type variable", Nothing) ] + else [ (DiagnosticSeverity_Warning, (4, 12), "Defaulting the following constraint", Nothing) ]) "Add type annotation ‘Integer’ to ‘3’" [ "{-# OPTIONS_GHC -Wtype-defaults #-}" , "module A where" @@ -2481,8 +2509,8 @@ , " in x" ] (if ghcVersion >= GHC94 - then [ (DiagnosticSeverity_Warning, (4, 20), "Defaulting the type variable") ] - else [ (DiagnosticSeverity_Warning, (4, 20), "Defaulting the following constraint") ]) + then [ (DiagnosticSeverity_Warning, (4, 20), "Defaulting the type variable", Nothing) ] + else [ (DiagnosticSeverity_Warning, (4, 20), "Defaulting the following constraint", Nothing) ]) "Add type annotation ‘Integer’ to ‘5’" [ "{-# OPTIONS_GHC -Wtype-defaults #-}" , "module A where" @@ -2503,12 +2531,12 @@ ] (if ghcVersion >= GHC94 then - [ (DiagnosticSeverity_Warning, (6, 8), "Defaulting the type variable") - , (DiagnosticSeverity_Warning, (6, 16), "Defaulting the type variable") + [ (DiagnosticSeverity_Warning, (6, 8), "Defaulting the type variable", Nothing) + , (DiagnosticSeverity_Warning, (6, 16), "Defaulting the type variable", Nothing) ] else - [ (DiagnosticSeverity_Warning, (6, 8), "Defaulting the following constraint") - , (DiagnosticSeverity_Warning, (6, 16), "Defaulting the following constraint") + [ (DiagnosticSeverity_Warning, (6, 8), "Defaulting the following constraint", Nothing) + , (DiagnosticSeverity_Warning, (6, 16), "Defaulting the following constraint", Nothing) ]) "Add type annotation ‘String’ to ‘\"debug\"’" [ "{-# OPTIONS_GHC -Wtype-defaults #-}" @@ -2530,8 +2558,8 @@ , "f a = traceShow \"debug\" a" ] (if ghcVersion >= GHC94 - then [ (DiagnosticSeverity_Warning, (6, 6), "Defaulting the type variable") ] - else [ (DiagnosticSeverity_Warning, (6, 6), "Defaulting the following constraint") ]) + then [ (DiagnosticSeverity_Warning, (6, 6), "Defaulting the type variable", Nothing) ] + else [ (DiagnosticSeverity_Warning, (6, 6), "Defaulting the following constraint", Nothing) ]) "Add type annotation ‘String’ to ‘\"debug\"’" [ "{-# OPTIONS_GHC -Wtype-defaults #-}" , "{-# LANGUAGE OverloadedStrings #-}" @@ -2552,8 +2580,8 @@ , "f = seq (\"debug\" :: [Char]) (seq (\"debug\" :: [Char]) (traceShow \"debug\"))" ] (if ghcVersion >= GHC94 - then [ (DiagnosticSeverity_Warning, (6, 54), "Defaulting the type variable") ] - else [ (DiagnosticSeverity_Warning, (6, 54), "Defaulting the following constraint") ]) + then [ (DiagnosticSeverity_Warning, (6, 54), "Defaulting the type variable", Nothing) ] + else [ (DiagnosticSeverity_Warning, (6, 54), "Defaulting the following constraint", Nothing) ]) "Add type annotation ‘String’ to ‘\"debug\"’" [ "{-# OPTIONS_GHC -Wtype-defaults #-}" , "{-# LANGUAGE OverloadedStrings #-}" @@ -2568,7 +2596,7 @@ testFor sourceLines diag expectedTitle expectedLines = do docId <- createDoc "A.hs" "haskell" $ T.unlines sourceLines expectDiagnostics [ ("A.hs", diag) ] - let cursors = map snd3 diag + let cursors = map (\(_, snd, _, _) -> snd) diag (ls, cs) = minimum cursors (le, ce) = maximum cursors @@ -2612,7 +2640,7 @@ where check modname = checkCodeAction ("Data.Mape -> Data." <> T.unpack modname) - ("replace with Data." <> modname) + ("Replace with Data." <> modname) (T.unlines [ "module Testing where" , "import Data.Mape" @@ -2658,33 +2686,33 @@ liftIO $ expectedCode @=? modifiedCode in testGroup "fill typed holes" - [ check "replace _ with show" + [ check "Replace _ with show" "_" "n" "n" "show" "n" "n" - , check "replace _ with globalConvert" + , check "Replace _ with globalConvert" "_" "n" "n" "globalConvert" "n" "n" - , check "replace _convertme with localConvert" + , check "Replace _convertme with localConvert" "_convertme" "n" "n" "localConvert" "n" "n" - , check "replace _b with globalInt" + , check "Replace _b with globalInt" "_a" "_b" "_c" "_a" "globalInt" "_c" - , check "replace _c with globalInt" + , check "Replace _c with globalInt" "_a" "_b" "_c" "_a" "_b" "globalInt" - , check "replace _c with parameterInt" + , check "Replace _c with parameterInt" "_a" "_b" "_c" "_a" "_b" "parameterInt" - , check "replace _ with foo _" + , check "Replace _ with foo _" "_" "n" "n" "(foo _)" "n" "n" - , testSession "replace _toException with E.toException" $ do + , testSession "Replace _toException with E.toException" $ do let mkDoc x = T.unlines [ "module Testing where" , "import qualified Control.Exception as E" @@ -2693,7 +2721,7 @@ doc <- createDoc "Test.hs" "haskell" $ mkDoc "_toException" _ <- waitForDiagnostics actions <- getCodeActions doc (Range (Position 3 0) (Position 3 maxBound)) - chosen <- pickActionWithTitle "replace _toException with E.toException" actions + chosen <- pickActionWithTitle "Replace _toException with E.toException" actions executeCodeAction chosen modifiedCode <- documentContents doc liftIO $ mkDoc "E.toException" @=? modifiedCode @@ -2709,7 +2737,7 @@ doc <- createDoc "Test.hs" "haskell" $ mkDoc "`_`" _ <- waitForDiagnostics actions <- getCodeActions doc (Range (Position 5 16) (Position 5 19)) - chosen <- pickActionWithTitle "replace _ with foo" actions + chosen <- pickActionWithTitle "Replace _ with foo" actions executeCodeAction chosen modifiedCode <- documentContents doc liftIO $ mkDoc "`foo`" @=? modifiedCode @@ -2722,7 +2750,7 @@ doc <- createDoc "Test.hs" "haskell" $ mkDoc "_" _ <- waitForDiagnostics actions <- getCodeActions doc (Range (Position 2 13) (Position 2 14)) - chosen <- pickActionWithTitle "replace _ with (<$>)" actions + chosen <- pickActionWithTitle "Replace _ with (<$>)" actions executeCodeAction chosen modifiedCode <- documentContents doc liftIO $ mkDoc "(<$>)" @=? modifiedCode @@ -2735,7 +2763,7 @@ doc <- createDoc "Test.hs" "haskell" $ mkDoc "`_`" _ <- waitForDiagnostics actions <- getCodeActions doc (Range (Position 2 16) (Position 2 19)) - chosen <- pickActionWithTitle "replace _ with (<$>)" actions + chosen <- pickActionWithTitle "Replace _ with (<$>)" actions executeCodeAction chosen modifiedCode <- documentContents doc liftIO $ mkDoc "<$>" @=? modifiedCode @@ -3222,7 +3250,7 @@ ] (R 2 0 2 11) "Export ‘bar’" - , ignoreForGhcVersions [GHC92, GHC94] "Diagnostic message has no suggestions" $ + , ignoreForGhcVersions [GHC94] "Diagnostic message has no suggestions" $ testSession "type is exported but not the constructor of same name" $ templateNoAction [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" , "module A (Foo) where" @@ -3384,6 +3412,19 @@ , "module A (pattern Foo) where" , "pattern Foo a <- (a, _)" ] + , testSession "unused pattern synonym operator" $ template + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE PatternSynonyms #-}" + , "module A () where" + , "pattern x :+ y = (x, y)" + ] + (R 3 0 3 12) + "Export ‘:+’" + [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" + , "{-# LANGUAGE PatternSynonyms #-}" + , "module A (pattern (:+)) where" + , "pattern x :+ y = (x, y)" + ] , testSession "unused data type" $ template [ "{-# OPTIONS_GHC -Wunused-top-binds #-}" , "module A () where" @@ -3805,6 +3846,13 @@ testSession :: TestName -> Session () -> TestTree testSession name = testCase name . run +testSessionExpectFail + :: TestName + -> ExpectBroken 'Ideal (Session ()) + -> ExpectBroken 'Current (Session ()) + -> TestTree +testSessionExpectFail name _ = testSession name . unCurrent + testSessionWithExtraFiles :: HasCallStack => FilePath -> TestName -> (FilePath -> Session ()) -> TestTree testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix @@ -3850,6 +3898,3 @@ brokenForGHC94 :: String -> TestTree -> TestTree brokenForGHC94 = knownBrokenForGhcVersions [GHC94] - -brokenForGHC92 :: String -> TestTree -> TestTree -brokenForGHC92 = knownBrokenForGhcVersions [GHC92] diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/MultiLinePragma.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/MultiLinePragma.expected.hs --- a/plugins/hls-refactor-plugin/test/data/import-placement/MultiLinePragma.expected.hs +++ b/plugins/hls-refactor-plugin/test/data/import-placement/MultiLinePragma.expected.hs @@ -3,8 +3,8 @@ {-# LANGUAGE RecordWildCards, OverloadedStrings #-} {-# OPTIONS_GHC -Wall, - -Wno-unused-imports #-} import Data.Monoid + -Wno-unused-imports #-} -- some comment diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/OptionsNotAtTopWithSpaces.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/OptionsNotAtTopWithSpaces.expected.hs --- a/plugins/hls-refactor-plugin/test/data/import-placement/OptionsNotAtTopWithSpaces.expected.hs +++ b/plugins/hls-refactor-plugin/test/data/import-placement/OptionsNotAtTopWithSpaces.expected.hs @@ -2,7 +2,6 @@ {-# LANGUAGE TupleSections #-} -import Data.Monoid @@ -11,6 +10,7 @@ instance SomeData All {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +import Data.Monoid addOne :: Int -> Int addOne x = x + 1 diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/OptionsPragmaNotAtTop.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/OptionsPragmaNotAtTop.expected.hs --- a/plugins/hls-refactor-plugin/test/data/import-placement/OptionsPragmaNotAtTop.expected.hs +++ b/plugins/hls-refactor-plugin/test/data/import-placement/OptionsPragmaNotAtTop.expected.hs @@ -1,8 +1,8 @@ -import Data.Monoid class Semigroup a => SomeData a instance SomeData All {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +import Data.Monoid addOne :: Int -> Int addOne x = x + 1 diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopMultipleComments.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopMultipleComments.expected.hs --- a/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopMultipleComments.expected.hs +++ b/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopMultipleComments.expected.hs @@ -9,7 +9,6 @@ -} {-# LANGUAGE TupleSections #-} -import Data.Monoid {- some comment -} -- again @@ -18,6 +17,7 @@ #! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +import Data.Monoid addOne :: Int -> Int addOne x = x + 1 diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.expected.hs --- a/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.expected.hs +++ b/plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.expected.hs @@ -4,7 +4,6 @@ -- another comment {-# LANGUAGE TupleSections #-} -import Data.Monoid {- some comment -} @@ -13,6 +12,7 @@ #! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +import Data.Monoid addOne :: Int -> Int addOne x = x + 1 diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTop.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTop.expected.hs --- a/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTop.expected.hs +++ b/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTop.expected.hs @@ -1,10 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} -import Data.Monoid class Semigroup a => SomeData a instance SomeData All #! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +import Data.Monoid f :: Int -> Int f x = x * x diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTopNoSpace.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTopNoSpace.expected.hs --- a/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTopNoSpace.expected.hs +++ b/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTopNoSpace.expected.hs @@ -1,8 +1,8 @@ -import Data.Monoid class Semigroup a => SomeData a instance SomeData All #! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" +import Data.Monoid f :: Int -> Int f x = x * x diff --git a/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTopWithSpaces.expected.hs b/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTopWithSpaces.expected.hs --- a/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTopWithSpaces.expected.hs +++ b/plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTopWithSpaces.expected.hs @@ -6,7 +6,6 @@ {-# LANGUAGE TupleSections #-} -import Data.Monoid @@ -16,6 +15,7 @@ #! nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (hp: with hp; [ turtle ])" {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +import Data.Monoid addOne :: Int -> Int addOne x = x + 1 diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -29,6 +29,7 @@ import qualified Data.Text as T import Development.IDE (Recorder, WithPriority, usePropertyAction) +import Development.IDE.Core.FileStore (getVersionedTextDoc) import Development.IDE.Core.PluginUtils import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service @@ -109,7 +110,7 @@ let newName = mkTcOcc $ T.unpack newNameText filesRefs = collectWith locToUri refs getFileEdit (uri, locations) = do - verTxtDocId <- lift $ pluginGetVersionedTextDoc (TextDocumentIdentifier uri) + verTxtDocId <- liftIO $ runAction "rename: getVersionedTextDoc" state $ getVersionedTextDoc (TextDocumentIdentifier uri) getSrcEdit state verTxtDocId (replaceRefs newName locations) fileEdits <- mapM getFileEdit filesRefs pure $ InL $ fold fileEdits diff --git a/plugins/hls-rename-plugin/test/Main.hs b/plugins/hls-rename-plugin/test/Main.hs --- a/plugins/hls-rename-plugin/test/Main.hs +++ b/plugins/hls-rename-plugin/test/Main.hs @@ -20,18 +20,13 @@ renamePlugin :: PluginTestDescriptor Rename.Log renamePlugin = mkPluginTestDescriptor Rename.descriptor "rename" --- See https://github.com/wz1000/HieDb/issues/45 -recordConstructorIssue :: String -recordConstructorIssue = "HIE references for record fields incorrect with GHC versions >= 9" - tests :: TestTree tests = testGroup "Rename" [ goldenWithRename "Data constructor" "DataConstructor" $ \doc -> rename doc (Position 0 15) "Op" , goldenWithRename "Exported function" "ExportedFunction" $ \doc -> rename doc (Position 2 1) "quux" - , ignoreForGhcVersions [GHC92] recordConstructorIssue $ - goldenWithRename "Field Puns" "FieldPuns" $ \doc -> + , goldenWithRename "Field Puns" "FieldPuns" $ \doc -> rename doc (Position 7 13) "bleh" , goldenWithRename "Function argument" "FunctionArgument" $ \doc -> rename doc (Position 3 4) "y" @@ -45,8 +40,7 @@ rename doc (Position 3 8) "baz" , goldenWithRename "Import hiding" "ImportHiding" $ \doc -> rename doc (Position 0 22) "hiddenFoo" - , ignoreForGhcVersions [GHC92] recordConstructorIssue $ - goldenWithRename "Indirect Puns" "IndirectPuns" $ \doc -> + , goldenWithRename "Indirect Puns" "IndirectPuns" $ \doc -> rename doc (Position 4 23) "blah" , goldenWithRename "Let expression" "LetExpression" $ \doc -> rename doc (Position 5 11) "foobar" @@ -58,8 +52,7 @@ rename doc (Position 3 12) "baz" , goldenWithRename "Realigns do block indentation" "RealignDo" $ \doc -> rename doc (Position 0 2) "fooBarQuux" - , ignoreForGhcVersions [GHC92] recordConstructorIssue $ - goldenWithRename "Record field" "RecordField" $ \doc -> + , goldenWithRename "Record field" "RecordField" $ \doc -> rename doc (Position 6 9) "number" , goldenWithRename "Shadowed name" "ShadowedName" $ \doc -> rename doc (Position 1 1) "baz" diff --git a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -42,6 +42,7 @@ import Data.String (IsString) import qualified Data.Text as T import qualified Data.Text.Encoding as T +import qualified Data.Text.Utf16.Rope.Mixed as Rope import Development.IDE hiding (pluginHandlers) import Development.IDE.Core.Actions (lookupMod) import Development.IDE.Core.PluginUtils @@ -127,9 +128,7 @@ import Retrie.Types import Retrie.Universe (Universe) -#if MIN_VERSION_ghc(9,3,0) import GHC.Types.PkgQual -#endif data Log = LogParsingModule FilePath @@ -503,7 +502,7 @@ | NoParse NormalizedFilePath | GHCParseError NormalizedFilePath String | NoTypeCheck NormalizedFilePath - deriving (Eq, Typeable) + deriving (Eq) instance Show CallRetrieError where show (CallRetrieInternalError msg f) = msg <> " - " <> fromNormalizedFilePath f @@ -735,11 +734,7 @@ ideclAs = toMod <$> ideclAsString ideclQualified = if ideclQualifiedBool then GHC.QualifiedPre else GHC.NotQualified -#if MIN_VERSION_ghc(9,3,0) ideclPkgQual = NoRawPkgQual -#else - ideclPkgQual = Nothing -#endif #if MIN_VERSION_ghc(9,5,0) ideclImportList = Nothing @@ -784,10 +779,10 @@ return (fixities, parsed) contents <- do - (_, mbContentsVFS) <- + mbContentsVFS <- runAction "Retrie.GetFileContents" state $ getFileContents nt case mbContentsVFS of - Just contents -> return contents + Just contents -> return $ Rope.toText contents Nothing -> T.decodeUtf8 <$> BS.readFile (fromNormalizedFilePath nt) if any (T.isPrefixOf "#if" . T.toLower) (T.lines contents) then do diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Types.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Types.hs --- a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Types.hs +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Types.hs @@ -10,7 +10,6 @@ import Control.DeepSeq (NFData (rnf), rwhnf) import qualified Data.Array as A import Data.Default (Default (def)) -import Data.Generics (Typeable) import Development.IDE (Pretty (pretty), RuleResult) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat hiding (loc) @@ -108,7 +107,7 @@ show (Loc line startChar len) = show line <> ":" <> show startChar <> "-" <> show (startChar + len) data GetSemanticTokens = GetSemanticTokens - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable GetSemanticTokens diff --git a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs --- a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs +++ b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs @@ -10,8 +10,7 @@ import qualified Data.List as T import Data.Map.Strict as Map hiding (map) import Data.String (fromString) -import Data.Text hiding (length, map, - unlines) +import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Utf16.Rope.Mixed as Rope import Data.Version (Version (..)) @@ -225,7 +224,7 @@ semanticTokensTests :: TestTree semanticTokensTests = - testGroup "other semantic Token test" $ + testGroup "other semantic Token test" [ testCase "module import test" $ do let file1 = "TModuleA.hs" let file2 = "TModuleB.hs" @@ -263,10 +262,9 @@ goldenWithSemanticTokensWithDefaultConfig "pattern bind" "TPatternSynonym", goldenWithSemanticTokensWithDefaultConfig "type family" "TTypefamily", goldenWithSemanticTokensWithDefaultConfig "TUnicodeSyntax" "TUnicodeSyntax", - goldenWithSemanticTokensWithDefaultConfig "TQualifiedName" "TQualifiedName" + goldenWithSemanticTokensWithDefaultConfig "TQualifiedName" "TQualifiedName", + goldenWithSemanticTokensWithDefaultConfig "TDoc" "TDoc" ] - -- not supported in ghc92 - ++ [goldenWithSemanticTokensWithDefaultConfig "TDoc" "TDoc" | ghcVersion > GHC92] semanticTokensDataTypeTests :: TestTree semanticTokensDataTypeTests = diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -38,12 +38,14 @@ mapMaybe) import qualified Data.Text as T import Development.IDE +import Development.IDE.Core.FileStore (getVersionedTextDoc) import Development.IDE.Core.PluginUtils import Development.IDE.GHC.Compat as Compat import Development.IDE.GHC.Compat.ExactPrint import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.GHC.ExactPrint import GHC.Exts +import qualified GHC.Runtime.Loader as Loader import qualified GHC.Types.Error as Error import Ide.Plugin.Error (PluginError (PluginInternalError)) import Ide.Plugin.Splice.Types @@ -191,7 +193,7 @@ pure (Right edits) case res of Nothing -> pure $ Right $ InR Null - Just (Left err) -> pure $ Left $ err + Just (Left err) -> pure $ Left err Just (Right edit) -> do _ <- pluginSendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) pure $ Right $ InR Null @@ -210,7 +212,7 @@ hscEnvEq <- runActionE "expandTHSplice.fallback.ghcSessionDeps" ideState $ useE GhcSessionDeps fp let ps = annotateParsedSource pm - hscEnv0 = hscEnvWithImportPaths hscEnvEq + hscEnv0 = hscEnv hscEnvEq modSum = pm_mod_summary pm hscEnv <- liftIO $ setupDynFlagsForGHCiLike hscEnv0 $ ms_hspp_opts modSum pure (ps, hscEnv, hsc_dflags hscEnv) @@ -232,7 +234,7 @@ `gopt_set` Opt_IgnoreOptimChanges `gopt_set` Opt_IgnoreHpcChanges `gopt_unset` Opt_DiagnosticsShowCaret - initializePlugins (hscSetFlags dflags4 env) + Loader.initializePlugins (hscSetFlags dflags4 env) adjustToRange :: Uri -> Range -> WorkspaceEdit -> WorkspaceEdit adjustToRange uri ran (WorkspaceEdit mhult mlt x) = @@ -464,7 +466,7 @@ data SearchResult r = Continue | Stop | Here r - deriving (Read, Show, Eq, Ord, Data, Typeable) + deriving (Read, Show, Eq, Ord, Data) fromSearchResult :: SearchResult a -> Maybe a fromSearchResult (Here r) = Just r @@ -474,7 +476,7 @@ -- TODO: Declaration Splices won't appear in HieAst; perhaps we must just use Parsed/Renamed ASTs? codeAction :: PluginMethodHandler IdeState Method_TextDocumentCodeAction codeAction state plId (CodeActionParams _ _ docId ran _) = do - verTxtDocId <- lift $ pluginGetVersionedTextDoc docId + verTxtDocId <- liftIO $ runAction "splice.codeAction.getVersionedTextDoc" state $ getVersionedTextDoc docId liftIO $ fmap (fromMaybe ( InL [])) $ runMaybeT $ do fp <- MaybeT $ pure $ uriToNormalizedFilePath $ toNormalizedUri theUri diff --git a/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs b/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs --- a/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs +++ b/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs @@ -187,17 +187,18 @@ "Possible solutions:" ] ++ map (" - " <>) (inspectionSolution inspection) - return ( file, - ShowDiag, - LSP.Diagnostic - { _range = realSrcSpanToRange observationSrcSpan, - _severity = Just LSP.DiagnosticSeverity_Hint, - _code = Just (LSP.InR $ unId (inspectionId inspection)), - _source = Just "stan", - _message = message, - _relatedInformation = Nothing, - _tags = Nothing, - _codeDescription = Nothing, - _data_ = Nothing - } - ) + return $ + ideErrorFromLspDiag + LSP.Diagnostic + { _range = realSrcSpanToRange observationSrcSpan, + _severity = Just LSP.DiagnosticSeverity_Hint, + _code = Just (LSP.InR $ unId (inspectionId inspection)), + _source = Just "stan", + _message = message, + _relatedInformation = Nothing, + _tags = Nothing, + _codeDescription = Nothing, + _data_ = Nothing + } + file + Nothing diff --git a/src/HlsPlugins.hs b/src/HlsPlugins.hs --- a/src/HlsPlugins.hs +++ b/src/HlsPlugins.hs @@ -152,6 +152,7 @@ allPlugins = #if hls_cabal let pId = "cabal" in Cabal.descriptor (pluginRecorder pId) pId : + let caId = "cabalHaskellIntegration" in Cabal.haskellInteractionDescriptor (pluginRecorder caId) caId : #endif #if hls_pragmas Pragmas.suggestPragmaDescriptor "pragmas-suggest" : diff --git a/src/Ide/Arguments.hs b/src/Ide/Arguments.hs --- a/src/Ide/Arguments.hs +++ b/src/Ide/Arguments.hs @@ -3,7 +3,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above module Ide.Arguments ( Arguments(..) diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -1,7 +1,6 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} @@ -18,7 +17,7 @@ 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.Rules hiding (Log) import Development.IDE.Core.Tracing (withTelemetryRecorder) import Development.IDE.Main (isLSP) import qualified Development.IDE.Main as IDEMain @@ -89,7 +88,7 @@ $ map describePlugin $ sortOn pluginId $ ipMap idePlugins - putStrLn $ show pluginSummary + print pluginSummary BiosMode PrintCradleType -> do dir <- IO.getCurrentDirectory diff --git a/test/functional/Config.hs b/test/functional/Config.hs --- a/test/functional/Config.hs +++ b/test/functional/Config.hs @@ -8,12 +8,11 @@ import Data.Hashable import qualified Data.HashMap.Strict as HM import qualified Data.Map as Map -import Data.Typeable (Typeable) import Development.IDE (RuleResult, action, define, getFilesOfInterestUntracked, getPluginConfigAction, ideErrorText, uses_) -import Development.IDE.Test (expectDiagnostics) +import Development.IDE.Test (ExpectedDiagnostic, expectDiagnostics) import GHC.Generics import Ide.Plugin.Config import Ide.Types @@ -43,13 +42,15 @@ setHlsConfig $ changeConfig "someplugin" def{plcHoverOn = False} -- getting only the expected diagnostics means the plugin wasn't enabled expectDiagnostics standardDiagnostics - , expectFailBecause "partial config is not supported" $ - testCase "custom defaults and non overlapping user config" $ runConfigSession "diagnostics" $ do + -- TODO: Partial config is not supported + , testCase "custom defaults and non overlapping user config" $ runConfigSession "diagnostics" $ do _doc <- createDoc "Foo.hs" "haskell" "module Foo where\nfoo = False" -- test that the user config doesn't accidentally override the initial config setHlsConfig $ changeConfig testPluginId def{plcHoverOn = False} -- getting only the expected diagnostics means the plugin wasn't enabled - expectDiagnostics standardDiagnostics + expectDiagnosticsFail + (BrokenIdeal standardDiagnostics) + (BrokenCurrent testPluginDiagnostics) , testCase "custom defaults and overlapping user plugin config" $ runConfigSession "diagnostics" $ do _doc <- createDoc "Foo.hs" "haskell" "module Foo where\nfoo = False" -- test that the user config overrides the default initial config @@ -64,8 +65,8 @@ expectDiagnostics standardDiagnostics ] where - standardDiagnostics = [("Foo.hs", [(DiagnosticSeverity_Warning, (1,0), "Top-level binding")])] - testPluginDiagnostics = [("Foo.hs", [(DiagnosticSeverity_Error, (0,0), "testplugin")])] + standardDiagnostics = [("Foo.hs", [(DiagnosticSeverity_Warning, (1,0), "Top-level binding", Nothing)])] + testPluginDiagnostics = [("Foo.hs", [(DiagnosticSeverity_Error, (0,0), "testplugin", Nothing)])] runConfigSession subdir session = do failIfSessionTimeout $ @@ -100,7 +101,14 @@ data GetTestDiagnostics = GetTestDiagnostics - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable GetTestDiagnostics instance NFData GetTestDiagnostics type instance RuleResult GetTestDiagnostics = () + +expectDiagnosticsFail + :: HasCallStack + => ExpectBroken 'Ideal [(FilePath, [ExpectedDiagnostic])] + -> ExpectBroken 'Current [(FilePath, [ExpectedDiagnostic])] + -> Session () +expectDiagnosticsFail _ = expectDiagnostics . unCurrent diff --git a/test/functional/Main.hs b/test/functional/Main.hs --- a/test/functional/Main.hs +++ b/test/functional/Main.hs @@ -12,8 +12,8 @@ main = defaultTestRunner $ testGroup "haskell-language-server" [ Config.tests , ConfigSchema.tests - , ignoreInEnv [HostOS Windows, GhcVer GHC92] "Tests gets stuck in ci" $ Format.tests + , ignoreInEnv [HostOS Windows] "Tests gets stuck in ci" Format.tests , FunctionalBadProject.tests , HieBios.tests - , ignoreInEnv [HostOS Windows] "Tests gets stuck in ci" $ Progress.tests + , ignoreInEnv [HostOS Windows] "Tests gets stuck in ci" Progress.tests ] diff --git a/test/testdata/hieBiosMainIs/dist-newstyle/cache/plan.json b/test/testdata/hieBiosMainIs/dist-newstyle/cache/plan.json new file mode 100644 --- /dev/null +++ b/test/testdata/hieBiosMainIs/dist-newstyle/cache/plan.json @@ -0,0 +1,1 @@ +{"cabal-version":"3.12.1.0","cabal-lib-version":"3.12.1.0","compiler-id":"ghc-9.12.2","os":"linux","arch":"x86_64","install-plan":[{"type":"pre-existing","id":"base-4.21.0.0-b7a5","pkg-name":"base","pkg-version":"4.21.0.0","depends":["ghc-internal-9.1202.0-7700","ghc-prim-0.13.0-00de"]},{"type":"pre-existing","id":"ghc-bignum-1.3-4dbb","pkg-name":"ghc-bignum","pkg-version":"1.3","depends":["ghc-prim-0.13.0-00de"]},{"type":"pre-existing","id":"ghc-internal-9.1202.0-7700","pkg-name":"ghc-internal","pkg-version":"9.1202.0","depends":["ghc-bignum-1.3-4dbb","ghc-prim-0.13.0-00de","rts-1.0.2"]},{"type":"pre-existing","id":"ghc-prim-0.13.0-00de","pkg-name":"ghc-prim","pkg-version":"0.13.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/hugin/Documents/haskell/hls/test/testdata/hieBiosMainIs/."},"dist-dir":"/home/hugin/Documents/haskell/hls/test/testdata/hieBiosMainIs/dist-newstyle/build/x86_64-linux/ghc-9.12.2/hieBiosMainIs-0.1.0.0/x/hieBiosMainIs","build-info":"/home/hugin/Documents/haskell/hls/test/testdata/hieBiosMainIs/dist-newstyle/build/x86_64-linux/ghc-9.12.2/hieBiosMainIs-0.1.0.0/x/hieBiosMainIs/build-info.json","depends":["base-4.21.0.0-b7a5"],"exe-depends":[],"component-name":"exe:hieBiosMainIs","bin-file":"/home/hugin/Documents/haskell/hls/test/testdata/hieBiosMainIs/dist-newstyle/build/x86_64-linux/ghc-9.12.2/hieBiosMainIs-0.1.0.0/x/hieBiosMainIs/build/hieBiosMainIs/hieBiosMainIs"},{"type":"pre-existing","id":"rts-1.0.2","pkg-name":"rts","pkg-version":"1.0.2","depends":[]}]} diff --git a/test/testdata/missingModuleTest/missingModule/dist-newstyle/cache/plan.json b/test/testdata/missingModuleTest/missingModule/dist-newstyle/cache/plan.json new file mode 100644 --- /dev/null +++ b/test/testdata/missingModuleTest/missingModule/dist-newstyle/cache/plan.json @@ -0,0 +1,1 @@ +{"cabal-version":"3.12.1.0","cabal-lib-version":"3.12.1.0","compiler-id":"ghc-9.12.2","os":"linux","arch":"x86_64","install-plan":[{"type":"pre-existing","id":"base-4.21.0.0-b7a5","pkg-name":"base","pkg-version":"4.21.0.0","depends":["ghc-internal-9.1202.0-7700","ghc-prim-0.13.0-00de"]},{"type":"pre-existing","id":"ghc-bignum-1.3-4dbb","pkg-name":"ghc-bignum","pkg-version":"1.3","depends":["ghc-prim-0.13.0-00de"]},{"type":"pre-existing","id":"ghc-internal-9.1202.0-7700","pkg-name":"ghc-internal","pkg-version":"9.1202.0","depends":["ghc-bignum-1.3-4dbb","ghc-prim-0.13.0-00de","rts-1.0.2"]},{"type":"pre-existing","id":"ghc-prim-0.13.0-00de","pkg-name":"ghc-prim","pkg-version":"0.13.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/hugin/Documents/haskell/hls/test/testdata/missingModuleTest/missingModule/."},"dist-dir":"/home/hugin/Documents/haskell/hls/test/testdata/missingModuleTest/missingModule/dist-newstyle/build/x86_64-linux/ghc-9.12.2/missingModule-0.1.0.0","build-info":"/home/hugin/Documents/haskell/hls/test/testdata/missingModuleTest/missingModule/dist-newstyle/build/x86_64-linux/ghc-9.12.2/missingModule-0.1.0.0/build-info.json","depends":["base-4.21.0.0-b7a5"],"exe-depends":[],"component-name":"lib"},{"type":"pre-existing","id":"rts-1.0.2","pkg-name":"rts","pkg-version":"1.0.2","depends":[]}]} diff --git a/test/testdata/schema/ghc912/default-config.golden.json b/test/testdata/schema/ghc912/default-config.golden.json new file mode 100644 --- /dev/null +++ b/test/testdata/schema/ghc912/default-config.golden.json @@ -0,0 +1,110 @@ +{ + "cabalFormattingProvider": "cabal-gild", + "checkParents": "CheckOnSave", + "checkProject": true, + "formattingProvider": "ormolu", + "maxCompletions": 40, + "plugin": { + "alternateNumberFormat": { + "globalOn": true + }, + "cabal": { + "codeActionsOn": true, + "completionOn": true, + "diagnosticsOn": true, + "hoverOn": true, + "symbolsOn": true + }, + "cabal-fmt": { + "config": { + "path": "cabal-fmt" + } + }, + "cabalHaskellIntegration": { + "globalOn": true + }, + "callHierarchy": { + "globalOn": true + }, + "changeTypeSignature": { + "globalOn": true + }, + "class": { + "codeActionsOn": true, + "codeLensOn": true + }, + "eval": { + "config": { + "diff": true, + "exception": false + }, + "globalOn": true + }, + "explicit-fields": { + "codeActionsOn": true, + "inlayHintsOn": true + }, + "explicit-fixity": { + "globalOn": true + }, + "ghcide-completions": { + "config": { + "autoExtendOn": true, + "snippetsOn": true + }, + "globalOn": true + }, + "ghcide-hover-and-symbols": { + "hoverOn": true, + "symbolsOn": true + }, + "ghcide-type-lenses": { + "config": { + "mode": "always" + }, + "globalOn": true + }, + "importLens": { + "codeActionsOn": true, + "codeLensOn": true, + "inlayHintsOn": true + }, + "moduleName": { + "globalOn": true + }, + "overloaded-record-dot": { + "globalOn": true + }, + "pragmas-completion": { + "globalOn": true + }, + "pragmas-disable": { + "globalOn": true + }, + "pragmas-suggest": { + "globalOn": true + }, + "qualifyImportedNames": { + "globalOn": true + }, + "semanticTokens": { + "config": { + "classMethodToken": "method", + "classToken": "class", + "dataConstructorToken": "enumMember", + "functionToken": "function", + "moduleToken": "namespace", + "operatorToken": "operator", + "patternSynonymToken": "macro", + "recordFieldToken": "property", + "typeConstructorToken": "enum", + "typeFamilyToken": "interface", + "typeSynonymToken": "type", + "typeVariableToken": "typeParameter", + "variableToken": "variable" + }, + "globalOn": false + } + }, + "sessionLoading": "singleComponent" +} diff --git a/test/testdata/schema/ghc912/vscode-extension-schema.golden.json b/test/testdata/schema/ghc912/vscode-extension-schema.golden.json new file mode 100644 --- /dev/null +++ b/test/testdata/schema/ghc912/vscode-extension-schema.golden.json @@ -0,0 +1,950 @@ +{ + "haskell.plugin.alternateNumberFormat.globalOn": { + "default": true, + "description": "Enables alternateNumberFormat plugin", + "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.codeActionsOn": { + "default": true, + "description": "Enables cabal code actions", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.cabal.completionOn": { + "default": true, + "description": "Enables cabal completions", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.cabal.diagnosticsOn": { + "default": true, + "description": "Enables cabal diagnostics", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.cabal.hoverOn": { + "default": true, + "description": "Enables cabal hover", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.cabal.symbolsOn": { + "default": true, + "description": "Enables cabal symbols", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.cabalHaskellIntegration.globalOn": { + "default": true, + "description": "Enables cabalHaskellIntegration plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.callHierarchy.globalOn": { + "default": true, + "description": "Enables callHierarchy plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.changeTypeSignature.globalOn": { + "default": true, + "description": "Enables changeTypeSignature plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.class.codeActionsOn": { + "default": true, + "description": "Enables class code actions", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.class.codeLensOn": { + "default": true, + "description": "Enables class code lenses", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.eval.config.diff": { + "default": true, + "markdownDescription": "Enable the diff output (WAS/NOW) of eval lenses", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.eval.config.exception": { + "default": false, + "markdownDescription": "Enable marking exceptions with `*** Exception:` similarly to doctest and GHCi.", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.eval.globalOn": { + "default": true, + "description": "Enables eval plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.explicit-fields.codeActionsOn": { + "default": true, + "description": "Enables explicit-fields code actions", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.explicit-fields.inlayHintsOn": { + "default": true, + "description": "Enables explicit-fields inlay hints", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.explicit-fixity.globalOn": { + "default": true, + "description": "Enables explicit-fixity plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-completions.config.autoExtendOn": { + "default": true, + "markdownDescription": "Extends the import list automatically when completing a out-of-scope identifier", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-completions.config.snippetsOn": { + "default": true, + "markdownDescription": "Inserts snippets when using code completions", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-completions.globalOn": { + "default": true, + "description": "Enables ghcide-completions plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-hover-and-symbols.hoverOn": { + "default": true, + "description": "Enables ghcide-hover-and-symbols hover", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-hover-and-symbols.symbolsOn": { + "default": true, + "description": "Enables ghcide-hover-and-symbols symbols", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.ghcide-type-lenses.config.mode": { + "default": "always", + "description": "Control how type lenses are shown", + "enum": [ + "always", + "exported", + "diagnostics" + ], + "enumDescriptions": [ + "Always displays type lenses of global bindings", + "Only display type lenses of exported global bindings", + "Follows error messages produced by GHC about missing signatures" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.ghcide-type-lenses.globalOn": { + "default": true, + "description": "Enables ghcide-type-lenses plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.importLens.codeActionsOn": { + "default": true, + "description": "Enables importLens code actions", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.importLens.codeLensOn": { + "default": true, + "description": "Enables importLens code lenses", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.importLens.inlayHintsOn": { + "default": true, + "description": "Enables importLens inlay hints", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.moduleName.globalOn": { + "default": true, + "description": "Enables moduleName plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.overloaded-record-dot.globalOn": { + "default": true, + "description": "Enables overloaded-record-dot plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.pragmas-completion.globalOn": { + "default": true, + "description": "Enables pragmas-completion plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.pragmas-disable.globalOn": { + "default": true, + "description": "Enables pragmas-disable plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.pragmas-suggest.globalOn": { + "default": true, + "description": "Enables pragmas-suggest plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.qualifyImportedNames.globalOn": { + "default": true, + "description": "Enables qualifyImportedNames plugin", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.semanticTokens.config.classMethodToken": { + "default": "method", + "description": "LSP semantic token type to use for typeclass methods", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.classToken": { + "default": "class", + "description": "LSP semantic token type to use for typeclasses", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.dataConstructorToken": { + "default": "enumMember", + "description": "LSP semantic token type to use for data constructors", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.functionToken": { + "default": "function", + "description": "LSP semantic token type to use for functions", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.moduleToken": { + "default": "namespace", + "description": "LSP semantic token type to use for modules", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.operatorToken": { + "default": "operator", + "description": "LSP semantic token type to use for operators", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.patternSynonymToken": { + "default": "macro", + "description": "LSP semantic token type to use for pattern synonyms", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.recordFieldToken": { + "default": "property", + "description": "LSP semantic token type to use for record fields", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.typeConstructorToken": { + "default": "enum", + "description": "LSP semantic token type to use for type constructors", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.typeFamilyToken": { + "default": "interface", + "description": "LSP semantic token type to use for type families", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.typeSynonymToken": { + "default": "type", + "description": "LSP semantic token type to use for type synonyms", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.typeVariableToken": { + "default": "typeParameter", + "description": "LSP semantic token type to use for type variables", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.config.variableToken": { + "default": "variable", + "description": "LSP semantic token type to use for variables", + "enum": [ + "namespace", + "type", + "class", + "enum", + "interface", + "struct", + "typeParameter", + "parameter", + "variable", + "property", + "enumMember", + "event", + "function", + "method", + "macro", + "keyword", + "modifier", + "comment", + "string", + "number", + "regexp", + "operator", + "decorator" + ], + "enumDescriptions": [ + "LSP Semantic Token Type: namespace", + "LSP Semantic Token Type: type", + "LSP Semantic Token Type: class", + "LSP Semantic Token Type: enum", + "LSP Semantic Token Type: interface", + "LSP Semantic Token Type: struct", + "LSP Semantic Token Type: typeParameter", + "LSP Semantic Token Type: parameter", + "LSP Semantic Token Type: variable", + "LSP Semantic Token Type: property", + "LSP Semantic Token Type: enumMember", + "LSP Semantic Token Type: event", + "LSP Semantic Token Type: function", + "LSP Semantic Token Type: method", + "LSP Semantic Token Type: macro", + "LSP Semantic Token Type: keyword", + "LSP Semantic Token Type: modifier", + "LSP Semantic Token Type: comment", + "LSP Semantic Token Type: string", + "LSP Semantic Token Type: number", + "LSP Semantic Token Type: regexp", + "LSP Semantic Token Type: operator", + "LSP Semantic Token Type: decorator" + ], + "scope": "resource", + "type": "string" + }, + "haskell.plugin.semanticTokens.globalOn": { + "default": false, + "description": "Enables semanticTokens plugin", + "scope": "resource", + "type": "boolean" + } +} diff --git a/test/testdata/schema/ghc92/default-config.golden.json b/test/testdata/schema/ghc92/default-config.golden.json deleted file mode 100644 --- a/test/testdata/schema/ghc92/default-config.golden.json +++ /dev/null @@ -1,153 +0,0 @@ -{ - "cabalFormattingProvider": "cabal-gild", - "checkParents": "CheckOnSave", - "checkProject": true, - "formattingProvider": "ormolu", - "maxCompletions": 40, - "plugin": { - "alternateNumberFormat": { - "globalOn": true - }, - "cabal": { - "codeActionsOn": true, - "completionOn": true, - "diagnosticsOn": true - }, - "cabal-fmt": { - "config": { - "path": "cabal-fmt" - } - }, - "cabal-gild": { - "config": { - "path": "cabal-gild" - } - }, - "callHierarchy": { - "globalOn": true - }, - "changeTypeSignature": { - "globalOn": true - }, - "class": { - "codeActionsOn": true, - "codeLensOn": true - }, - "eval": { - "config": { - "diff": true, - "exception": false - }, - "globalOn": true - }, - "explicit-fields": { - "globalOn": true - }, - "explicit-fixity": { - "globalOn": true - }, - "fourmolu": { - "config": { - "external": false, - "path": "fourmolu" - } - }, - "gadt": { - "globalOn": true - }, - "ghcide-code-actions-bindings": { - "globalOn": true - }, - "ghcide-code-actions-fill-holes": { - "globalOn": true - }, - "ghcide-code-actions-imports-exports": { - "globalOn": true - }, - "ghcide-code-actions-type-signatures": { - "globalOn": true - }, - "ghcide-completions": { - "config": { - "autoExtendOn": true, - "snippetsOn": true - }, - "globalOn": true - }, - "ghcide-hover-and-symbols": { - "hoverOn": true, - "symbolsOn": true - }, - "ghcide-type-lenses": { - "config": { - "mode": "always" - }, - "globalOn": true - }, - "hlint": { - "codeActionsOn": true, - "config": { - "flags": [] - }, - "diagnosticsOn": true - }, - "importLens": { - "codeActionsOn": true, - "codeLensOn": true - }, - "moduleName": { - "globalOn": true - }, - "ormolu": { - "config": { - "external": false - } - }, - "overloaded-record-dot": { - "globalOn": true - }, - "pragmas-completion": { - "globalOn": true - }, - "pragmas-disable": { - "globalOn": true - }, - "pragmas-suggest": { - "globalOn": true - }, - "qualifyImportedNames": { - "globalOn": true - }, - "rename": { - "config": { - "crossModule": false - }, - "globalOn": true - }, - "retrie": { - "globalOn": true - }, - "semanticTokens": { - "config": { - "classMethodToken": "method", - "classToken": "class", - "dataConstructorToken": "enumMember", - "functionToken": "function", - "moduleToken": "namespace", - "operatorToken": "operator", - "patternSynonymToken": "macro", - "recordFieldToken": "property", - "typeConstructorToken": "enum", - "typeFamilyToken": "interface", - "typeSynonymToken": "type", - "typeVariableToken": "typeParameter", - "variableToken": "variable" - }, - "globalOn": false - }, - "splice": { - "globalOn": true - } - }, - "sessionLoading": "singleComponent" -} diff --git a/test/testdata/schema/ghc92/vscode-extension-schema.golden.json b/test/testdata/schema/ghc92/vscode-extension-schema.golden.json deleted file mode 100644 --- a/test/testdata/schema/ghc92/vscode-extension-schema.golden.json +++ /dev/null @@ -1,1016 +0,0 @@ -{ - "haskell.plugin.alternateNumberFormat.globalOn": { - "default": true, - "description": "Enables alternateNumberFormat plugin", - "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", - "scope": "resource", - "type": "boolean" - }, - "haskell.plugin.cabal.completionOn": { - "default": true, - "description": "Enables cabal completions", - "scope": "resource", - "type": "boolean" - }, - "haskell.plugin.cabal.diagnosticsOn": { - "default": true, - "description": "Enables cabal diagnostics", - "scope": "resource", - "type": "boolean" - }, - "haskell.plugin.callHierarchy.globalOn": { - "default": true, - "description": "Enables callHierarchy plugin", - "scope": "resource", - "type": "boolean" - }, - "haskell.plugin.changeTypeSignature.globalOn": { - "default": true, - "description": "Enables changeTypeSignature plugin", - "scope": "resource", - "type": "boolean" - }, - "haskell.plugin.class.codeActionsOn": { - "default": true, - "description": "Enables class code actions", - "scope": "resource", - "type": "boolean" - }, - "haskell.plugin.class.codeLensOn": { - "default": true, - "description": "Enables class code lenses", - "scope": "resource", - "type": "boolean" - }, - "haskell.plugin.eval.config.diff": { - "default": true, - "markdownDescription": "Enable the diff output (WAS/NOW) of eval lenses", - "scope": "resource", - "type": "boolean" - }, - "haskell.plugin.eval.config.exception": { - "default": false, - "markdownDescription": "Enable marking exceptions with `*** Exception:` similarly to doctest and GHCi.", - "scope": "resource", - "type": "boolean" - }, - "haskell.plugin.eval.globalOn": { - "default": true, - "description": "Enables eval plugin", - "scope": "resource", - "type": "boolean" - }, - "haskell.plugin.explicit-fields.globalOn": { - "default": true, - "description": "Enables explicit-fields plugin", - "scope": "resource", - "type": "boolean" - }, - "haskell.plugin.explicit-fixity.globalOn": { - "default": true, - "description": "Enables explicit-fixity plugin", - "scope": "resource", - "type": "boolean" - }, - "haskell.plugin.fourmolu.config.external": { - "default": false, - "markdownDescription": "Call out to an external \"fourmolu\" executable, rather than using the bundled library.", - "scope": "resource", - "type": "boolean" - }, - "haskell.plugin.fourmolu.config.path": { - "default": "fourmolu", - "markdownDescription": "Set path to executable (for \"external\" mode).", - "scope": "resource", - "type": "string" - }, - "haskell.plugin.gadt.globalOn": { - "default": true, - "description": "Enables gadt plugin", - "scope": "resource", - "type": "boolean" - }, - "haskell.plugin.ghcide-code-actions-bindings.globalOn": { - "default": true, - "description": "Enables ghcide-code-actions-bindings plugin", - "scope": "resource", - "type": "boolean" - }, - "haskell.plugin.ghcide-code-actions-fill-holes.globalOn": { - "default": true, - "description": "Enables ghcide-code-actions-fill-holes plugin", - "scope": "resource", - "type": "boolean" - }, - "haskell.plugin.ghcide-code-actions-imports-exports.globalOn": { - "default": true, - "description": "Enables ghcide-code-actions-imports-exports plugin", - "scope": "resource", - "type": "boolean" - }, - "haskell.plugin.ghcide-code-actions-type-signatures.globalOn": { - "default": true, - "description": "Enables ghcide-code-actions-type-signatures plugin", - "scope": "resource", - "type": "boolean" - }, - "haskell.plugin.ghcide-completions.config.autoExtendOn": { - "default": true, - "markdownDescription": "Extends the import list automatically when completing a out-of-scope identifier", - "scope": "resource", - "type": "boolean" - }, - "haskell.plugin.ghcide-completions.config.snippetsOn": { - "default": true, - "markdownDescription": "Inserts snippets when using code completions", - "scope": "resource", - "type": "boolean" - }, - "haskell.plugin.ghcide-completions.globalOn": { - "default": true, - "description": "Enables ghcide-completions plugin", - "scope": "resource", - "type": "boolean" - }, - "haskell.plugin.ghcide-hover-and-symbols.hoverOn": { - "default": true, - "description": "Enables ghcide-hover-and-symbols hover", - "scope": "resource", - "type": "boolean" - }, - "haskell.plugin.ghcide-hover-and-symbols.symbolsOn": { - "default": true, - "description": "Enables ghcide-hover-and-symbols symbols", - "scope": "resource", - "type": "boolean" - }, - "haskell.plugin.ghcide-type-lenses.config.mode": { - "default": "always", - "description": "Control how type lenses are shown", - "enum": [ - "always", - "exported", - "diagnostics" - ], - "enumDescriptions": [ - "Always displays type lenses of global bindings", - "Only display type lenses of exported global bindings", - "Follows error messages produced by GHC about missing signatures" - ], - "scope": "resource", - "type": "string" - }, - "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" - }, - "haskell.plugin.importLens.codeActionsOn": { - "default": true, - "description": "Enables importLens code actions", - "scope": "resource", - "type": "boolean" - }, - "haskell.plugin.importLens.codeLensOn": { - "default": true, - "description": "Enables importLens code lenses", - "scope": "resource", - "type": "boolean" - }, - "haskell.plugin.moduleName.globalOn": { - "default": true, - "description": "Enables moduleName plugin", - "scope": "resource", - "type": "boolean" - }, - "haskell.plugin.ormolu.config.external": { - "default": false, - "markdownDescription": "Call out to an external \"ormolu\" executable, rather than using the bundled library", - "scope": "resource", - "type": "boolean" - }, - "haskell.plugin.overloaded-record-dot.globalOn": { - "default": true, - "description": "Enables overloaded-record-dot plugin", - "scope": "resource", - "type": "boolean" - }, - "haskell.plugin.pragmas-completion.globalOn": { - "default": true, - "description": "Enables pragmas-completion plugin", - "scope": "resource", - "type": "boolean" - }, - "haskell.plugin.pragmas-disable.globalOn": { - "default": true, - "description": "Enables pragmas-disable plugin", - "scope": "resource", - "type": "boolean" - }, - "haskell.plugin.pragmas-suggest.globalOn": { - "default": true, - "description": "Enables pragmas-suggest plugin", - "scope": "resource", - "type": "boolean" - }, - "haskell.plugin.qualifyImportedNames.globalOn": { - "default": true, - "description": "Enables qualifyImportedNames plugin", - "scope": "resource", - "type": "boolean" - }, - "haskell.plugin.rename.config.crossModule": { - "default": false, - "markdownDescription": "Enable experimental cross-module renaming", - "scope": "resource", - "type": "boolean" - }, - "haskell.plugin.rename.globalOn": { - "default": true, - "description": "Enables rename plugin", - "scope": "resource", - "type": "boolean" - }, - "haskell.plugin.retrie.globalOn": { - "default": true, - "description": "Enables retrie plugin", - "scope": "resource", - "type": "boolean" - }, - "haskell.plugin.semanticTokens.config.classMethodToken": { - "default": "method", - "description": "LSP semantic token type to use for typeclass methods", - "enum": [ - "namespace", - "type", - "class", - "enum", - "interface", - "struct", - "typeParameter", - "parameter", - "variable", - "property", - "enumMember", - "event", - "function", - "method", - "macro", - "keyword", - "modifier", - "comment", - "string", - "number", - "regexp", - "operator", - "decorator" - ], - "enumDescriptions": [ - "LSP Semantic Token Type: namespace", - "LSP Semantic Token Type: type", - "LSP Semantic Token Type: class", - "LSP Semantic Token Type: enum", - "LSP Semantic Token Type: interface", - "LSP Semantic Token Type: struct", - "LSP Semantic Token Type: typeParameter", - "LSP Semantic Token Type: parameter", - "LSP Semantic Token Type: variable", - "LSP Semantic Token Type: property", - "LSP Semantic Token Type: enumMember", - "LSP Semantic Token Type: event", - "LSP Semantic Token Type: function", - "LSP Semantic Token Type: method", - "LSP Semantic Token Type: macro", - "LSP Semantic Token Type: keyword", - "LSP Semantic Token Type: modifier", - "LSP Semantic Token Type: comment", - "LSP Semantic Token Type: string", - "LSP Semantic Token Type: number", - "LSP Semantic Token Type: regexp", - "LSP Semantic Token Type: operator", - "LSP Semantic Token Type: decorator" - ], - "scope": "resource", - "type": "string" - }, - "haskell.plugin.semanticTokens.config.classToken": { - "default": "class", - "description": "LSP semantic token type to use for typeclasses", - "enum": [ - "namespace", - "type", - "class", - "enum", - "interface", - "struct", - "typeParameter", - "parameter", - "variable", - "property", - "enumMember", - "event", - "function", - "method", - "macro", - "keyword", - "modifier", - "comment", - "string", - "number", - "regexp", - "operator", - "decorator" - ], - "enumDescriptions": [ - "LSP Semantic Token Type: namespace", - "LSP Semantic Token Type: type", - "LSP Semantic Token Type: class", - "LSP Semantic Token Type: enum", - "LSP Semantic Token Type: interface", - "LSP Semantic Token Type: struct", - "LSP Semantic Token Type: typeParameter", - "LSP Semantic Token Type: parameter", - "LSP Semantic Token Type: variable", - "LSP Semantic Token Type: property", - "LSP Semantic Token Type: enumMember", - "LSP Semantic Token Type: event", - "LSP Semantic Token Type: function", - "LSP Semantic Token Type: method", - "LSP Semantic Token Type: macro", - "LSP Semantic Token Type: keyword", - "LSP Semantic Token Type: modifier", - "LSP Semantic Token Type: comment", - "LSP Semantic Token Type: string", - "LSP Semantic Token Type: number", - "LSP Semantic Token Type: regexp", - "LSP Semantic Token Type: operator", - "LSP Semantic Token Type: decorator" - ], - "scope": "resource", - "type": "string" - }, - "haskell.plugin.semanticTokens.config.dataConstructorToken": { - "default": "enumMember", - "description": "LSP semantic token type to use for data constructors", - "enum": [ - "namespace", - "type", - "class", - "enum", - "interface", - "struct", - "typeParameter", - "parameter", - "variable", - "property", - "enumMember", - "event", - "function", - "method", - "macro", - "keyword", - "modifier", - "comment", - "string", - "number", - "regexp", - "operator", - "decorator" - ], - "enumDescriptions": [ - "LSP Semantic Token Type: namespace", - "LSP Semantic Token Type: type", - "LSP Semantic Token Type: class", - "LSP Semantic Token Type: enum", - "LSP Semantic Token Type: interface", - "LSP Semantic Token Type: struct", - "LSP Semantic Token Type: typeParameter", - "LSP Semantic Token Type: parameter", - "LSP Semantic Token Type: variable", - "LSP Semantic Token Type: property", - "LSP Semantic Token Type: enumMember", - "LSP Semantic Token Type: event", - "LSP Semantic Token Type: function", - "LSP Semantic Token Type: method", - "LSP Semantic Token Type: macro", - "LSP Semantic Token Type: keyword", - "LSP Semantic Token Type: modifier", - "LSP Semantic Token Type: comment", - "LSP Semantic Token Type: string", - "LSP Semantic Token Type: number", - "LSP Semantic Token Type: regexp", - "LSP Semantic Token Type: operator", - "LSP Semantic Token Type: decorator" - ], - "scope": "resource", - "type": "string" - }, - "haskell.plugin.semanticTokens.config.functionToken": { - "default": "function", - "description": "LSP semantic token type to use for functions", - "enum": [ - "namespace", - "type", - "class", - "enum", - "interface", - "struct", - "typeParameter", - "parameter", - "variable", - "property", - "enumMember", - "event", - "function", - "method", - "macro", - "keyword", - "modifier", - "comment", - "string", - "number", - "regexp", - "operator", - "decorator" - ], - "enumDescriptions": [ - "LSP Semantic Token Type: namespace", - "LSP Semantic Token Type: type", - "LSP Semantic Token Type: class", - "LSP Semantic Token Type: enum", - "LSP Semantic Token Type: interface", - "LSP Semantic Token Type: struct", - "LSP Semantic Token Type: typeParameter", - "LSP Semantic Token Type: parameter", - "LSP Semantic Token Type: variable", - "LSP Semantic Token Type: property", - "LSP Semantic Token Type: enumMember", - "LSP Semantic Token Type: event", - "LSP Semantic Token Type: function", - "LSP Semantic Token Type: method", - "LSP Semantic Token Type: macro", - "LSP Semantic Token Type: keyword", - "LSP Semantic Token Type: modifier", - "LSP Semantic Token Type: comment", - "LSP Semantic Token Type: string", - "LSP Semantic Token Type: number", - "LSP Semantic Token Type: regexp", - "LSP Semantic Token Type: operator", - "LSP Semantic Token Type: decorator" - ], - "scope": "resource", - "type": "string" - }, - "haskell.plugin.semanticTokens.config.moduleToken": { - "default": "namespace", - "description": "LSP semantic token type to use for modules", - "enum": [ - "namespace", - "type", - "class", - "enum", - "interface", - "struct", - "typeParameter", - "parameter", - "variable", - "property", - "enumMember", - "event", - "function", - "method", - "macro", - "keyword", - "modifier", - "comment", - "string", - "number", - "regexp", - "operator", - "decorator" - ], - "enumDescriptions": [ - "LSP Semantic Token Type: namespace", - "LSP Semantic Token Type: type", - "LSP Semantic Token Type: class", - "LSP Semantic Token Type: enum", - "LSP Semantic Token Type: interface", - "LSP Semantic Token Type: struct", - "LSP Semantic Token Type: typeParameter", - "LSP Semantic Token Type: parameter", - "LSP Semantic Token Type: variable", - "LSP Semantic Token Type: property", - "LSP Semantic Token Type: enumMember", - "LSP Semantic Token Type: event", - "LSP Semantic Token Type: function", - "LSP Semantic Token Type: method", - "LSP Semantic Token Type: macro", - "LSP Semantic Token Type: keyword", - "LSP Semantic Token Type: modifier", - "LSP Semantic Token Type: comment", - "LSP Semantic Token Type: string", - "LSP Semantic Token Type: number", - "LSP Semantic Token Type: regexp", - "LSP Semantic Token Type: operator", - "LSP Semantic Token Type: decorator" - ], - "scope": "resource", - "type": "string" - }, - "haskell.plugin.semanticTokens.config.operatorToken": { - "default": "operator", - "description": "LSP semantic token type to use for operators", - "enum": [ - "namespace", - "type", - "class", - "enum", - "interface", - "struct", - "typeParameter", - "parameter", - "variable", - "property", - "enumMember", - "event", - "function", - "method", - "macro", - "keyword", - "modifier", - "comment", - "string", - "number", - "regexp", - "operator", - "decorator" - ], - "enumDescriptions": [ - "LSP Semantic Token Type: namespace", - "LSP Semantic Token Type: type", - "LSP Semantic Token Type: class", - "LSP Semantic Token Type: enum", - "LSP Semantic Token Type: interface", - "LSP Semantic Token Type: struct", - "LSP Semantic Token Type: typeParameter", - "LSP Semantic Token Type: parameter", - "LSP Semantic Token Type: variable", - "LSP Semantic Token Type: property", - "LSP Semantic Token Type: enumMember", - "LSP Semantic Token Type: event", - "LSP Semantic Token Type: function", - "LSP Semantic Token Type: method", - "LSP Semantic Token Type: macro", - "LSP Semantic Token Type: keyword", - "LSP Semantic Token Type: modifier", - "LSP Semantic Token Type: comment", - "LSP Semantic Token Type: string", - "LSP Semantic Token Type: number", - "LSP Semantic Token Type: regexp", - "LSP Semantic Token Type: operator", - "LSP Semantic Token Type: decorator" - ], - "scope": "resource", - "type": "string" - }, - "haskell.plugin.semanticTokens.config.patternSynonymToken": { - "default": "macro", - "description": "LSP semantic token type to use for pattern synonyms", - "enum": [ - "namespace", - "type", - "class", - "enum", - "interface", - "struct", - "typeParameter", - "parameter", - "variable", - "property", - "enumMember", - "event", - "function", - "method", - "macro", - "keyword", - "modifier", - "comment", - "string", - "number", - "regexp", - "operator", - "decorator" - ], - "enumDescriptions": [ - "LSP Semantic Token Type: namespace", - "LSP Semantic Token Type: type", - "LSP Semantic Token Type: class", - "LSP Semantic Token Type: enum", - "LSP Semantic Token Type: interface", - "LSP Semantic Token Type: struct", - "LSP Semantic Token Type: typeParameter", - "LSP Semantic Token Type: parameter", - "LSP Semantic Token Type: variable", - "LSP Semantic Token Type: property", - "LSP Semantic Token Type: enumMember", - "LSP Semantic Token Type: event", - "LSP Semantic Token Type: function", - "LSP Semantic Token Type: method", - "LSP Semantic Token Type: macro", - "LSP Semantic Token Type: keyword", - "LSP Semantic Token Type: modifier", - "LSP Semantic Token Type: comment", - "LSP Semantic Token Type: string", - "LSP Semantic Token Type: number", - "LSP Semantic Token Type: regexp", - "LSP Semantic Token Type: operator", - "LSP Semantic Token Type: decorator" - ], - "scope": "resource", - "type": "string" - }, - "haskell.plugin.semanticTokens.config.recordFieldToken": { - "default": "property", - "description": "LSP semantic token type to use for record fields", - "enum": [ - "namespace", - "type", - "class", - "enum", - "interface", - "struct", - "typeParameter", - "parameter", - "variable", - "property", - "enumMember", - "event", - "function", - "method", - "macro", - "keyword", - "modifier", - "comment", - "string", - "number", - "regexp", - "operator", - "decorator" - ], - "enumDescriptions": [ - "LSP Semantic Token Type: namespace", - "LSP Semantic Token Type: type", - "LSP Semantic Token Type: class", - "LSP Semantic Token Type: enum", - "LSP Semantic Token Type: interface", - "LSP Semantic Token Type: struct", - "LSP Semantic Token Type: typeParameter", - "LSP Semantic Token Type: parameter", - "LSP Semantic Token Type: variable", - "LSP Semantic Token Type: property", - "LSP Semantic Token Type: enumMember", - "LSP Semantic Token Type: event", - "LSP Semantic Token Type: function", - "LSP Semantic Token Type: method", - "LSP Semantic Token Type: macro", - "LSP Semantic Token Type: keyword", - "LSP Semantic Token Type: modifier", - "LSP Semantic Token Type: comment", - "LSP Semantic Token Type: string", - "LSP Semantic Token Type: number", - "LSP Semantic Token Type: regexp", - "LSP Semantic Token Type: operator", - "LSP Semantic Token Type: decorator" - ], - "scope": "resource", - "type": "string" - }, - "haskell.plugin.semanticTokens.config.typeConstructorToken": { - "default": "enum", - "description": "LSP semantic token type to use for type constructors", - "enum": [ - "namespace", - "type", - "class", - "enum", - "interface", - "struct", - "typeParameter", - "parameter", - "variable", - "property", - "enumMember", - "event", - "function", - "method", - "macro", - "keyword", - "modifier", - "comment", - "string", - "number", - "regexp", - "operator", - "decorator" - ], - "enumDescriptions": [ - "LSP Semantic Token Type: namespace", - "LSP Semantic Token Type: type", - "LSP Semantic Token Type: class", - "LSP Semantic Token Type: enum", - "LSP Semantic Token Type: interface", - "LSP Semantic Token Type: struct", - "LSP Semantic Token Type: typeParameter", - "LSP Semantic Token Type: parameter", - "LSP Semantic Token Type: variable", - "LSP Semantic Token Type: property", - "LSP Semantic Token Type: enumMember", - "LSP Semantic Token Type: event", - "LSP Semantic Token Type: function", - "LSP Semantic Token Type: method", - "LSP Semantic Token Type: macro", - "LSP Semantic Token Type: keyword", - "LSP Semantic Token Type: modifier", - "LSP Semantic Token Type: comment", - "LSP Semantic Token Type: string", - "LSP Semantic Token Type: number", - "LSP Semantic Token Type: regexp", - "LSP Semantic Token Type: operator", - "LSP Semantic Token Type: decorator" - ], - "scope": "resource", - "type": "string" - }, - "haskell.plugin.semanticTokens.config.typeFamilyToken": { - "default": "interface", - "description": "LSP semantic token type to use for type families", - "enum": [ - "namespace", - "type", - "class", - "enum", - "interface", - "struct", - "typeParameter", - "parameter", - "variable", - "property", - "enumMember", - "event", - "function", - "method", - "macro", - "keyword", - "modifier", - "comment", - "string", - "number", - "regexp", - "operator", - "decorator" - ], - "enumDescriptions": [ - "LSP Semantic Token Type: namespace", - "LSP Semantic Token Type: type", - "LSP Semantic Token Type: class", - "LSP Semantic Token Type: enum", - "LSP Semantic Token Type: interface", - "LSP Semantic Token Type: struct", - "LSP Semantic Token Type: typeParameter", - "LSP Semantic Token Type: parameter", - "LSP Semantic Token Type: variable", - "LSP Semantic Token Type: property", - "LSP Semantic Token Type: enumMember", - "LSP Semantic Token Type: event", - "LSP Semantic Token Type: function", - "LSP Semantic Token Type: method", - "LSP Semantic Token Type: macro", - "LSP Semantic Token Type: keyword", - "LSP Semantic Token Type: modifier", - "LSP Semantic Token Type: comment", - "LSP Semantic Token Type: string", - "LSP Semantic Token Type: number", - "LSP Semantic Token Type: regexp", - "LSP Semantic Token Type: operator", - "LSP Semantic Token Type: decorator" - ], - "scope": "resource", - "type": "string" - }, - "haskell.plugin.semanticTokens.config.typeSynonymToken": { - "default": "type", - "description": "LSP semantic token type to use for type synonyms", - "enum": [ - "namespace", - "type", - "class", - "enum", - "interface", - "struct", - "typeParameter", - "parameter", - "variable", - "property", - "enumMember", - "event", - "function", - "method", - "macro", - "keyword", - "modifier", - "comment", - "string", - "number", - "regexp", - "operator", - "decorator" - ], - "enumDescriptions": [ - "LSP Semantic Token Type: namespace", - "LSP Semantic Token Type: type", - "LSP Semantic Token Type: class", - "LSP Semantic Token Type: enum", - "LSP Semantic Token Type: interface", - "LSP Semantic Token Type: struct", - "LSP Semantic Token Type: typeParameter", - "LSP Semantic Token Type: parameter", - "LSP Semantic Token Type: variable", - "LSP Semantic Token Type: property", - "LSP Semantic Token Type: enumMember", - "LSP Semantic Token Type: event", - "LSP Semantic Token Type: function", - "LSP Semantic Token Type: method", - "LSP Semantic Token Type: macro", - "LSP Semantic Token Type: keyword", - "LSP Semantic Token Type: modifier", - "LSP Semantic Token Type: comment", - "LSP Semantic Token Type: string", - "LSP Semantic Token Type: number", - "LSP Semantic Token Type: regexp", - "LSP Semantic Token Type: operator", - "LSP Semantic Token Type: decorator" - ], - "scope": "resource", - "type": "string" - }, - "haskell.plugin.semanticTokens.config.typeVariableToken": { - "default": "typeParameter", - "description": "LSP semantic token type to use for type variables", - "enum": [ - "namespace", - "type", - "class", - "enum", - "interface", - "struct", - "typeParameter", - "parameter", - "variable", - "property", - "enumMember", - "event", - "function", - "method", - "macro", - "keyword", - "modifier", - "comment", - "string", - "number", - "regexp", - "operator", - "decorator" - ], - "enumDescriptions": [ - "LSP Semantic Token Type: namespace", - "LSP Semantic Token Type: type", - "LSP Semantic Token Type: class", - "LSP Semantic Token Type: enum", - "LSP Semantic Token Type: interface", - "LSP Semantic Token Type: struct", - "LSP Semantic Token Type: typeParameter", - "LSP Semantic Token Type: parameter", - "LSP Semantic Token Type: variable", - "LSP Semantic Token Type: property", - "LSP Semantic Token Type: enumMember", - "LSP Semantic Token Type: event", - "LSP Semantic Token Type: function", - "LSP Semantic Token Type: method", - "LSP Semantic Token Type: macro", - "LSP Semantic Token Type: keyword", - "LSP Semantic Token Type: modifier", - "LSP Semantic Token Type: comment", - "LSP Semantic Token Type: string", - "LSP Semantic Token Type: number", - "LSP Semantic Token Type: regexp", - "LSP Semantic Token Type: operator", - "LSP Semantic Token Type: decorator" - ], - "scope": "resource", - "type": "string" - }, - "haskell.plugin.semanticTokens.config.variableToken": { - "default": "variable", - "description": "LSP semantic token type to use for variables", - "enum": [ - "namespace", - "type", - "class", - "enum", - "interface", - "struct", - "typeParameter", - "parameter", - "variable", - "property", - "enumMember", - "event", - "function", - "method", - "macro", - "keyword", - "modifier", - "comment", - "string", - "number", - "regexp", - "operator", - "decorator" - ], - "enumDescriptions": [ - "LSP Semantic Token Type: namespace", - "LSP Semantic Token Type: type", - "LSP Semantic Token Type: class", - "LSP Semantic Token Type: enum", - "LSP Semantic Token Type: interface", - "LSP Semantic Token Type: struct", - "LSP Semantic Token Type: typeParameter", - "LSP Semantic Token Type: parameter", - "LSP Semantic Token Type: variable", - "LSP Semantic Token Type: property", - "LSP Semantic Token Type: enumMember", - "LSP Semantic Token Type: event", - "LSP Semantic Token Type: function", - "LSP Semantic Token Type: method", - "LSP Semantic Token Type: macro", - "LSP Semantic Token Type: keyword", - "LSP Semantic Token Type: modifier", - "LSP Semantic Token Type: comment", - "LSP Semantic Token Type: string", - "LSP Semantic Token Type: number", - "LSP Semantic Token Type: regexp", - "LSP Semantic Token Type: operator", - "LSP Semantic Token Type: decorator" - ], - "scope": "resource", - "type": "string" - }, - "haskell.plugin.semanticTokens.globalOn": { - "default": false, - "description": "Enables semanticTokens plugin", - "scope": "resource", - "type": "boolean" - }, - "haskell.plugin.splice.globalOn": { - "default": true, - "description": "Enables splice plugin", - "scope": "resource", - "type": "boolean" - } -} diff --git a/test/testdata/schema/ghc94/default-config.golden.json b/test/testdata/schema/ghc94/default-config.golden.json --- a/test/testdata/schema/ghc94/default-config.golden.json +++ b/test/testdata/schema/ghc94/default-config.golden.json @@ -11,7 +11,9 @@ "cabal": { "codeActionsOn": true, "completionOn": true, - "diagnosticsOn": true + "diagnosticsOn": true, + "hoverOn": true, + "symbolsOn": true }, "cabal-fmt": { "config": { @@ -23,6 +25,9 @@ "path": "cabal-gild" } }, + "cabalHaskellIntegration": { + "globalOn": true + }, "callHierarchy": { "globalOn": true }, @@ -41,7 +46,8 @@ "globalOn": true }, "explicit-fields": { - "globalOn": true + "codeActionsOn": true, + "inlayHintsOn": true }, "explicit-fixity": { "globalOn": true @@ -93,7 +99,8 @@ }, "importLens": { "codeActionsOn": true, - "codeLensOn": true + "codeLensOn": true, + "inlayHintsOn": true }, "moduleName": { "globalOn": true diff --git a/test/testdata/schema/ghc94/vscode-extension-schema.golden.json b/test/testdata/schema/ghc94/vscode-extension-schema.golden.json --- a/test/testdata/schema/ghc94/vscode-extension-schema.golden.json +++ b/test/testdata/schema/ghc94/vscode-extension-schema.golden.json @@ -35,6 +35,24 @@ "scope": "resource", "type": "boolean" }, + "haskell.plugin.cabal.hoverOn": { + "default": true, + "description": "Enables cabal hover", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.cabal.symbolsOn": { + "default": true, + "description": "Enables cabal symbols", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.cabalHaskellIntegration.globalOn": { + "default": true, + "description": "Enables cabalHaskellIntegration plugin", + "scope": "resource", + "type": "boolean" + }, "haskell.plugin.callHierarchy.globalOn": { "default": true, "description": "Enables callHierarchy plugin", @@ -77,12 +95,18 @@ "scope": "resource", "type": "boolean" }, - "haskell.plugin.explicit-fields.globalOn": { + "haskell.plugin.explicit-fields.codeActionsOn": { "default": true, - "description": "Enables explicit-fields plugin", + "description": "Enables explicit-fields code actions", "scope": "resource", "type": "boolean" }, + "haskell.plugin.explicit-fields.inlayHintsOn": { + "default": true, + "description": "Enables explicit-fields inlay hints", + "scope": "resource", + "type": "boolean" + }, "haskell.plugin.explicit-fixity.globalOn": { "default": true, "description": "Enables explicit-fixity plugin", @@ -210,6 +234,12 @@ "haskell.plugin.importLens.codeLensOn": { "default": true, "description": "Enables importLens code lenses", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.importLens.inlayHintsOn": { + "default": true, + "description": "Enables importLens inlay hints", "scope": "resource", "type": "boolean" }, diff --git a/test/testdata/schema/ghc96/default-config.golden.json b/test/testdata/schema/ghc96/default-config.golden.json --- a/test/testdata/schema/ghc96/default-config.golden.json +++ b/test/testdata/schema/ghc96/default-config.golden.json @@ -11,7 +11,9 @@ "cabal": { "codeActionsOn": true, "completionOn": true, - "diagnosticsOn": true + "diagnosticsOn": true, + "hoverOn": true, + "symbolsOn": true }, "cabal-fmt": { "config": { @@ -23,6 +25,9 @@ "path": "cabal-gild" } }, + "cabalHaskellIntegration": { + "globalOn": true + }, "callHierarchy": { "globalOn": true }, @@ -41,7 +46,8 @@ "globalOn": true }, "explicit-fields": { - "globalOn": true + "codeActionsOn": true, + "inlayHintsOn": true }, "explicit-fixity": { "globalOn": true @@ -93,7 +99,8 @@ }, "importLens": { "codeActionsOn": true, - "codeLensOn": true + "codeLensOn": true, + "inlayHintsOn": true }, "moduleName": { "globalOn": true diff --git a/test/testdata/schema/ghc96/vscode-extension-schema.golden.json b/test/testdata/schema/ghc96/vscode-extension-schema.golden.json --- a/test/testdata/schema/ghc96/vscode-extension-schema.golden.json +++ b/test/testdata/schema/ghc96/vscode-extension-schema.golden.json @@ -35,6 +35,24 @@ "scope": "resource", "type": "boolean" }, + "haskell.plugin.cabal.hoverOn": { + "default": true, + "description": "Enables cabal hover", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.cabal.symbolsOn": { + "default": true, + "description": "Enables cabal symbols", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.cabalHaskellIntegration.globalOn": { + "default": true, + "description": "Enables cabalHaskellIntegration plugin", + "scope": "resource", + "type": "boolean" + }, "haskell.plugin.callHierarchy.globalOn": { "default": true, "description": "Enables callHierarchy plugin", @@ -77,12 +95,18 @@ "scope": "resource", "type": "boolean" }, - "haskell.plugin.explicit-fields.globalOn": { + "haskell.plugin.explicit-fields.codeActionsOn": { "default": true, - "description": "Enables explicit-fields plugin", + "description": "Enables explicit-fields code actions", "scope": "resource", "type": "boolean" }, + "haskell.plugin.explicit-fields.inlayHintsOn": { + "default": true, + "description": "Enables explicit-fields inlay hints", + "scope": "resource", + "type": "boolean" + }, "haskell.plugin.explicit-fixity.globalOn": { "default": true, "description": "Enables explicit-fixity plugin", @@ -210,6 +234,12 @@ "haskell.plugin.importLens.codeLensOn": { "default": true, "description": "Enables importLens code lenses", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.importLens.inlayHintsOn": { + "default": true, + "description": "Enables importLens inlay hints", "scope": "resource", "type": "boolean" }, diff --git a/test/testdata/schema/ghc98/default-config.golden.json b/test/testdata/schema/ghc98/default-config.golden.json --- a/test/testdata/schema/ghc98/default-config.golden.json +++ b/test/testdata/schema/ghc98/default-config.golden.json @@ -11,7 +11,9 @@ "cabal": { "codeActionsOn": true, "completionOn": true, - "diagnosticsOn": true + "diagnosticsOn": true, + "hoverOn": true, + "symbolsOn": true }, "cabal-fmt": { "config": { @@ -23,6 +25,9 @@ "path": "cabal-gild" } }, + "cabalHaskellIntegration": { + "globalOn": true + }, "callHierarchy": { "globalOn": true }, @@ -41,7 +46,8 @@ "globalOn": true }, "explicit-fields": { - "globalOn": true + "codeActionsOn": true, + "inlayHintsOn": true }, "explicit-fixity": { "globalOn": true @@ -93,7 +99,8 @@ }, "importLens": { "codeActionsOn": true, - "codeLensOn": true + "codeLensOn": true, + "inlayHintsOn": true }, "moduleName": { "globalOn": true diff --git a/test/testdata/schema/ghc98/vscode-extension-schema.golden.json b/test/testdata/schema/ghc98/vscode-extension-schema.golden.json --- a/test/testdata/schema/ghc98/vscode-extension-schema.golden.json +++ b/test/testdata/schema/ghc98/vscode-extension-schema.golden.json @@ -35,6 +35,24 @@ "scope": "resource", "type": "boolean" }, + "haskell.plugin.cabal.hoverOn": { + "default": true, + "description": "Enables cabal hover", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.cabal.symbolsOn": { + "default": true, + "description": "Enables cabal symbols", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.cabalHaskellIntegration.globalOn": { + "default": true, + "description": "Enables cabalHaskellIntegration plugin", + "scope": "resource", + "type": "boolean" + }, "haskell.plugin.callHierarchy.globalOn": { "default": true, "description": "Enables callHierarchy plugin", @@ -77,12 +95,18 @@ "scope": "resource", "type": "boolean" }, - "haskell.plugin.explicit-fields.globalOn": { + "haskell.plugin.explicit-fields.codeActionsOn": { "default": true, - "description": "Enables explicit-fields plugin", + "description": "Enables explicit-fields code actions", "scope": "resource", "type": "boolean" }, + "haskell.plugin.explicit-fields.inlayHintsOn": { + "default": true, + "description": "Enables explicit-fields inlay hints", + "scope": "resource", + "type": "boolean" + }, "haskell.plugin.explicit-fixity.globalOn": { "default": true, "description": "Enables explicit-fixity plugin", @@ -210,6 +234,12 @@ "haskell.plugin.importLens.codeLensOn": { "default": true, "description": "Enables importLens code lenses", + "scope": "resource", + "type": "boolean" + }, + "haskell.plugin.importLens.inlayHintsOn": { + "default": true, + "description": "Enables importLens inlay hints", "scope": "resource", "type": "boolean" },