packages feed

haskell-language-server 2.9.0.1 → 2.10.0.0

raw patch · 313 files changed

+11335/−6891 lines, 313 filesdep +Cabaldep +cabal-adddep +prettydep ~basedep ~extradep ~ghc-exactprintnew-component:exe:ghcide-test-preprocessor

Dependencies added: Cabal, cabal-add, pretty

Dependency ranges changed: base, extra, ghc-exactprint, ghcide, hls-graph, hls-plugin-api, hls-test-utils, lsp, lsp-types

Files

ChangeLog.md view
@@ -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
exe/Wrapper.hs view
@@ -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
ghcide-bench/src/Experiments.hs view
@@ -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
+ ghcide-test/data/TH/THA.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}+module THA where+import Language.Haskell.TH++th_a :: DecsQ+th_a = [d| a = () |]
+ ghcide-test/data/TH/THB.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE TemplateHaskell #-}+module THB where+import THA++$th_a
+ ghcide-test/data/TH/THC.hs view
@@ -0,0 +1,5 @@+module THC where+import THB++c ::()+c = a
+ ghcide-test/data/TH/hie.yaml view
@@ -0,0 +1,1 @@+cradle: {direct: {arguments: ["-Wmissing-signatures", "-package template-haskell", "THA", "THB", "THC"]}}
+ ghcide-test/data/THCoreFile/THA.hs view
@@ -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')
+ ghcide-test/data/THCoreFile/THB.hs view
@@ -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)
+ ghcide-test/data/THCoreFile/THC.hs view
@@ -0,0 +1,5 @@+module THC where+import THB++c ::()+c = a
+ ghcide-test/data/THCoreFile/hie.yaml view
@@ -0,0 +1,1 @@+cradle: {direct: {arguments: ["-package template-haskell", "THA", "THB", "THC"]}}
+ ghcide-test/data/THLoading/A.hs view
@@ -0,0 +1,5 @@+module A where+import B (bar)++foo :: ()+foo = bar
+ ghcide-test/data/THLoading/B.hs view
@@ -0,0 +1,4 @@+module B where++bar :: ()+bar = ()
+ ghcide-test/data/THLoading/THA.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE TemplateHaskell #-}+module THA where+import Language.Haskell.TH+import A (foo)++th_a :: DecsQ+th_a = [d| a = foo |]
+ ghcide-test/data/THLoading/THB.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE TemplateHaskell #-}+module THB where+import THA++$th_a
+ ghcide-test/data/THLoading/hie.yaml view
@@ -0,0 +1,1 @@+cradle: {direct: {arguments: ["-package template-haskell", "THA", "THB", "A", "B"]}}
+ ghcide-test/data/THNewName/A.hs view
@@ -0,0 +1,6 @@+module A (template) where++import Language.Haskell.TH++template :: DecsQ+template = (\consA -> [DataD [] (mkName "A") [] Nothing [NormalC consA []] []]) <$> newName "A"
+ ghcide-test/data/THNewName/B.hs view
@@ -0,0 +1,5 @@+module B(A(A)) where++import A++template
+ ghcide-test/data/THNewName/C.hs view
@@ -0,0 +1,4 @@+module C where+import B++a = A
+ ghcide-test/data/THNewName/hie.yaml view
@@ -0,0 +1,1 @@+cradle: {direct: {arguments: ["-XTemplateHaskell","-Wmissing-signatures","A", "B", "C"]}}
+ ghcide-test/data/THUnboxed/THA.hs view
@@ -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 = () |]
+ ghcide-test/data/THUnboxed/THB.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE TemplateHaskell #-}+module THB where+import THA++$th_a
+ ghcide-test/data/THUnboxed/THC.hs view
@@ -0,0 +1,5 @@+module THC where+import THB++c ::()+c = a
+ ghcide-test/data/THUnboxed/hie.yaml view
@@ -0,0 +1,1 @@+cradle: {direct: {arguments: ["-Wmissing-signatures", "-package template-haskell", "THA", "THB", "THC"]}}
+ ghcide-test/data/boot/A.hs view
@@ -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
+ ghcide-test/data/boot/A.hs-boot view
@@ -0,0 +1,3 @@+module A where+newtype TA = MkTA Int+instance Eq TA
+ ghcide-test/data/boot/B.hs view
@@ -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
+ ghcide-test/data/boot/C.hs view
@@ -0,0 +1,8 @@+module C where++import B+import A hiding (MkTA(..))++x = MkTA+y = MkTB+z = f
+ ghcide-test/data/boot/hie.yaml view
@@ -0,0 +1,1 @@+cradle: {direct: {arguments: ["A.hs", "A.hs-boot", "B.hs", "C.hs"]}}
+ ghcide-test/data/boot2/A.hs view
@@ -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
+ ghcide-test/data/boot2/B.hs view
@@ -0,0 +1,8 @@+module B where++import D++data B = B++instance Show B where+  show B = "B"
+ ghcide-test/data/boot2/B.hs-boot view
@@ -0,0 +1,3 @@+module B where++data B = B
+ ghcide-test/data/boot2/C.hs view
@@ -0,0 +1,3 @@+module C where++import B
+ ghcide-test/data/boot2/D.hs view
@@ -0,0 +1,3 @@+module D where++import {-# SOURCE #-} B
+ ghcide-test/data/boot2/E.hs view
@@ -0,0 +1,3 @@+module E(B(B)) where++import {-# SOURCE #-} B
+ ghcide-test/data/boot2/hie.yaml view
@@ -0,0 +1,1 @@+cradle: {direct: {arguments: ["A.hs", "B.hs-boot", "B.hs", "C.hs", "D.hs", "E.hs"]}}
+ ghcide-test/data/cabal-exe/a/a.cabal view
@@ -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
+ ghcide-test/data/cabal-exe/a/src/Main.hs view
@@ -0,0 +1,3 @@+module Main where++main = putStrLn "Hello, Haskell!"
+ ghcide-test/data/cabal-exe/cabal.project view
@@ -0,0 +1,1 @@+packages: ./a
+ ghcide-test/data/cabal-exe/hie.yaml view
@@ -0,0 +1,3 @@+cradle:+  cabal:+    component: "exe:a"
+ ghcide-test/data/hover/Bar.hs view
@@ -0,0 +1,4 @@+module Bar (Bar(..)) where++-- | Bar Haddock+data Bar = Bar
+ ghcide-test/data/hover/Foo.hs view
@@ -0,0 +1,6 @@+module Foo (Bar, foo) where++import Bar++-- | foo Haddock+foo = Bar
+ ghcide-test/data/hover/GotoHover.hs view
@@ -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)
+ ghcide-test/data/hover/GotoImplementation.hs view
@@ -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
+ ghcide-test/data/hover/RecordDotSyntax.hs view
@@ -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
+ ghcide-test/data/hover/hie.yaml view
@@ -0,0 +1,1 @@+cradle: {direct: {arguments: ["Foo", "Bar", "GotoHover", "RecordDotSyntax", "GotoImplementation"]}}
+ ghcide-test/data/ignore-fatal/IgnoreFatal.hs view
@@ -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'
+ ghcide-test/data/ignore-fatal/cabal.project view
@@ -0,0 +1,1 @@+packages: ignore-fatal.cabal
+ ghcide-test/data/ignore-fatal/hie.yaml view
@@ -0,0 +1,4 @@+cradle:+  cabal:+    - path: "."+      component: "lib:ignore-fatal"
+ ghcide-test/data/ignore-fatal/ignore-fatal.cabal view
@@ -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
+ ghcide-test/data/multi-unit-reexport/a/A.hs view
@@ -0,0 +1,3 @@+module A(foo) where+import Data.Text+foo = ()
+ ghcide-test/data/multi-unit-reexport/b/B.hs view
@@ -0,0 +1,3 @@+module B(module B) where+import A+qux = foo
+ ghcide-test/data/multi-unit-reexport/c/C.hs view
@@ -0,0 +1,4 @@+module C(module C) where+import A+import B+cux = foo `seq` qux
+ ghcide-test/data/multi-unit-reexport/cabal.project view
@@ -0,0 +1,2 @@+packages: a b c+multi-repl: True
+ ghcide-test/data/multi-unit-reexport/hie.yaml view
@@ -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"+               ]
+ ghcide-test/data/multi-unit/a/A.hs view
@@ -0,0 +1,3 @@+module A(foo) where+import Data.Text+foo = ()
+ ghcide-test/data/multi-unit/b/B.hs view
@@ -0,0 +1,3 @@+module B(module B) where+import "a" A+qux = foo
+ ghcide-test/data/multi-unit/c/C.hs view
@@ -0,0 +1,3 @@+module C(module C) where+import A+cux = foo
+ ghcide-test/data/multi-unit/cabal.project view
@@ -0,0 +1,2 @@+packages: a b c+multi-repl: True
+ ghcide-test/data/multi-unit/hie.yaml view
@@ -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"+               ]
+ ghcide-test/data/multi/a/A.hs view
@@ -0,0 +1,3 @@+module A(foo) where+import Control.Concurrent.Async+foo = ()
+ ghcide-test/data/multi/a/a.cabal view
@@ -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: .
+ ghcide-test/data/multi/b/B.hs view
@@ -0,0 +1,3 @@+module B(module B) where+import A+qux = foo
+ ghcide-test/data/multi/b/b.cabal view
@@ -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: .
+ ghcide-test/data/multi/c/C.hs view
@@ -0,0 +1,3 @@+module C(module C) where+import A+cux = foo
+ ghcide-test/data/multi/c/c.cabal view
@@ -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: .
+ ghcide-test/data/multi/cabal.project view
@@ -0,0 +1,3 @@+packages: a b c++allow-newer: base
+ ghcide-test/data/multi/hie.yaml view
@@ -0,0 +1,8 @@+cradle:+  cabal:+    - path: "./a"+      component: "lib:a"+    - path: "./b"+      component: "lib:b"+    - path: "./c"+      component: "lib:c"
+ ghcide-test/data/plugin-knownnat/KnownNat.hs view
@@ -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
+ ghcide-test/data/plugin-knownnat/cabal.project view
@@ -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
+ ghcide-test/data/plugin-knownnat/plugin.cabal view
@@ -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: .
+ ghcide-test/data/recomp/A.hs view
@@ -0,0 +1,6 @@+module A(x) where++import B++x :: Int+x = y
+ ghcide-test/data/recomp/B.hs view
@@ -0,0 +1,4 @@+module B(y) where++y :: Int+y = undefined
+ ghcide-test/data/recomp/P.hs view
@@ -0,0 +1,5 @@+module P() where+import A+import B++bar = x :: Int
+ ghcide-test/data/recomp/hie.yaml view
@@ -0,0 +1,1 @@+cradle: {direct: {arguments: ["-Wmissing-signatures","B", "A", "P"]}}
+ ghcide-test/data/references/Main.hs view
@@ -0,0 +1,14 @@+module Main where++import References++main :: IO ()+main = return ()++++a = 2 :: Int+b = a + 1++acc :: Account+acc = Savings
+ ghcide-test/data/references/OtherModule.hs view
@@ -0,0 +1,9 @@+module OtherModule (symbolDefinedInOtherModule, symbolDefinedInOtherOtherModule) where++import OtherOtherModule++symbolDefinedInOtherModule = 1++symbolLocalToOtherModule = 2++someFxn x = x + symbolLocalToOtherModule
+ ghcide-test/data/references/OtherOtherModule.hs view
@@ -0,0 +1,3 @@+module OtherOtherModule where++symbolDefinedInOtherOtherModule = "asdf"
+ ghcide-test/data/references/References.hs view
@@ -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
+ ghcide-test/data/references/hie.yaml view
@@ -0,0 +1,1 @@+cradle: {direct: {arguments: ["Main","OtherModule","OtherOtherModule","References"]}}
+ ghcide-test/data/rootUri/dirA/Foo.hs view
@@ -0,0 +1,3 @@+module Foo () where++foo = ()
+ ghcide-test/data/rootUri/dirA/foo.cabal view
@@ -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: .
+ ghcide-test/data/rootUri/dirB/Foo.hs view
@@ -0,0 +1,3 @@+module Foo () where++foo = ()
+ ghcide-test/data/rootUri/dirB/foo.cabal view
@@ -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: .
+ ghcide-test/data/symlink/hie.yaml view
@@ -0,0 +1,10 @@++cradle:+  direct:+    arguments:+      - -i+      - -isrc+      - -iother_loc/+      - other_loc/Sym.hs+      - src/Foo.hs+      - -Wall
+ ghcide-test/data/symlink/some_loc/Sym.hs view
@@ -0,0 +1,4 @@+module Sym where++foo :: String+foo = ""
+ ghcide-test/data/symlink/src/Foo.hs view
@@ -0,0 +1,4 @@+module Foo where++import Sym+
+ ghcide-test/data/working-dir/a/A.hs view
@@ -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) |]
+ ghcide-test/data/working-dir/a/B.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}+module B() where++import A++$th_a
+ ghcide-test/data/working-dir/a/a.cabal view
@@ -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: .
+ ghcide-test/data/working-dir/cabal.project view
@@ -0,0 +1,1 @@+packages: a
+ ghcide-test/data/working-dir/hie.yaml view
@@ -0,0 +1,2 @@+cradle:+  cabal:
+ ghcide-test/exe/AsyncTests.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE DataKinds #-}++module AsyncTests (tests) where++import           Control.Monad+import           Control.Monad.IO.Class        (liftIO)+import           Data.Aeson                    (toJSON)+import           Data.Proxy+import qualified Data.Text                     as T+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types   hiding+                                               (SemanticTokenAbsolute (..),+                                                SemanticTokenRelative (..),+                                                SemanticTokensEdit (..),+                                                mkRange)+import           Language.LSP.Test+-- import Test.QuickCheck.Instances ()+import           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" ]+    ]
+ ghcide-test/exe/BootTests.hs view
@@ -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+  ]
+ ghcide-test/exe/CPPTests.hs view
@@ -0,0 +1,56 @@+module CPPTests (tests) where++import           Control.Exception           (catch)+import qualified Data.Text                   as T+import           Development.IDE.Test        (Cursor, expectDiagnostics,+                                              expectNoMoreDiagnostics)+import           Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..),+                                              SemanticTokenRelative (..),+                                              SemanticTokensEdit (..), mkRange)+import           Language.LSP.Test+-- import Test.QuickCheck.Instances ()+import           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
+ ghcide-test/exe/ClientSettingsTests.hs view
@@ -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
+ ghcide-test/exe/CodeLensTests.hs view
@@ -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+        ]
+ ghcide-test/exe/CompletionTests.hs view
@@ -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
+ ghcide-test/exe/Config.hs view
@@ -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")
+ ghcide-test/exe/CradleTests.hs view
@@ -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\""+        ]
+ ghcide-test/exe/DependentFileTest.hs view
@@ -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", [])]
+ ghcide-test/exe/DiagnosticTests.hs view
@@ -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
+ ghcide-test/exe/ExceptionTests.hs view
@@ -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
+ ghcide-test/exe/FindDefinitionAndHoverTests.hs view
@@ -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 <> ":<LINE>:<COL>**[...]", Just expectedRange) <>+        "\n but got: " <> show (msg, rangeInHover)++  assertFoundIn :: T.Text -> T.Text -> Assertion+  assertFoundIn part whole = assertBool+    (T.unpack $ "failed to find: `" <> part <> "` in hover message:\n" <> whole)+    (part `T.isInfixOf` whole)++  assertNotFoundIn :: T.Text -> T.Text -> Assertion+  assertNotFoundIn part whole = assertBool+    (T.unpack $ "found unexpected: `" <> part <> "` in hover message:\n" <> whole)+    (not . T.isInfixOf part $ whole)++  sourceFilePath = T.unpack sourceFileName+  sourceFileName = "GotoHover.hs"++  mkFindTests tests = testGroup "get"+    [ testGroup "definition" $ mapMaybe fst tests+    , testGroup "hover"      $ mapMaybe snd tests+    , 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
+ ghcide-test/exe/FindImplementationAndHoverTests.hs view
@@ -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 <> "'"
+ ghcide-test/exe/FuzzySearch.hs view
@@ -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
+ ghcide-test/exe/GarbageCollectionTests.hs view
@@ -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
+ ghcide-test/exe/HaddockTests.hs view
@@ -0,0 +1,90 @@++module HaddockTests (tests) where++import           Development.IDE.Spans.Common+-- import Test.QuickCheck.Instances ()+import           Test.Tasty+import           Test.Tasty.HUnit++tests :: TestTree+tests+  = testGroup "haddock"+      [ testCase "Num" $ checkHaddock+          (unlines+             [ "However, '(+)' and '(*)' are"+             , "customarily expected to define a ring and have the following properties:"+             , ""+             , "[__Associativity of (+)__]: @(x + y) + z@ = @x + (y + z)@"+             , "[__Commutativity of (+)__]: @x + y@ = @y + x@"+             , "[__@fromInteger 0@ is the additive identity__]: @x + fromInteger 0@ = @x@"+             ]+          )+          (unlines+             [ ""+             , ""+             , "However,  `(+)`  and  `(*)`  are"+             , "customarily expected to define a ring and have the following properties: "+             , "+ ****Associativity of (+)****: `(x + y) + z`  =  `x + (y + z)`"+             , "+ ****Commutativity of (+)****: `x + y`  =  `y + x`"+             , "+ ****`fromInteger 0`  is the additive identity****: `x + fromInteger 0`  =  `x`"+             ]+          )+      , testCase "unsafePerformIO" $ checkHaddock+          (unlines+             [ "may require"+             , "different precautions:"+             , ""+             , "  * Use @{\\-\\# NOINLINE foo \\#-\\}@ as a pragma on any function @foo@"+             , "        that calls 'unsafePerformIO'.  If the call is inlined,"+             , "        the I\\/O may be performed more than once."+             , ""+             , "  * Use the compiler flag @-fno-cse@ to prevent common sub-expression"+             , "        elimination being performed on the module."+             , ""+             ]+          )+          (unlines+             [ ""+             , ""+             , "may require"+             , "different precautions: "+             , "+ Use  `{-# NOINLINE foo #-}`  as a pragma on any function  `foo` "+             , "  that calls  `unsafePerformIO` .  If the call is inlined,"+             , "  the I/O may be performed more than once."+             , ""+             , "+ Use the compiler flag  `-fno-cse`  to prevent common sub-expression"+             , "  elimination being performed on the module."+             , ""+             ]+          )+      , testCase "ordered list" $ checkHaddock+          (unlines+             [ "may require"+             , "different precautions:"+             , ""+             , "  1. Use @{\\-\\# NOINLINE foo \\#-\\}@ as a pragma on any function @foo@"+             , "        that calls 'unsafePerformIO'.  If the call is inlined,"+             , "        the I\\/O may be performed more than once."+             , ""+             , "  2. Use the compiler flag @-fno-cse@ to prevent common sub-expression"+             , "        elimination being performed on the module."+             , ""+             ]+          )+          (unlines+             [ ""+             , ""+             , "may require"+             , "different precautions: "+             , "1. Use  `{-# NOINLINE foo #-}`  as a pragma on any function  `foo` "+             , "  that calls  `unsafePerformIO` .  If the call is inlined,"+             , "  the I/O may be performed more than once."+             , ""+             , "2. Use the compiler flag  `-fno-cse`  to prevent common sub-expression"+             , "  elimination being performed on the module."+             , ""+             ]+          )+      ]+  where+    checkHaddock s txt = spanDocToMarkdownForTest s @?= txt
+ ghcide-test/exe/HieDbRetry.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE MultiWayIf #-}+module HieDbRetry (tests) where++import           Control.Concurrent.Extra (Var, modifyVar, newVar, readVar,+                                           withVar)+import           Control.Exception        (ErrorCall (ErrorCall), evaluate,+                                           throwIO, tryJust)+import           Control.Monad.IO.Class   (MonadIO (liftIO))+import           Data.Tuple.Extra         (dupe)+import qualified Database.SQLite.Simple   as SQLite+import           Development.IDE.Session  (retryOnException, retryOnSqliteBusy)+import qualified Development.IDE.Session  as Session+import           Ide.Logger               (Recorder (Recorder, logger_),+                                           WithPriority (WithPriority, payload),+                                           cmapWithPrio)+import qualified System.Random            as Random+import           Test.Tasty               (TestTree, testGroup)+import           Test.Tasty.HUnit         (assertFailure, testCase, (@?=))++data Log+  = LogSession Session.Log+  deriving Show++makeLogger :: Var [Log] -> Recorder (WithPriority Log)+makeLogger msgsVar =+  Recorder {+    logger_ = \WithPriority{ payload = msg } -> liftIO $ modifyVar msgsVar (\msgs -> pure (msg : msgs, ()))+  }++rng :: Random.StdGen+rng = Random.mkStdGen 0++retryOnSqliteBusyForTest :: Recorder (WithPriority Log) -> Int -> IO a -> IO a+retryOnSqliteBusyForTest recorder maxRetryCount = retryOnException isErrorBusy (cmapWithPrio LogSession recorder) 1 1 maxRetryCount rng++isErrorBusy :: SQLite.SQLError -> Maybe SQLite.SQLError+isErrorBusy e+  | SQLite.SQLError { sqlError = SQLite.ErrorBusy } <- e = Just e+  | otherwise = Nothing++errorBusy :: SQLite.SQLError+errorBusy = SQLite.SQLError{ sqlError = SQLite.ErrorBusy, sqlErrorDetails = "", sqlErrorContext = "" }++isErrorCall :: ErrorCall -> Maybe ErrorCall+isErrorCall e+  | ErrorCall _ <- e = Just e++tests :: TestTree+tests = testGroup "RetryHieDb"+  [ testCase "retryOnException throws exception after max retries" $ do+      logMsgsVar <- newVar []+      let logger = makeLogger logMsgsVar+      let maxRetryCount = 1++      result <- tryJust isErrorBusy (retryOnSqliteBusyForTest logger maxRetryCount (throwIO errorBusy))++      case result of+        Left exception -> do+          exception @?= errorBusy+          withVar logMsgsVar $ \logMsgs ->+            length logMsgs @?= 2+            -- uncomment if want to compare log msgs+            -- logMsgs @?= []+        Right _ -> assertFailure "Expected ErrorBusy exception"++   , testCase "retryOnException doesn't throw if given function doesn't throw" $ do+      let expected = 1 :: Int+      let maxRetryCount = 0++      actual <- retryOnSqliteBusyForTest mempty maxRetryCount (pure expected)++      actual @?= expected++   , testCase "retryOnException retries the number of times it should" $ do+      countVar <- newVar 0+      let maxRetryCount = 3+      let incrementThenThrow = modifyVar countVar (\count -> pure (dupe (count + 1))) >> throwIO errorBusy++      _ <- tryJust isErrorBusy (retryOnSqliteBusyForTest mempty maxRetryCount incrementThenThrow)++      withVar countVar $ \count ->+        count @?= maxRetryCount + 1++   , testCase "retryOnException doesn't retry if exception is not ErrorBusy" $ do+      countVar <- newVar (0 :: Int)+      let maxRetryCount = 1++      let throwThenIncrement = do+            count <- readVar countVar+            if count == 0 then+              evaluate (error "dummy exception")+            else+              modifyVar countVar (\count -> pure (dupe (count + 1)))+++      _ <- tryJust isErrorCall (retryOnSqliteBusyForTest mempty maxRetryCount throwThenIncrement)++      withVar countVar $ \count ->+        count @?= 0++   , testCase "retryOnSqliteBusy retries on ErrorBusy" $ do+      countVar <- newVar (0 :: Int)++      let incrementThenThrowThenIncrement = do+            count <- readVar countVar+            if count == 0 then+              modifyVar countVar (\count -> pure (dupe (count + 1))) >> throwIO errorBusy+            else+              modifyVar countVar (\count -> pure (dupe (count + 1)))++      _ <- retryOnSqliteBusy mempty rng incrementThenThrowThenIncrement++      withVar countVar $ \count ->+        count @?= 2++    , testCase "retryOnException exponentially backs off" $ do+       logMsgsVar <- newVar ([] :: [Log])++       let maxDelay = 100+       let baseDelay = 1+       let maxRetryCount = 6+       let logger = makeLogger logMsgsVar++       result <- tryJust isErrorBusy (retryOnException isErrorBusy (cmapWithPrio LogSession logger) maxDelay baseDelay maxRetryCount rng (throwIO errorBusy))++       case result of+         Left _ -> do+           withVar logMsgsVar $ \logMsgs ->+             -- uses log messages to check backoff...+             if | (LogSession (Session.LogHieDbRetriesExhausted baseDelay maximumDelay maxRetryCount _) : _) <- logMsgs -> do+                  baseDelay @?= 64+                  maximumDelay @?= 100+                  maxRetryCount @?= 0+                | otherwise -> assertFailure "Expected more than 0 log messages"+         Right _ -> assertFailure "Expected ErrorBusy exception"+  ]
+ ghcide-test/exe/HighlightTests.hs view
@@ -0,0 +1,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"+      ]
+ ghcide-test/exe/IfaceTests.hs view
@@ -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
+ ghcide-test/exe/InitializeResponseTests.hs view
@@ -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+
+ ghcide-test/exe/LogType.hs view
@@ -0,0 +1,21 @@+module LogType (Log(..)) where++import qualified Development.IDE.LSP.Notifications as Notifications+import qualified Development.IDE.Main              as IDE+import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide++import           Ide.Logger                        (Pretty (pretty))+import           Language.LSP.VFS                  (VfsLog)++data Log+  = LogGhcIde Ghcide.Log+  | LogIDEMain IDE.Log+  | LogVfs VfsLog+  | LogNotifications Notifications.Log++instance Pretty Log where+  pretty = \case+    LogGhcIde log  -> pretty log+    LogIDEMain log -> pretty log+    LogVfs log     -> pretty log+    LogNotifications log -> pretty log
+ ghcide-test/exe/Main.hs view
@@ -0,0 +1,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+    ]
+ ghcide-test/exe/NonLspCommandLine.hs view
@@ -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)
+ ghcide-test/exe/OpenCloseTest.hs view
@@ -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
+ ghcide-test/exe/OutlineTests.hs view
@@ -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)
+ ghcide-test/exe/PluginSimpleTests.hs view
@@ -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")]+          )+      ]
+ ghcide-test/exe/PositionMappingTests.hs view
@@ -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
+ ghcide-test/exe/PreprocessorTests.hs view
@@ -0,0 +1,27 @@++module PreprocessorTests (tests) where++import qualified Data.Text                   as T+import           Development.IDE.Test        (expectDiagnostics)+import           Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..),+                                              SemanticTokenRelative (..),+                                              SemanticTokensEdit (..), mkRange)+import           Language.LSP.Test+-- import Test.QuickCheck.Instances ()+import           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"?+      )+    ]
+ ghcide-test/exe/Progress.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE PackageImports #-}+module Progress (tests) where++import           Control.Concurrent.STM+import           Data.Foldable                          (for_)+import qualified Data.HashMap.Strict                    as Map+import           Development.IDE                        (NormalizedFilePath)+import           Development.IDE.Core.ProgressReporting+import qualified "list-t" ListT+import qualified StmContainers.Map                      as STM+import           Test.Tasty+import           Test.Tasty.HUnit++tests :: TestTree+tests = testGroup "Progress"+    [ reportProgressTests+    ]++data InProgressModel = InProgressModel {+    done, todo :: Int,+    current    :: Map.HashMap NormalizedFilePath Int+}++reportProgressTests :: TestTree+reportProgressTests = testGroup "recordProgress"+    [ test "addNew"   addNew+    , test "increase" increase+    , test "decrease" decrease+    , test "done" done+    ]+    where+        p0 = pure $ InProgressModel 0 0 mempty+        addNew = recordProgressModel "A" succ p0+        increase = recordProgressModel "A" succ addNew+        decrease = recordProgressModel "A" succ increase+        done = recordProgressModel "A" pred decrease+        recordProgressModel key change state =+            model state $ \st -> recordProgress st key change+        model stateModelIO k = do+            state <- fromModel =<< stateModelIO+            _ <- k state+            toModel state+        test name p = testCase name $ do+            InProgressModel{..} <- p+            (done, todo) @?= (length (filter (==0) (Map.elems current)), Map.size current)++fromModel :: InProgressModel -> IO InProgressState+fromModel InProgressModel{..} = do+    doneVar <- newTVarIO done+    todoVar <- newTVarIO todo+    currentVar <- STM.newIO+    atomically $ for_ (Map.toList current) $ \(k,v) -> STM.insert v k currentVar+    return InProgressState{..}++toModel :: InProgressState -> IO InProgressModel+toModel InProgressState{..} = atomically $ do+    done <- readTVar doneVar+    todo <- readTVar todoVar+    current <- Map.fromList <$> ListT.toList (STM.listT currentVar)+    return InProgressModel{..}
+ ghcide-test/exe/ReferenceTests.hs view
@@ -0,0 +1,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
+ ghcide-test/exe/ResolveTests.hs view
@@ -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
+ ghcide-test/exe/RootUriTests.hs view
@@ -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+        }++
+ ghcide-test/exe/SafeTests.hs view
@@ -0,0 +1,38 @@++module SafeTests (tests) where++import qualified Data.Text            as T+import           Development.IDE.Test (expectNoMoreDiagnostics)+import           Language.LSP.Test++import           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 ]
+ ghcide-test/exe/SymlinkTests.hs view
@@ -0,0 +1,27 @@++module SymlinkTests (tests) where++import           Control.Monad.IO.Class      (liftIO)+import           Development.IDE.Test        (expectDiagnosticsWithTags)+import           Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..),+                                              SemanticTokenRelative (..),+                                              SemanticTokensEdit (..), mkRange)+import           Language.LSP.Test+import           System.Directory+import           System.FilePath++import           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 ()+    ]
+ ghcide-test/exe/THTests.hs view
@@ -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"
+ ghcide-test/exe/UnitTests.hs view
@@ -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)
+ ghcide-test/exe/WatchedFileTests.hs view
@@ -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]+            ]
+ ghcide-test/preprocessor/Main.hs view
@@ -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
− ghcide/test/exe/AsyncTests.hs 
@@ -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" ]-    ]
− ghcide/test/exe/BootTests.hs 
@@ -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-  ]
− ghcide/test/exe/CPPTests.hs 
@@ -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
− ghcide/test/exe/ClientSettingsTests.hs 
@@ -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
− ghcide/test/exe/CodeLensTests.hs 
@@ -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-        ]
− ghcide/test/exe/CompletionTests.hs 
@@ -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
− ghcide/test/exe/Config.hs 
@@ -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")
− ghcide/test/exe/CradleTests.hs 
@@ -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\""-        ]
− ghcide/test/exe/DependentFileTest.hs 
@@ -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", [])]
− ghcide/test/exe/DiagnosticTests.hs 
@@ -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
− ghcide/test/exe/ExceptionTests.hs 
@@ -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
− ghcide/test/exe/FindDefinitionAndHoverTests.hs 
@@ -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 <> ":<LINE>:<COL>**[...]", Just expectedRange) <>-        "\n but got: " <> show (msg, rangeInHover)--  assertFoundIn :: T.Text -> T.Text -> Assertion-  assertFoundIn part whole = assertBool-    (T.unpack $ "failed to find: `" <> part <> "` in hover message:\n" <> whole)-    (part `T.isInfixOf` whole)--  assertNotFoundIn :: T.Text -> T.Text -> Assertion-  assertNotFoundIn part whole = assertBool-    (T.unpack $ "found unexpected: `" <> part <> "` in hover message:\n" <> whole)-    (not . T.isInfixOf part $ whole)--  sourceFilePath = T.unpack sourceFileName-  sourceFileName = "GotoHover.hs"--  mkFindTests tests = testGroup "get"-    [ testGroup "definition" $ mapMaybe fst tests-    , testGroup "hover"      $ mapMaybe snd tests-    , 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
− ghcide/test/exe/FuzzySearch.hs 
@@ -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
− ghcide/test/exe/GarbageCollectionTests.hs 
@@ -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
− ghcide/test/exe/HaddockTests.hs 
@@ -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
− ghcide/test/exe/HieDbRetry.hs 
@@ -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"-  ]
− ghcide/test/exe/HighlightTests.hs 
@@ -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"-      ]
− ghcide/test/exe/IfaceTests.hs 
@@ -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
− ghcide/test/exe/InitializeResponseTests.hs 
@@ -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-
− ghcide/test/exe/LogType.hs 
@@ -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
− ghcide/test/exe/Main.hs 
@@ -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-    ]
− ghcide/test/exe/NonLspCommandLine.hs 
@@ -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)
− ghcide/test/exe/OpenCloseTest.hs 
@@ -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
− ghcide/test/exe/OutlineTests.hs 
@@ -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)
− ghcide/test/exe/PluginSimpleTests.hs 
@@ -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")]-          )-      ]
− ghcide/test/exe/PositionMappingTests.hs 
@@ -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
− ghcide/test/exe/PreprocessorTests.hs 
@@ -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")]-      )-    ]
− ghcide/test/exe/Progress.hs 
@@ -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{..}
− ghcide/test/exe/ReferenceTests.hs 
@@ -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
− ghcide/test/exe/RootUriTests.hs 
@@ -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-        }--
− ghcide/test/exe/SafeTests.hs 
@@ -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 ]
− ghcide/test/exe/SymlinkTests.hs 
@@ -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 ()-    ]
− ghcide/test/exe/THTests.hs 
@@ -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"
− ghcide/test/exe/UnitTests.hs 
@@ -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)
− ghcide/test/exe/WatchedFileTests.hs 
@@ -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]-            ]
haskell-language-server.cabal view
@@ -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 <https://github.com/haskell/haskell-language-server#readme>@@ -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,
plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/Literals.hs view
@@ -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
plugins/hls-cabal-fmt-plugin/src/Ide/Plugin/CabalFmt.hs view
@@ -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
plugins/hls-cabal-fmt-plugin/test/Main.hs view
@@ -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
plugins/hls-cabal-fmt-plugin/test/testdata/commented_testdata.formatted_document.cabal view
@@ -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
plugins/hls-cabal-gild-plugin/src/Ide/Plugin/CabalGild.hs view
@@ -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
plugins/hls-cabal-gild-plugin/test/Main.hs view
@@ -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"
plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs view
@@ -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
+ plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/CabalAdd.hs view
@@ -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)
+ plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/CabalFields.hs view
@@ -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
plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Simple.hs view
@@ -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. --
plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completer/Types.hs view
@@ -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   }
plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Completions.hs view
@@ -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
plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Data.hs view
@@ -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),
plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Types.hs view
@@ -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)
+ plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Definition.hs view
@@ -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"
plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs view
@@ -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
+ plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/FieldSuggest.hs view
@@ -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
+ plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Outline.hs view
@@ -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+  }
+ plugins/hls-cabal-plugin/test/CabalAdd.hs view
@@ -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
plugins/hls-cabal-plugin/test/Completer.hs view
@@ -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:+          ^+|]
plugins/hls-cabal-plugin/test/Context.hs view
@@ -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
+ plugins/hls-cabal-plugin/test/Definition.hs view
@@ -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)
plugins/hls-cabal-plugin/test/Main.hs view
@@ -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
+ plugins/hls-cabal-plugin/test/Outline.hs view
@@ -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+    }
plugins/hls-cabal-plugin/test/Utils.hs view
@@ -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
+ plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-bench/bench/Main.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Data.List.Split++main :: IO ()+main = putStrLn "Test suite not yet implemented."
+ plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-bench/cabal-add-bench.cabal view
@@ -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
+ plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-exe/cabal-add-exe.cabal view
@@ -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
+ plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-exe/src/Main.hs view
@@ -0,0 +1,5 @@+module Main where++import Data.List.Split++main = putStrLn "Hello, Haskell!"
+ plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-lib/cabal-add-lib.cabal view
@@ -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
+ plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-lib/src/MyLib.hs view
@@ -0,0 +1,6 @@+module MyLib (someFunc) where++import Data.List.Split++someFunc :: IO ()+someFunc = putStrLn "someFunc"
+ plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-multitarget/bench/Main.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Data.List.Split++main :: IO ()+main = putStrLn "Test suite not yet implemented."
+ plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-multitarget/cabal-add-multitarget.cabal view
@@ -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+
+ plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-multitarget/lib/InternalLib.hs view
@@ -0,0 +1,6 @@+module InternalLib (internalFunc) where++import Data.List.Split++internalFunc :: IO ()+internalFunc = putStrLn "internalFunc"
+ plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-multitarget/lib/MyLib.hs view
@@ -0,0 +1,6 @@+module MyLib (someFunc) where++import Data.List.Split++someFunc :: IO ()+someFunc = putStrLn "someFunc"
+ plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-multitarget/src/Main.hs view
@@ -0,0 +1,5 @@+module Main where++import Data.List.Split++main = putStrLn "Hello, Haskell!"
+ plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-multitarget/test/Main.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Data.List.Split++main :: IO ()+main = putStrLn "Test suite not yet implemented."
+ plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-packageYaml/cabal-add-packageYaml.cabal view
@@ -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
+ plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-packageYaml/package.yaml view
+ plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-packageYaml/src/Main.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Data.List.Split++main :: IO ()+main = putStrLn "Test suite not yet implemented."
+ plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-tests/cabal-add-tests.cabal view
@@ -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
+ plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal-add-tests/test/Main.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Data.List.Split++main :: IO ()+main = putStrLn "Test suite not yet implemented."
+ plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/cabal.project view
@@ -0,0 +1,6 @@+packages: cabal-add-exe+          cabal-add-lib+          cabal-add-tests+          cabal-add-bench+          cabal-add-multitarget+          cabal-add-packageYaml
+ plugins/hls-cabal-plugin/test/testdata/cabal-add-testdata/hie.yaml view
@@ -0,0 +1,2 @@+cradle:+  cabal:
+ plugins/hls-cabal-plugin/test/testdata/code-actions/FieldSuggestions.cabal view
@@ -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:+
+ plugins/hls-cabal-plugin/test/testdata/code-actions/FieldSuggestions.golden.cabal view
@@ -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:+
+ plugins/hls-cabal-plugin/test/testdata/goto-definition/common-section/simple-with-common.cabal view
@@ -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
+ plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/module-examples.cabal view
@@ -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)
+ plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/Library/Lib.hs view
@@ -0,0 +1,1 @@+module Library.Lib where
+ plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/Library/Other/OtherLib.hs view
@@ -0,0 +1,1 @@+module Library.Other.OtherLib where
+ plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/bench/Config.hs view
@@ -0,0 +1,1 @@+module Config where
+ plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/bench/Main.hs view
@@ -0,0 +1,3 @@+module Main where++main = undefined
+ plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/exe/Config.hs view
@@ -0,0 +1,1 @@+module Confing where
+ plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/exe/Main.hs view
@@ -0,0 +1,3 @@+module Main where++main = undefined
+ plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/test/Config.hs view
@@ -0,0 +1,1 @@+module Config where
+ plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/test/Library.hs view
@@ -0,0 +1,1 @@+module Library where
+ plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/test/Main.hs view
+ plugins/hls-cabal-plugin/test/testdata/goto-definition/simple-with-common.cabal view
@@ -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
+ plugins/hls-cabal-plugin/test/testdata/hie.yaml view
@@ -0,0 +1,3 @@+cradle:+  direct:+    arguments: []
+ plugins/hls-cabal-plugin/test/testdata/hover/hover-deps.cabal view
@@ -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
+ plugins/hls-cabal-plugin/test/testdata/outline-cabal/field.cabal view
@@ -0,0 +1,1 @@+homepage:
+ plugins/hls-cabal-plugin/test/testdata/outline-cabal/fieldline.cabal view
@@ -0,0 +1,1 @@+cabal-version:      3.0
+ plugins/hls-cabal-plugin/test/testdata/outline-cabal/section.cabal view
@@ -0,0 +1,2 @@+  build-depends:+    base                         >=4.16     && <5
+ plugins/hls-cabal-plugin/test/testdata/outline-cabal/sectionarg.cabal view
@@ -0,0 +1,2 @@+  if os(windows)+    build-depends: Win32
+ plugins/hls-cabal-plugin/test/testdata/unsupportedVersion.cabal view
@@ -0,0 +1,3 @@+cabal-version:      99999.0+name:               invalid+version:            0.1.0.0
plugins/hls-call-hierarchy-plugin/test/Main.hs view
@@ -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
plugins/hls-change-type-signature-plugin/test/Main.hs view
@@ -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
plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs view
@@ -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
plugins/hls-class-plugin/src/Ide/Plugin/Class/ExactPrint.hs view
@@ -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 ->
plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs view
@@ -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
plugins/hls-class-plugin/src/Ide/Plugin/Class/Utils.hs view
@@ -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
plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs view
@@ -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
plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs view
@@ -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
plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs view
@@ -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 <https://github.com/jyp/dante Dante>, <https://www.haskell.org/haddock/doc/html/ch03s08.html#idm140354810775744 Haddock>'s Examples and Properties and <https://hackage.haskell.org/package/doctest Doctest>.@@ -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{..} =
plugins/hls-eval-plugin/src/Ide/Plugin/Eval/GHC.hs view
@@ -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
plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs view
@@ -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]
plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs view
@@ -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 
plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs view
@@ -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
plugins/hls-eval-plugin/test/Main.hs view
@@ -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 =
plugins/hls-eval-plugin/test/testdata/T20.expected.hs view
@@ -4,4 +4,4 @@ default (Word)  -- >>> :type  +d   40+ 2 --- 40+ 2 :: Word+-- 40+ 2 :: Integer
+ plugins/hls-eval-plugin/test/testdata/TPropertyError.ghc912.expected.hs view
@@ -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):+-- []
− plugins/hls-eval-plugin/test/testdata/TPropertyError.ghc92.expected.hs 
@@ -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):--- []
plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs view
@@ -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)
plugins/hls-explicit-fixity-plugin/test/Main.hs view
@@ -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
plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs view
@@ -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
plugins/hls-explicit-imports-plugin/test/Main.hs view
@@ -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 ()
plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs view
@@ -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 _ = "<CollectRecordsResult>"@@ -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)--
plugins/hls-explicit-record-fields-plugin/test/Main.hs view
@@ -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"
+ plugins/hls-explicit-record-fields-plugin/test/testdata/PolymorphicRecordConstruction.expected.hs view
@@ -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 }
+ plugins/hls-explicit-record-fields-plugin/test/testdata/PolymorphicRecordConstruction.hs view
@@ -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
+ plugins/hls-explicit-record-fields-plugin/test/testdata/PositionalConstruction.expected.hs view
@@ -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 }
+ plugins/hls-explicit-record-fields-plugin/test/testdata/PositionalConstruction.hs view
@@ -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
plugins/hls-floskell-plugin/src/Ide/Plugin/Floskell.hs view
@@ -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
plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs view
@@ -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
plugins/hls-gadt-plugin/src/Ide/Plugin/GHC.hs view
@@ -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
plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs view
@@ -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
plugins/hls-hlint-plugin/test/Main.hs view
@@ -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"
plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs view
@@ -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,
plugins/hls-notes-plugin/src/Ide/Plugin/Notes.hs view
@@ -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
plugins/hls-ormolu-plugin/src/Ide/Plugin/Ormolu.hs view
@@ -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)  -- --------------------------------------------------------------------- 
plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs view
@@ -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
plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs view
@@ -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
plugins/hls-pragmas-plugin/test/Main.hs view
@@ -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   ] 
+ plugins/hls-pragmas-plugin/test/testdata/DeferredOutOfScopeVariables.expected.hs view
@@ -0,0 +1,5 @@+module DeferredOutOfScopeVariables where++f :: ()+f = let x = Doesn'tExist+     in undefined
+ plugins/hls-pragmas-plugin/test/testdata/DeferredOutOfScopeVariables.hs view
@@ -0,0 +1,5 @@+module DeferredOutOfScopeVariables where++f :: ()+f = let x = Doesn'tExist+     in undefined
plugins/hls-qualify-imported-names-plugin/src/Ide/Plugin/QualifyImportedNames.hs view
@@ -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 [] 
plugins/hls-refactor-plugin/src/Development/IDE/GHC/Compat/ExactPrint.hs view
@@ -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'
plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs view
@@ -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
plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs view
@@ -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
plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs view
@@ -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']
plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs view
@@ -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
plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/RuleTypes.hs view
@@ -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
plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs view
@@ -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)
plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillHole.hs view
@@ -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
plugins/hls-refactor-plugin/test/Main.hs view
@@ -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]
plugins/hls-refactor-plugin/test/data/import-placement/MultiLinePragma.expected.hs view
@@ -3,8 +3,8 @@ {-# LANGUAGE RecordWildCards,     OverloadedStrings #-} {-# OPTIONS_GHC -Wall,-  -Wno-unused-imports #-} import Data.Monoid+  -Wno-unused-imports #-}   -- some comment
plugins/hls-refactor-plugin/test/data/import-placement/OptionsNotAtTopWithSpaces.expected.hs view
@@ -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
plugins/hls-refactor-plugin/test/data/import-placement/OptionsPragmaNotAtTop.expected.hs view
@@ -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
plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopMultipleComments.expected.hs view
@@ -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
plugins/hls-refactor-plugin/test/data/import-placement/PragmaNotAtTopWithCommentsAtTop.expected.hs view
@@ -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
plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTop.expected.hs view
@@ -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
plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTopNoSpace.expected.hs view
@@ -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
plugins/hls-refactor-plugin/test/data/import-placement/ShebangNotAtTopWithSpaces.expected.hs view
@@ -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
plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs view
@@ -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
plugins/hls-rename-plugin/test/Main.hs view
@@ -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"
plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs view
@@ -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
plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Types.hs view
@@ -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 
plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs view
@@ -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 =
plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs view
@@ -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
plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs view
@@ -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
src/HlsPlugins.hs view
@@ -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" :
src/Ide/Arguments.hs view
@@ -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(..)
src/Ide/Main.hs view
@@ -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
test/functional/Config.hs view
@@ -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
test/functional/Main.hs view
@@ -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     ]
+ test/testdata/hieBiosMainIs/dist-newstyle/cache/plan.json view
@@ -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":[]}]}
+ test/testdata/missingModuleTest/missingModule/dist-newstyle/cache/plan.json view
@@ -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":[]}]}
+ test/testdata/schema/ghc912/default-config.golden.json view
@@ -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"+}
+ test/testdata/schema/ghc912/vscode-extension-schema.golden.json view
@@ -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"+    }+}
− test/testdata/schema/ghc92/default-config.golden.json 
@@ -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"-}
− test/testdata/schema/ghc92/vscode-extension-schema.golden.json 
@@ -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"-    }-}
test/testdata/schema/ghc94/default-config.golden.json view
@@ -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
test/testdata/schema/ghc94/vscode-extension-schema.golden.json view
@@ -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"     },
test/testdata/schema/ghc96/default-config.golden.json view
@@ -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
test/testdata/schema/ghc96/vscode-extension-schema.golden.json view
@@ -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"     },
test/testdata/schema/ghc98/default-config.golden.json view
@@ -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
test/testdata/schema/ghc98/vscode-extension-schema.golden.json view
@@ -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"     },