diff --git a/.github/workflows/supported-ghc-versions.json b/.github/workflows/supported-ghc-versions.json index 5a59fdc0a7..387811c11b 100644 --- a/.github/workflows/supported-ghc-versions.json +++ b/.github/workflows/supported-ghc-versions.json @@ -1 +1 @@ -[ "9.8", "9.6", "9.4" , "9.2" ] +["9.10", "9.8", "9.6", "9.4" , "9.2" ] diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index b86b6b8302..fa851b03ff 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -98,7 +98,7 @@ jobs: - uses: ./.github/actions/setup-build with: ghc: ${{ matrix.ghc }} - os: ${{ runner.os }} + os: ${{ runner.os }} - name: Build run: cabal build all @@ -141,7 +141,8 @@ jobs: name: Test hls-refactor-plugin run: cabal test hls-refactor-plugin-tests || cabal test hls-refactor-plugin-tests - - if: matrix.test + # TODO enable when it supports 9.10 + - if: matrix.test && matrix.ghc != '9.10' name: Test hls-floskell-plugin run: cabal test hls-floskell-plugin-tests || cabal test hls-floskell-plugin-tests @@ -157,15 +158,18 @@ jobs: name: Test hls-eval-plugin run: cabal test hls-eval-plugin-tests || cabal test hls-eval-plugin-tests - - if: matrix.test + # TODO enable when it supports 9.10 + - if: matrix.test && matrix.ghc != '9.10' name: Test hls-splice-plugin run: cabal test hls-splice-plugin-tests || cabal test hls-splice-plugin-tests - - if: matrix.test && matrix.ghc != '9.2' + # TODO enable when it supports 9.10 + - if: matrix.test && matrix.ghc != '9.2' && matrix.ghc != '9.10' name: Test hls-stan-plugin run: cabal test hls-stan-plugin-tests || cabal test hls-stan-plugin-tests - - if: matrix.test + # TODO enable when it supports 9.10 + - if: matrix.test && matrix.ghc != '9.10' name: Test hls-stylish-haskell-plugin run: cabal test hls-stylish-haskell-plugin-tests || cabal test hls-stylish-haskell-plugin-tests @@ -173,7 +177,8 @@ jobs: name: Test hls-ormolu-plugin run: cabal test hls-ormolu-plugin-tests || cabal test hls-ormolu-plugin-tests - - if: matrix.test + # TODO enable when it supports 9.10 + - if: matrix.test && matrix.ghc != '9.10' name: Test hls-fourmolu-plugin run: cabal test hls-fourmolu-plugin-tests || cabal test hls-fourmolu-plugin-tests @@ -189,7 +194,8 @@ jobs: name: Test hls-rename-plugin test suite run: cabal test hls-rename-plugin-tests || cabal test hls-rename-plugin-tests - - if: matrix.test + # TODO enable when it supports 9.10 + - if: matrix.test && matrix.ghc != '9.10' name: Test hls-hlint-plugin test suite run: cabal test hls-hlint-plugin-tests || cabal test hls-hlint-plugin-tests @@ -238,7 +244,8 @@ jobs: name: Test hls-cabal-plugin test suite run: cabal test hls-cabal-plugin-tests || cabal test hls-cabal-plugin-tests - - if: matrix.test + # TODO enable when it supports 9.10 + - if: matrix.test && matrix.ghc != '9.10' name: Test hls-retrie-plugin test suite run: cabal test hls-retrie-plugin-tests || cabal test hls-retrie-plugin-tests diff --git a/cabal.project b/cabal.project index faa94671f8..8b84a4a457 100644 --- a/cabal.project +++ b/cabal.project @@ -7,12 +7,12 @@ packages: ./hls-plugin-api ./hls-test-utils -index-state: 2024-06-07T00:00:00Z +index-state: 2024-06-10T12:08:58Z tests: True test-show-details: direct -benchmarks: True +-- benchmarks: True write-ghc-environment-files: never @@ -40,4 +40,29 @@ constraints: -- the flag '-fopen-simd', which blocked the release 2.2.0.0. -- We want to be able to benefit from the performance optimisations -- in the future, thus: TODO: remove this flag. - bitvec -simd + bitvec -simd, + + +if impl(ghc >= 9.9) + benchmarks: False + constraints: + lens >= 5.3.2, + -- See + -- https://github.com/haskell/stylish-haskell/issues/479 + -- https://github.com/fourmolu/fourmolu/issues/412 + -- https://github.com/ennocramer/floskell/pull/82 + -- https://github.com/ndmitchell/hlint/pull/1594 + haskell-language-server -stylishHaskell -fourmolu -hlint -retrie -splice -floskell, + allow-newer: + entropy:base, + entropy:directory, + entropy:filepath, + entropy:process, + haddock-library:base, + haddock-library:containers, + -- These can be removed when we get a new lsp release + quickcheck-instances:base, + quickcheck-instances:containers, + uuid-types:template-haskell, +else + benchmarks: True diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index fd2e0dcdf1..87db32c2bc 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -14,7 +14,7 @@ homepage: https://github.com/haskell/haskell-language-server/tree/master/ghcide#readme bug-reports: https://github.com/haskell/haskell-language-server/issues -tested-with: GHC ==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 || ==9.2.8 extra-source-files: CHANGELOG.md README.md diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index f295e568c6..af1c97a457 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -76,7 +76,7 @@ import Development.IDE.Core.Shake import Development.IDE.Core.Tracing (withTrace) import Development.IDE.GHC.Compat hiding (loadInterface, parseHeader, parseModule, - tcRnModule, writeHieFile) + tcRnModule, writeHieFile, assert) import qualified Development.IDE.GHC.Compat as Compat import qualified Development.IDE.GHC.Compat as GHC import qualified Development.IDE.GHC.Compat.Util as Util diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index 11b904624d..b8c8a34d6f 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -129,7 +129,7 @@ progressReporting (Just lspEnv) optProgressStyle = do when (nextPct == prevPct) retry pure (todo, done, nextPct) - update (ProgressAmount (Just nextPct) (Just $ T.pack $ show done <> "/" <> show todo)) + _ <- update (ProgressAmount (Just nextPct) (Just $ T.pack $ show done <> "/" <> show todo)) loop update nextPct updateStateForFile inProgress file = actionBracket (f succ) (const $ f pred) . const -- This functions are deliberately eta-expanded to avoid space leaks. diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index 605420d3b6..3d60669f5c 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -16,7 +16,7 @@ module Development.IDE.Core.RuleTypes( ) where import Control.DeepSeq -import Control.Exception (assert) +import qualified Control.Exception as E import Control.Lens import Data.Aeson.Types (Value) import Data.Hashable @@ -188,9 +188,9 @@ hiFileFingerPrint HiFileResult{..} = hirIfaceFp <> maybe "" snd hirCoreFp mkHiFileResult :: ModSummary -> ModIface -> ModDetails -> ModuleEnv ByteString -> Maybe (CoreFile, ByteString) -> HiFileResult mkHiFileResult hirModSummary hirModIface hirModDetails hirRuntimeModules hirCoreFp = - assert (case hirCoreFp of Just (CoreFile{cf_iface_hash}, _) - -> getModuleHash hirModIface == cf_iface_hash - _ -> True) + E.assert (case hirCoreFp of + Just (CoreFile{cf_iface_hash}, _) -> getModuleHash hirModIface == cf_iface_hash + _ -> True) HiFileResult{..} where hirIfaceFp = fingerprintToBS . getModuleHash $ hirModIface -- will always be two bytes diff --git a/ghcide/src/Development/IDE/GHC/CPP.hs b/ghcide/src/Development/IDE/GHC/CPP.hs index 450cc702e8..b0ec869e24 100644 --- a/ghcide/src/Development/IDE/GHC/CPP.hs +++ b/ghcide/src/Development/IDE/GHC/CPP.hs @@ -34,6 +34,10 @@ import qualified GHC.Driver.Pipeline.Execute as Pipeline import qualified GHC.SysTools.Cpp as Pipeline #endif +#if MIN_VERSION_ghc(9,11,0) +import qualified GHC.SysTools.Tasks as Pipeline +#endif + addOptP :: String -> DynFlags -> DynFlags addOptP f = alterToolSettings $ \s -> s { toolSettings_opt_P = f : toolSettings_opt_P s @@ -52,7 +56,9 @@ doCpp env input_fn output_fn = #if MIN_VERSION_ghc(9,5,0) let cpp_opts = Pipeline.CppOpts { cppLinePragmas = True -#if MIN_VERSION_ghc(9,9,0) +#if MIN_VERSION_ghc(9,11,0) + , sourceCodePreprocessor = Pipeline.SCPHsCpp +#elif MIN_VERSION_ghc(9,10,0) , useHsCpp = True #else , cppUseCc = False diff --git a/ghcide/src/Development/IDE/GHC/Compat.hs b/ghcide/src/Development/IDE/GHC/Compat.hs index e786c2ee14..8e138ce56b 100644 --- a/ghcide/src/Development/IDE/GHC/Compat.hs +++ b/ghcide/src/Development/IDE/GHC/Compat.hs @@ -335,7 +335,11 @@ myCoreToStg logger dflags ictxt return (stg_binds2, denv, cost_centre_info) - +#if MIN_VERSION_ghc(9,9,0) +reLocA :: (HasLoc (GenLocated a e), HasAnnotation b) + => GenLocated a e -> GenLocated b e +reLocA = reLoc +#endif getDependentMods :: ModIface -> [ModuleName] #if MIN_VERSION_ghc(9,3,0) @@ -515,13 +519,16 @@ data GhcVersion | GHC94 | GHC96 | GHC98 - deriving (Eq, Ord, Show) + | GHC910 + deriving (Eq, Ord, Show, Enum) ghcVersionStr :: String ghcVersionStr = VERSION_ghc ghcVersion :: GhcVersion -#if MIN_VERSION_GLASGOW_HASKELL(9,8,0,0) +#if MIN_VERSION_GLASGOW_HASKELL(9,10,0,0) +ghcVersion = GHC910 +#elif MIN_VERSION_GLASGOW_HASKELL(9,8,0,0) ghcVersion = GHC98 #elif MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) ghcVersion = GHC96 diff --git a/ghcide/src/Development/IDE/GHC/Compat/Core.hs b/ghcide/src/Development/IDE/GHC/Compat/Core.hs index f6ab831b72..06f798d1ff 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Core.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Core.hs @@ -197,7 +197,9 @@ module Development.IDE.GHC.Compat.Core ( pattern RealSrcLoc, SrcLoc.SrcLoc(SrcLoc.UnhelpfulLoc), BufSpan, +#if !MIN_VERSION_ghc(9,9,0) GHC.SrcAnn, +#endif SrcLoc.leftmost_smallest, SrcLoc.containsSpan, SrcLoc.mkGeneralSrcSpan, @@ -494,8 +496,11 @@ import Data.Foldable (toList) import GHC.Core.Multiplicity (scaledThing) import GHC.Data.Bag import GHC.Driver.Env -import GHC.Hs (HsModule (..), SrcSpanAnn') -import GHC.Hs.Decls hiding (FunDep) +import GHC.Hs (HsModule (..)) +#if !MIN_VERSION_ghc(9,9,0) +import GHC.Hs (SrcSpanAnn') +#endif +import GHC.Hs.Decls hiding (FunDep) import GHC.Hs.Doc import GHC.Hs.Expr import GHC.Hs.Extension @@ -651,10 +656,20 @@ instance HasSrcSpan SrcSpan where instance HasSrcSpan (SrcLoc.GenLocated SrcSpan a) where getLoc = GHC.getLoc +#if MIN_VERSION_ghc(9,9,0) +instance HasSrcSpan (EpAnn a) where + getLoc = GHC.getHasLoc +#endif + +#if MIN_VERSION_ghc(9,9,0) +instance HasSrcSpan (SrcLoc.GenLocated (EpAnn ann) a) where + getLoc (L l _) = getLoc l +#else instance HasSrcSpan (SrcSpanAnn' ann) where getLoc = GHC.locA instance HasSrcSpan (SrcLoc.GenLocated (SrcSpanAnn' ann) a) where getLoc (L l _) = l +#endif pattern L :: HasSrcSpan a => SrcSpan -> e -> SrcLoc.GenLocated a e pattern L l a <- GHC.L (getLoc -> l) a @@ -662,9 +677,15 @@ pattern L l a <- GHC.L (getLoc -> l) a -- This is from the old api, but it still simplifies pattern ConPatIn :: SrcLoc.Located (ConLikeP GhcPs) -> HsConPatDetails GhcPs -> Pat GhcPs +#if MIN_VERSION_ghc(9,9,0) +pattern ConPatIn con args <- ConPat _ (L _ (SrcLoc.noLoc -> con)) args + where + ConPatIn con args = ConPat GHC.noAnn (GHC.noLocA $ SrcLoc.unLoc con) args +#else pattern ConPatIn con args <- ConPat EpAnnNotUsed (L _ (SrcLoc.noLoc -> con)) args where ConPatIn con args = ConPat EpAnnNotUsed (GHC.noLocA $ SrcLoc.unLoc con) args +#endif conPatDetails :: Pat p -> Maybe (HsConPatDetails p) conPatDetails (ConPat _ _ args) = Just args @@ -680,8 +701,16 @@ initObjLinker env = GHCi.initObjLinker (GHCi.hscInterp env) loadDLL :: HscEnv -> String -> IO (Maybe String) -loadDLL env = - GHCi.loadDLL (GHCi.hscInterp env) +loadDLL env str = do + res <- GHCi.loadDLL (GHCi.hscInterp env) str +#if MIN_VERSION_ghc(9,11,0) + pure $ + case res of + Left err_msg -> Just err_msg + Right _ -> Nothing +#else + pure res +#endif unload :: HscEnv -> [Linkable] -> IO () unload hsc_env linkables = diff --git a/ghcide/src/Development/IDE/GHC/Orphans.hs b/ghcide/src/Development/IDE/GHC/Orphans.hs index 63f663840c..d7a85948cf 100644 --- a/ghcide/src/Development/IDE/GHC/Orphans.hs +++ b/ghcide/src/Development/IDE/GHC/Orphans.hs @@ -109,14 +109,19 @@ instance NFData ModSummary where instance Ord FastString where compare a b = if a == b then EQ else compare (fs_sbs a) (fs_sbs b) + +#if MIN_VERSION_ghc(9,9,0) +instance NFData (EpAnn a) where + rnf = rwhnf +#else instance NFData (SrcSpanAnn' a) where rnf = rwhnf +deriving instance Functor SrcSpanAnn' +#endif instance Bifunctor GenLocated where bimap f g (L l x) = L (f l) (g x) -deriving instance Functor SrcSpanAnn' - instance NFData ParsedModule where rnf = rwhnf diff --git a/ghcide/src/Development/IDE/LSP/Outline.hs b/ghcide/src/Development/IDE/LSP/Outline.hs index 8d466a61a6..1c9d1971b3 100644 --- a/ghcide/src/Development/IDE/LSP/Outline.hs +++ b/ghcide/src/Development/IDE/LSP/Outline.hs @@ -271,7 +271,9 @@ hsConDeclsBinders cons get_flds_gadt :: HsConDeclGADTDetails GhcPs -> [LFieldOcc GhcPs] -#if MIN_VERSION_ghc(9,3,0) +#if MIN_VERSION_ghc(9,9,0) + get_flds_gadt (RecConGADT _ flds) = get_flds (reLoc flds) +#elif MIN_VERSION_ghc(9,3,0) get_flds_gadt (RecConGADT flds _) = get_flds (reLoc flds) #else get_flds_gadt (RecConGADT flds) = get_flds (reLoc flds) diff --git a/ghcide/test/cabal/Development/IDE/Test/Runfiles.hs b/ghcide/test/cabal/Development/IDE/Test/Runfiles.hs deleted file mode 100644 index 83b7e8c368..0000000000 --- a/ghcide/test/cabal/Development/IDE/Test/Runfiles.hs +++ /dev/null @@ -1,9 +0,0 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - -module Development.IDE.Test.Runfiles - ( locateGhcideExecutable - ) where - -locateGhcideExecutable :: IO FilePath -locateGhcideExecutable = pure "ghcide" diff --git a/ghcide/test/exe/BootTests.hs b/ghcide/test/exe/BootTests.hs index 078281d391..06c05ba9b6 100644 --- a/ghcide/test/exe/BootTests.hs +++ b/ghcide/test/exe/BootTests.hs @@ -17,7 +17,6 @@ import Language.LSP.Protocol.Types hiding mkRange) import Language.LSP.Test import System.FilePath (()) -import Test.Hls.FileSystem (toAbsFp) import Test.Tasty import Test.Tasty.HUnit diff --git a/ghcide/test/exe/ClientSettingsTests.hs b/ghcide/test/exe/ClientSettingsTests.hs index 8251558235..7c3c3b27f1 100644 --- a/ghcide/test/exe/ClientSettingsTests.hs +++ b/ghcide/test/exe/ClientSettingsTests.hs @@ -1,8 +1,7 @@ {-# LANGUAGE GADTs #-} module ClientSettingsTests (tests) where -import Config (lspTestCaps, testWithConfig, - testWithDummyPluginEmpty) +import Config (testWithDummyPluginEmpty) import Control.Applicative.Combinators import Control.Monad import Data.Aeson (toJSON) @@ -16,8 +15,7 @@ import Language.LSP.Protocol.Types hiding SemanticTokensEdit (..), mkRange) import Language.LSP.Test -import Test.Hls (testConfigCaps, - waitForProgressDone) +import Test.Hls (waitForProgressDone) import Test.Tasty tests :: TestTree diff --git a/ghcide/test/exe/CodeLensTests.hs b/ghcide/test/exe/CodeLensTests.hs index c5f320f5c7..4ec5f3957c 100644 --- a/ghcide/test/exe/CodeLensTests.hs +++ b/ghcide/test/exe/CodeLensTests.hs @@ -88,7 +88,11 @@ addSigLensesTests = , ("symbolKindTest = Proxy @\"qwq\"", "symbolKindTest :: Proxy \"qwq\"") , ("promotedKindTest = Proxy @Nothing", if ghcVersion >= GHC96 then "promotedKindTest :: Proxy Nothing" else "promotedKindTest :: Proxy 'Nothing") , ("typeOperatorTest = Refl", "typeOperatorTest :: forall {k} {a :: k}. a :~: a") - , ("notInScopeTest = mkCharType", "notInScopeTest :: String -> Data.Data.DataType") + , ("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 diff --git a/ghcide/test/exe/CompletionTests.hs b/ghcide/test/exe/CompletionTests.hs index 590f0b707a..26d8d17fc2 100644 --- a/ghcide/test/exe/CompletionTests.hs +++ b/ghcide/test/exe/CompletionTests.hs @@ -16,7 +16,6 @@ import Data.Default import Data.List.Extra import Data.Maybe import qualified Data.Text as T -import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) import Development.IDE.Types.Location import Ide.Plugin.Config import qualified Language.LSP.Protocol.Lens as L @@ -30,7 +29,7 @@ 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 (knownBrokenOnWindows) +import Test.Hls.Util import Test.Tasty import Test.Tasty.HUnit @@ -217,7 +216,7 @@ localCompletionTests = [ nonLocalCompletionTests :: [TestTree] nonLocalCompletionTests = - [ brokenForWinGhc $ completionTest + [ brokenForWinOldGhc $ completionTest "variable" ["module A where", "f = hea"] (Position 1 7) @@ -276,6 +275,11 @@ nonLocalCompletionTests = ] 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 = [ @@ -352,7 +356,7 @@ packageCompletionTests = , "'GHC.Exts" ] ++ (["'GHC.IsList" | ghcVersion >= GHC94])) - , testSessionEmpty "Map" $ do + , 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", diff --git a/ghcide/test/exe/CradleTests.hs b/ghcide/test/exe/CradleTests.hs index 1b1ac631e5..cdfbb06ea2 100644 --- a/ghcide/test/exe/CradleTests.hs +++ b/ghcide/test/exe/CradleTests.hs @@ -3,17 +3,23 @@ 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 @@ -24,11 +30,6 @@ import Language.LSP.Protocol.Types hiding import Language.LSP.Test import System.FilePath import System.IO.Extra hiding (withTempDir) --- import Test.QuickCheck.Instances () -import Config -import Control.Lens ((^.)) -import Development.IDE.Plugin.Test (WaitForIdeRuleResult (..)) -import GHC.TypeLits (symbolVal) import Test.Hls (ignoreForGhcVersions) import Test.Tasty import Test.Tasty.HUnit diff --git a/ghcide/test/exe/ExceptionTests.hs b/ghcide/test/exe/ExceptionTests.hs index ad53c97bb3..756e7e0547 100644 --- a/ghcide/test/exe/ExceptionTests.hs +++ b/ghcide/test/exe/ExceptionTests.hs @@ -31,7 +31,6 @@ import LogType (Log (..)) import Test.Hls (TestConfig (testDisableDefaultPlugin, testPluginDescriptor), runSessionWithTestConfig, testCheckProject, - testConfigSession, waitForProgressDone) import Test.Tasty import Test.Tasty.HUnit diff --git a/ghcide/test/exe/FindDefinitionAndHoverTests.hs b/ghcide/test/exe/FindDefinitionAndHoverTests.hs index d315c84c75..63d8dd7ab7 100644 --- a/ghcide/test/exe/FindDefinitionAndHoverTests.hs +++ b/ghcide/test/exe/FindDefinitionAndHoverTests.hs @@ -136,7 +136,7 @@ tests = let 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 ", "GHC.Num", "base"]] + 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] @@ -159,7 +159,7 @@ tests = let holeL65 = Position 65 8 ; hleInfo2 = [ExpectHoverText ["_ :: a -> Maybe a"]] cccL17 = Position 17 16 ; docLink = [ExpectHoverTextRegex "\\*Defined in 'GHC.Types'\\* \\*\\(ghc-prim-[0-9.]+\\)\\*\n\n"] imported = Position 56 13 ; importedSig = getDocUri "Foo.hs" >>= \foo -> return [ExpectHoverText ["foo", "Foo", "Haddock"], mkL foo 5 0 5 3] - reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar", "Haddock"], mkL bar 3 (if ghcVersion >= GHC94 then 5 else 0) 3 (if ghcVersion >= GHC94 then 8 else 14)] + 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-"]] diff --git a/ghcide/test/exe/IfaceTests.hs b/ghcide/test/exe/IfaceTests.hs index 90d27c445b..330d372d73 100644 --- a/ghcide/test/exe/IfaceTests.hs +++ b/ghcide/test/exe/IfaceTests.hs @@ -18,7 +18,6 @@ import Language.LSP.Test import System.Directory import System.FilePath import System.IO.Extra hiding (withTempDir) -import Test.Hls.FileSystem (toAbsFp) import Test.Tasty import Test.Tasty.HUnit diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 14363f1aed..6c8091840d 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -29,7 +29,7 @@ module Main (main) where --- import Test.QuickCheck.Instances () + import qualified HieDbRetry import Test.Tasty import Test.Tasty.Ingredients.Rerun diff --git a/ghcide/test/exe/OutlineTests.hs b/ghcide/test/exe/OutlineTests.hs index 640e13a907..0d336a6bd0 100644 --- a/ghcide/test/exe/OutlineTests.hs +++ b/ghcide/test/exe/OutlineTests.hs @@ -7,6 +7,7 @@ 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) @@ -55,11 +56,11 @@ tests = [ docSymbolD "A a" "type family" SymbolKind_Function (R 1 0 1 15), docSymbol "A ()" SymbolKind_Interface (R 2 0 2 23) ], - testSymbolsA "data family" ["{-# language TypeFamilies #-}", "data family A"] [docSymbolD "A" "data family" SymbolKind_Function (R 1 0 1 11)], + testSymbolsA "data family" ["{-# 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 11), + [ 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)], diff --git a/ghcide/test/exe/PluginSimpleTests.hs b/ghcide/test/exe/PluginSimpleTests.hs index 80b16395bd..05eb76ba81 100644 --- a/ghcide/test/exe/PluginSimpleTests.hs +++ b/ghcide/test/exe/PluginSimpleTests.hs @@ -1,19 +1,14 @@ module PluginSimpleTests (tests) where +import Config import Control.Monad.IO.Class (liftIO) -import Development.IDE.GHC.Compat (GhcVersion (..)) import Development.IDE.Test (expectDiagnostics) import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..), SemanticTokenRelative (..), SemanticTokensEdit (..), mkRange) import Language.LSP.Test import System.FilePath --- import Test.QuickCheck.Instances () -import Config -import Test.Hls.Util (EnvSpec (..), OS (..), - knownBrokenForGhcVersions, - knownBrokenInSpecificEnv) import Test.Tasty tests :: TestTree diff --git a/ghcide/test/exe/ReferenceTests.hs b/ghcide/test/exe/ReferenceTests.hs index f15606ac9c..bc69a8fdbf 100644 --- a/ghcide/test/exe/ReferenceTests.hs +++ b/ghcide/test/exe/ReferenceTests.hs @@ -34,7 +34,7 @@ import Test.Hls (FromServerMessage' (..), SMethod (..), TCustomMessage (..), TNotificationMessage (..)) -import Test.Hls.FileSystem (copyDir, toAbsFp) +import Test.Hls.FileSystem (copyDir) import Test.Tasty import Test.Tasty.ExpectedFailure import Test.Tasty.HUnit diff --git a/ghcide/test/exe/THTests.hs b/ghcide/test/exe/THTests.hs index 61c2ef49f3..42a5650ed7 100644 --- a/ghcide/test/exe/THTests.hs +++ b/ghcide/test/exe/THTests.hs @@ -13,8 +13,6 @@ import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..), SemanticTokensEdit (..), mkRange) import Language.LSP.Test import System.FilePath -import Test.Hls (waitForAllProgressDone, - waitForProgressBegin) import Test.Tasty import Test.Tasty.HUnit @@ -180,7 +178,7 @@ thLinkingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do -- modify b too let bSource' = T.unlines $ init (T.lines bSource) ++ ["$th"] changeDoc bdoc [TextDocumentContentChangeEvent . InR $ TextDocumentContentChangeWholeDocument bSource'] - waitForDiagnostics + _ <- waitForDiagnostics expectCurrentDiagnostics bdoc [(DiagnosticSeverity_Warning, (4,1), "Top-level binding")] diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 5a415d2357..ce0e9797dd 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -14,7 +14,7 @@ copyright: The Haskell IDE Team license: Apache-2.0 license-file: LICENSE build-type: Simple -tested-with: GHC ==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 || ==9.2.8 extra-source-files: README.md ChangeLog.md @@ -207,7 +207,7 @@ test-suite hls-cabal-gild-plugin-tests , hls-test-utils == 2.8.0.0 if flag(isolateCabalGildTests) - build-tool-depends: cabal-gild:cabal-gild ^>=1.1 + build-tool-depends: cabal-gild:cabal-gild ^>=1.3 cpp-options: -Dhls_isolate_cabalgild_tests ----------------------------- @@ -290,8 +290,6 @@ test-suite hls-cabal-plugin-tests , lens , lsp-types , text - , text-rope - , transformers ----------------------------- -- class plugin @@ -325,7 +323,7 @@ library hls-class-plugin , deepseq , extra , ghc - , ghc-exactprint >= 1.5 + , ghc-exactprint >= 1.5 && < 1.10.0.0 , ghcide == 2.8.0.0 , hls-graph , hls-plugin-api == 2.8.0.0 @@ -1481,6 +1479,9 @@ test-suite hls-fourmolu-plugin-tests type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-fourmolu-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-tool-depends: fourmolu:fourmolu build-depends: @@ -1534,6 +1535,9 @@ test-suite hls-ormolu-plugin-tests type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-ormolu-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-tool-depends: ormolu:ormolu build-depends: @@ -1652,18 +1656,18 @@ library hls-refactor-plugin , containers , ghc-exactprint < 1 || >= 1.4 , extra - , retrie , syb , hls-graph , dlist , deepseq , mtl , lens - , data-default , time -- FIXME: Only needed to workaround for qualified imports in GHC 9.4 , regex-applicative , parser-combinators + if impl(ghc < 9.10) + build-depends: data-default test-suite hls-refactor-plugin-tests import: defaults, pedantic, test-defaults, warnings @@ -1824,7 +1828,6 @@ test-suite hls-notes-plugin-tests main-is: NotesTest.hs build-depends: , base - , directory , filepath , haskell-language-server:hls-notes-plugin , hls-test-utils == 2.8.0.0 @@ -2094,7 +2097,6 @@ test-suite ghcide-tests build-depends: , aeson - , async , base , containers , data-default @@ -2189,7 +2191,6 @@ executable ghcide-bench bytestring, containers, data-default, - directory, extra, filepath, hls-plugin-api, diff --git a/hie-compat/hie-compat.cabal b/hie-compat/hie-compat.cabal index aa0eb241fe..49bf9990a5 100644 --- a/hie-compat/hie-compat.cabal +++ b/hie-compat/hie-compat.cabal @@ -24,7 +24,7 @@ source-repository head library default-language: GHC2021 build-depends: - base < 4.20, array, bytestring, containers, directory, filepath, transformers + base < 4.21, array, bytestring, containers, directory, filepath, transformers build-depends: ghc >= 8.10, ghc-boot ghc-options: -Wall -Wno-name-shadowing diff --git a/hls-graph/hls-graph.cabal b/hls-graph/hls-graph.cabal index 5ac6691898..72adcc3cd1 100644 --- a/hls-graph/hls-graph.cabal +++ b/hls-graph/hls-graph.cabal @@ -136,7 +136,7 @@ test-suite tests , stm , stm-containers , tasty - , tasty-hspec + , tasty-hspec >= 1.2 , tasty-rerun build-tool-depends: hspec-discover:hspec-discover diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index 6729b9615d..359e5ceb6a 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -2,6 +2,7 @@ -- has the constraints we need on it when we get it out. {-# OPTIONS_GHC -Wno-redundant-constraints #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} @@ -27,7 +28,6 @@ import Data.Dynamic import Data.Either import Data.Foldable (for_, traverse_) import Data.IORef.Extra -import Data.List.NonEmpty (unzip) import Data.Maybe import Data.Traversable (for) import Data.Tuple.Extra @@ -42,6 +42,12 @@ import qualified StmContainers.Map as SMap import System.IO.Unsafe import System.Time.Extra (duration, sleep) +#if MIN_VERSION_base(4,19,0) +import Data.Functor (unzip) +#else +import Data.List.NonEmpty (unzip) +#endif + newDatabase :: Dynamic -> TheRules -> IO Database newDatabase databaseExtra databaseRules = do diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs b/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs index 408e3d2f12..5369c578f8 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs @@ -13,7 +13,7 @@ import qualified Data.ByteString.Lazy.Char8 as LBS import Data.Char import Data.Dynamic (toDyn) import qualified Data.HashMap.Strict as Map -import Data.List (dropWhileEnd, foldl', +import Data.List (dropWhileEnd, intercalate, partition, sort, sortBy) @@ -33,6 +33,10 @@ import System.FilePath import System.IO.Unsafe (unsafePerformIO) import System.Time.Extra (Seconds) +#if !MIN_VERSION_base(4,20,0) +import Data.List (foldl') +#endif + #ifdef FILE_EMBED import Data.FileEmbed import Language.Haskell.TH.Syntax (runIO) diff --git a/hls-plugin-api/src/Ide/Plugin/RangeMap.hs b/hls-plugin-api/src/Ide/Plugin/RangeMap.hs index 8ec62e68e6..7b1887a802 100644 --- a/hls-plugin-api/src/Ide/Plugin/RangeMap.hs +++ b/hls-plugin-api/src/Ide/Plugin/RangeMap.hs @@ -16,9 +16,9 @@ module Ide.Plugin.RangeMap ) where import Development.IDE.Graph.Classes (NFData) + #ifdef USE_FINGERTREE import Data.Bifunctor (first) -import Data.Foldable (foldl') import qualified HaskellWorks.Data.IntervalMap.FingerTree as IM import Language.LSP.Protocol.Types (Position, Range (Range)) @@ -26,6 +26,10 @@ import Language.LSP.Protocol.Types (Position, import Language.LSP.Protocol.Types (Range, isSubrangeOf) #endif +#if USE_FINGERTREE && !MIN_VERSION_base(4,20,0) +import Data.List (foldl') +#endif + -- | A map from code ranges to values. #ifdef USE_FINGERTREE newtype RangeMap a = RangeMap diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index e3ef9de47f..f786b6aac9 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -72,7 +72,6 @@ import Data.Default import Data.Dependent.Map (DMap) import qualified Data.Dependent.Map as DMap import qualified Data.DList as DList -import Data.Foldable (foldl') import Data.GADT.Compare import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) @@ -106,6 +105,11 @@ import System.FilePath import System.IO.Unsafe import Text.Regex.TDFA.Text () import UnliftIO (MonadUnliftIO) + +#if !MIN_VERSION_base(4,20,0) +import Data.Foldable (foldl') +#endif + -- --------------------------------------------------------------------- data IdePlugins ideState = IdePlugins_ diff --git a/hls-plugin-api/test/Ide/PluginUtilsTest.hs b/hls-plugin-api/test/Ide/PluginUtilsTest.hs index 9d49ac276d..1fa1ace39b 100644 --- a/hls-plugin-api/test/Ide/PluginUtilsTest.hs +++ b/hls-plugin-api/test/Ide/PluginUtilsTest.hs @@ -7,15 +7,11 @@ module Ide.PluginUtilsTest ) where import qualified Data.Aeson as A -import qualified Data.Aeson.Text as A import qualified Data.Aeson.Types as A import Data.ByteString.Lazy (ByteString) -import Data.Char (isPrint) import Data.Function ((&)) import qualified Data.Set as Set import qualified Data.Text as T -import qualified Data.Text.Lazy as Tl -import Debug.Trace (trace, traceM) import Ide.Plugin.Properties (KeyNamePath (..), definePropertiesProperty, defineStringProperty, diff --git a/plugins/hls-cabal-gild-plugin/test/testdata/lib_testdata.formatted_document.cabal b/plugins/hls-cabal-gild-plugin/test/testdata/lib_testdata.formatted_document.cabal index f8ca530630..a29e590238 100644 --- a/plugins/hls-cabal-gild-plugin/test/testdata/lib_testdata.formatted_document.cabal +++ b/plugins/hls-cabal-gild-plugin/test/testdata/lib_testdata.formatted_document.cabal @@ -17,4 +17,5 @@ executable testdata testdata, hs-source-dirs: app - default-language: Haskell2010 + default-language: + Haskell2010 diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs index 3c14196459..eb9fed55d7 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs @@ -224,8 +224,9 @@ kick = do -- ---------------------------------------------------------------- licenseSuggestCodeAction :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction -licenseSuggestCodeAction _ _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=diags}) = - pure $ InL $ diags >>= (fmap InR . LicenseSuggest.licenseErrorAction uri) +licenseSuggestCodeAction ideState _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=diags}) = do + maxCompls <- fmap maxCompletions . liftIO $ runAction "cabal-plugin.suggestLicense" ideState getClientConfigAction + pure $ InL $ diags >>= (fmap InR . LicenseSuggest.licenseErrorAction maxCompls uri) -- ---------------------------------------------------------------- -- Cabal file of Interest rules and global variable diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/LicenseSuggest.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/LicenseSuggest.hs index c8f2f29ec6..7da1277289 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/LicenseSuggest.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/LicenseSuggest.hs @@ -31,13 +31,12 @@ import qualified Text.Fuzzy.Parallel as Fuzzy -- with a suggestion, then return a 'CodeAction' for replacing the -- the incorrect license identifier with the suggestion. licenseErrorAction - :: Uri - -- ^ File for which the diagnostic was generated - -> Diagnostic - -- ^ Output of 'Ide.Plugin.Cabal.Diag.errorDiagnostic' + :: Int -- ^ Maximum number of suggestions to return + -> Uri -- ^ File for which the diagnostic was generated + -> Diagnostic -- ^ Output of 'Ide.Plugin.Cabal.Diag.errorDiagnostic' -> [CodeAction] -licenseErrorAction uri diag = - mkCodeAction <$> licenseErrorSuggestion (_message diag) +licenseErrorAction maxCompletions uri diag = + mkCodeAction <$> licenseErrorSuggestion maxCompletions (_message diag) where mkCodeAction (original, suggestion) = let @@ -66,22 +65,22 @@ licenseNames = map (T.pack . licenseId) [minBound .. maxBound] -- Results are sorted by best fit, and prefer solutions that have smaller -- length distance to the original word. -- --- >>> take 2 $ licenseErrorSuggestion (T.pack "Unknown SPDX license identifier: 'BSD3'") +-- >>> licenseErrorSuggestion 2 (T.pack "Unknown SPDX license identifier: 'BSD3'") -- [("BSD3","BSD-3-Clause"),("BSD3","BSD-3-Clause-LBNL")] licenseErrorSuggestion :: - T.Text - -- ^ Output of 'Ide.Plugin.Cabal.Diag.errorDiagnostic' + Int -- ^ Maximum number of suggestions to return + -> T.Text -- ^ Output of 'Ide.Plugin.Cabal.Diag.errorDiagnostic' -> [(T.Text, T.Text)] -- ^ (Original (incorrect) license identifier, suggested replacement) -licenseErrorSuggestion msg = +licenseErrorSuggestion maxCompletions msg = (getMatch <$> msg =~~ regex) >>= \case [original] -> - let matches = map Fuzzy.original $ Fuzzy.simpleFilter Fuzzy.defChunkSize Fuzzy.defMaxResults original licenseNames - in [(original,candidate) | candidate <- List.sortBy (lengthDistance original) matches] + let matches = map Fuzzy.original $ Fuzzy.simpleFilter Fuzzy.defChunkSize maxCompletions original licenseNames + in [(original,candidate) | candidate <- List.sortOn (lengthDistance original) matches] _ -> [] where regex :: T.Text regex = "Unknown SPDX license identifier: '(.*)'" getMatch :: (T.Text, T.Text, T.Text, [T.Text]) -> [T.Text] getMatch (_, _, _, results) = results - lengthDistance original x1 x2 = abs (T.length original - T.length x1) `compare` abs (T.length original - T.length x2) + lengthDistance original x = abs $ T.length original - T.length x diff --git a/plugins/hls-cabal-plugin/test/Main.hs b/plugins/hls-cabal-plugin/test/Main.hs index 132abb5162..6488e71e16 100644 --- a/plugins/hls-cabal-plugin/test/Main.hs +++ b/plugins/hls-cabal-plugin/test/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} @@ -60,15 +61,23 @@ codeActionUnitTests = "Code Action Tests" [ testCase "Unknown format" $ do -- the message has the wrong format - licenseErrorSuggestion "Unknown license identifier: 'BSD3' Do you mean BSD-3-Clause?" @?= [] + licenseErrorSuggestion maxCompletions "Unknown license identifier: 'BSD3' Do you mean BSD-3-Clause?" @?= [] , testCase "BSD-3-Clause" $ do - take 2 (licenseErrorSuggestion "Unknown SPDX license identifier: 'BSD3' Do you mean BSD-3-Clause?") - @?= [("BSD3", "BSD-3-Clause"), ("BSD3", "BSD-3-Clause-LBNL")] + take 2 (licenseErrorSuggestion maxCompletions "Unknown SPDX license identifier: 'BSD3' Do you mean BSD-3-Clause?") + @?= +-- Cabal-syntax 3.12.0.0 added bunch of new licenses, so now more licenses match "BSD3" pattern +#if MIN_VERSION_Cabal_syntax(3,12,0) + [("BSD3", "BSD-4.3RENO"), ("BSD3", "BSD-3-Clause")] +#else + [("BSD3", "BSD-3-Clause"), ("BSD3", "BSD-3-Clause-LBNL")] +#endif , testCase "MiT" $ do -- contains no suggestion - take 2 (licenseErrorSuggestion "Unknown SPDX license identifier: 'MiT'") + take 2 (licenseErrorSuggestion maxCompletions "Unknown SPDX license identifier: 'MiT'") @?= [("MiT", "MIT"), ("MiT", "MIT-0")] ] + where + maxCompletions = 100 -- ------------------------ ------------------------------------------------ -- Integration Tests diff --git a/plugins/hls-call-hierarchy-plugin/test/Main.hs b/plugins/hls-call-hierarchy-plugin/test/Main.hs index 11ac776154..f356a0e278 100644 --- a/plugins/hls-call-hierarchy-plugin/test/Main.hs +++ b/plugins/hls-call-hierarchy-plugin/test/Main.hs @@ -113,13 +113,14 @@ prepareCallHierarchyTests = , testGroup "data family" [ testCase "1" $ do let contents = T.unlines ["{-# LANGUAGE TypeFamilies #-}", "data family A"] - range = mkRange 1 0 1 11 + -- 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) 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 11 + range = mkRange 1 0 1 (if ghcVersion == GHC910 then 15 else 11) selRange = mkRange 1 12 1 13 expected = mkCallHierarchyItemT "A" SymbolKind_Function range selRange oneCaseWithCreate contents 1 12 expected diff --git a/plugins/hls-change-type-signature-plugin/test/Main.hs b/plugins/hls-change-type-signature-plugin/test/Main.hs index da7e789b61..d34e19ea4f 100644 --- a/plugins/hls-change-type-signature-plugin/test/Main.hs +++ b/plugins/hls-change-type-signature-plugin/test/Main.hs @@ -39,7 +39,8 @@ test :: TestTree test = testGroup "changeTypeSignature" [ testRegexes , codeActionTest "TExpectedActual" 4 11 - , knownBrokenForGhcVersions [GHC92, GHC94, GHC96, GHC98] "Error Message in 9.2/9.4 does not provide enough info" $ codeActionTest "TRigidType" 4 14 + , knownBrokenForGhcVersions [GHC92 .. GHC910] "Error Message in 9.2+ does not provide enough info" $ + codeActionTest "TRigidType" 4 14 , codeActionTest "TRigidType2" 4 6 , codeActionTest "TLocalBinding" 7 22 , codeActionTest "TLocalBindingShadow1" 11 8 diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/ExactPrint.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/ExactPrint.hs index 3d5f63e607..11afcfd1c4 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/ExactPrint.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/ExactPrint.hs @@ -5,22 +5,30 @@ module Ide.Plugin.Class.ExactPrint where import Control.Monad.Trans.Maybe +import Data.Either.Extra (eitherToMaybe) +import Data.Functor.Identity (Identity) import qualified Data.Text as T import Development.IDE.GHC.Compat +import GHC.Parser.Annotation import Ide.Plugin.Class.Types import Ide.Plugin.Class.Utils import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Parsers - -import Data.Either.Extra (eitherToMaybe) -import Data.Functor.Identity (Identity) -import GHC.Parser.Annotation import Language.LSP.Protocol.Types (Range) +#if MIN_VERSION_ghc(9,9,0) +import Control.Lens (_head, over) +#endif + makeEditText :: Monad m => ParsedModule -> DynFlags -> AddMinimalMethodsParams -> MaybeT m (T.Text, T.Text) makeEditText pm df AddMinimalMethodsParams{..} = do mDecls <- MaybeT . pure $ traverse (makeMethodDecl df) methodGroup - let ps = makeDeltaAst $ pm_parsed_source pm + let ps = +#if !MIN_VERSION_ghc(9,9,0) + makeDeltaAst $ +#endif + pm_parsed_source pm + old = T.pack $ exactPrint ps (ps', _, _) = runTransform (addMethodDecls ps mDecls range withSig) new = T.pack $ exactPrint ps' @@ -44,8 +52,32 @@ addMethodDecls ps mDecls range withSig go inserting = do allDecls <- hsDecls ps case break (inRange range . getLoc) allDecls of - (before, L l inst : after) -> replaceDecls ps (before ++ L l (addWhere inst):(map newLine inserting ++ after)) - (before, []) -> replaceDecls ps before + (before, L l inst : after) -> + let + instSpan = realSrcSpan $ getLoc l + instCol = srcSpanStartCol instSpan +#if MIN_VERSION_ghc(9,9,0) + instRow = srcSpanEndLine instSpan + methodEpAnn = noAnnSrcSpanDP $ deltaPos 1 (instCol + defaultIndent) + -- Put each TyCl method/type signature on separate line, indented by 2 spaces relative to instance decl + newLine (L _ e) = L methodEpAnn e + + -- Set DeltaPos for following declarations so they don't move undesirably + resetFollowing = + over _head (\followingDecl -> + let followingDeclRow = srcSpanStartLine $ realSrcSpan $ getLoc followingDecl + delta = DifferentLine (followingDeclRow - instRow) instCol + in setEntryDP followingDecl delta) +#else + newLine (L l e) = + let dp = deltaPos 1 (instCol + defaultIndent - 1) + in L (noAnnSrcSpanDP (getLoc l) dp <> l) e + + resetFollowing = id +#endif + in replaceDecls ps (before ++ L l (addWhere inst):(map newLine inserting ++ resetFollowing after)) + (before, []) -> + replaceDecls ps before -- Add `where` keyword for `instance X where` if `where` is missing. -- @@ -56,20 +88,29 @@ addMethodDecls ps mDecls range withSig -- -- See the link for the original definition: -- https://hackage.haskell.org/package/ghc-9.2.1/docs/Language-Haskell-Syntax-Extension.html#t:XCClsInstDecl + addWhere :: HsDecl GhcPs -> HsDecl GhcPs addWhere instd@(InstD xInstD (ClsInstD ext decl@ClsInstDecl{..})) = case cid_ext of - (EpAnn entry anns comments, key) -> +#if MIN_VERSION_ghc(9,9,0) + (warnings, anns, key) + | any (\(AddEpAnn kw _ )-> kw == AnnWhere) anns -> instd + | otherwise -> InstD xInstD (ClsInstD ext decl { - cid_ext = (EpAnn - entry - (AddEpAnn AnnWhere (EpaDelta (SameLine 1) []) : anns) - comments - , key) + cid_ext = ( warnings + , AddEpAnn AnnWhere d1 : anns + , key + ) }) +#else + (EpAnn entry anns comments, key) -> + InstD xInstD (ClsInstD ext decl { + cid_ext = (EpAnn + entry + (AddEpAnn AnnWhere d1 : anns) + comments + , key + ) + }) _ -> instd +#endif addWhere decl = decl - - newLine (L l e) = - let dp = deltaPos 1 defaultIndent - in L (noAnnSrcSpanDP (getLoc l) dp <> l) e - diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs index f62efd5ccc..18c9dbae26 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs @@ -133,7 +133,11 @@ data BindInfo = BindInfo getInstanceBindLensRule :: Recorder (WithPriority Log) -> Rules () getInstanceBindLensRule recorder = do defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \GetInstanceBindLens nfp -> runMaybeT $ do +#if MIN_VERSION_ghc(9,9,0) + tmr@(tmrRenamed -> (hs_tyclds -> tycls, _, _, _, _)) <- useMT TypeCheck nfp +#else tmr@(tmrRenamed -> (hs_tyclds -> tycls, _, _, _)) <- useMT TypeCheck nfp +#endif (InstanceBindTypeSigsResult allBinds) <- useMT GetInstanceBindTypeSigs nfp let -- declared instance methods without signatures diff --git a/plugins/hls-class-plugin/test/Main.hs b/plugins/hls-class-plugin/test/Main.hs index ea4da718ff..7f1feddc11 100644 --- a/plugins/hls-class-plugin/test/Main.hs +++ b/plugins/hls-class-plugin/test/Main.hs @@ -63,9 +63,10 @@ codeActionTests = testGroup getActionByTitle "Add placeholders for 'g'" , goldenWithClass "Creates a placeholder for other two methods" "T6" "2" $ getActionByTitle "Add placeholders for 'g','h'" - , onlyRunForGhcVersions [GHC92, GHC94] "Only ghc-9.2+ enabled GHC2021 implicitly" $ - goldenWithClass "Don't insert pragma with GHC2021" "InsertWithGHC2021Enabled" "" $ - getActionByTitle "Add placeholders for '==' with signature(s)" + , goldenWithClass "Creates a placeholder when all top-level decls are indented" "T7" "" $ + getActionByTitle "Add placeholders for 'g','h','i'" + , goldenWithClass "Don't insert pragma with GHC2021" "InsertWithGHC2021Enabled" "" $ + getActionByTitle "Add placeholders for '==' with signature(s)" , goldenWithClass "Insert pragma if not exist" "InsertWithoutPragma" "" $ getActionByTitle "Add placeholders for '==' with signature(s)" , goldenWithClass "Don't insert pragma if exist" "InsertWithPragma" "" $ @@ -132,8 +133,7 @@ codeLensTests = testGroup , goldenCodeLens "Apply code lens for local class" "LocalClassDefine" 0 , goldenCodeLens "Apply code lens on the same line" "Inline" 0 , goldenCodeLens "Don't insert pragma while existing" "CodeLensWithPragma" 0 - , onlyRunForGhcVersions [GHC92, GHC94] "Only ghc-9.2+ enabled GHC2021 implicitly" $ - goldenCodeLens "Don't insert pragma while GHC2021 enabled" "CodeLensWithGHC2021" 0 + , goldenCodeLens "Don't insert pragma while GHC2021 enabled" "CodeLensWithGHC2021" 0 , goldenCodeLens "Qualified name" "Qualified" 0 , goldenCodeLens "Type family" "TypeFamily" 0 , testCase "keep stale lens" $ do diff --git a/plugins/hls-class-plugin/test/testdata/T5.expected.hs b/plugins/hls-class-plugin/test/testdata/T5.expected.hs index 6c26425f34..fcc51c0787 100644 --- a/plugins/hls-class-plugin/test/testdata/T5.expected.hs +++ b/plugins/hls-class-plugin/test/testdata/T5.expected.hs @@ -1,4 +1,4 @@ -module T1 where +module T5 where data X = X diff --git a/plugins/hls-class-plugin/test/testdata/T5.hs b/plugins/hls-class-plugin/test/testdata/T5.hs index e7dc1d4da3..d33dd8b17c 100644 --- a/plugins/hls-class-plugin/test/testdata/T5.hs +++ b/plugins/hls-class-plugin/test/testdata/T5.hs @@ -1,4 +1,4 @@ -module T1 where +module T5 where data X = X diff --git a/plugins/hls-class-plugin/test/testdata/T7.expected.hs b/plugins/hls-class-plugin/test/testdata/T7.expected.hs new file mode 100644 index 0000000000..5bf716c900 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/T7.expected.hs @@ -0,0 +1,20 @@ +module T7 where + + data X = X + + class Test a where + f :: a -> a + g :: a + h :: a -> a + i :: a + + instance Test X where + f X = X + g = _ + h = _ + i = _ + + + + + whiteSpaceBeforeAndIndentationOfThisShouldBePreserved = () diff --git a/plugins/hls-class-plugin/test/testdata/T7.hs b/plugins/hls-class-plugin/test/testdata/T7.hs new file mode 100644 index 0000000000..2f9a1b67f6 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/T7.hs @@ -0,0 +1,17 @@ +module T7 where + + data X = X + + class Test a where + f :: a -> a + g :: a + h :: a -> a + i :: a + + instance Test X where + f X = X + + + + + whiteSpaceBeforeAndIndentationOfThisShouldBePreserved = () diff --git a/plugins/hls-code-range-plugin/test/Main.hs b/plugins/hls-code-range-plugin/test/Main.hs index 88eac8eafd..da32deed51 100644 --- a/plugins/hls-code-range-plugin/test/Main.hs +++ b/plugins/hls-code-range-plugin/test/Main.hs @@ -35,7 +35,7 @@ main = do ] selectionRangeGoldenTest :: TestName -> [(UInt, UInt)] -> TestTree -selectionRangeGoldenTest testName positions = goldenGitDiff testName (testDataDir testName <.> "golden" <.> "txt") $ do +selectionRangeGoldenTest testName positions = goldenGitDiff testName (testDataDir testName <.> "golden" <.> "txt" <> ghcSuffix) $ do res <- runSessionWithServer def plugin testDataDir $ do doc <- openDoc (testName <.> "hs") "haskell" resp <- request SMethod_TextDocumentSelectionRange $ SelectionRangeParams Nothing Nothing doc @@ -65,7 +65,7 @@ selectionRangeGoldenTest testName positions = goldenGitDiff testName (testDataDi showLBS = fromString . show foldingRangeGoldenTest :: TestName -> TestTree -foldingRangeGoldenTest testName = goldenGitDiff testName (testDataDir testName <.> "golden" <.> "txt") $ do +foldingRangeGoldenTest testName = goldenGitDiff testName (testDataDir testName <.> "golden" <.> "txt" <> ghcSuffix) $ do res <- runSessionWithServer def plugin testDataDir $ do doc <- openDoc (testName <.> "hs") "haskell" resp <- request SMethod_TextDocumentFoldingRange $ FoldingRangeParams Nothing Nothing doc @@ -91,3 +91,6 @@ foldingRangeGoldenTest testName = goldenGitDiff testName (testDataDir testN showLBS = fromString . show showFRK = fromString . show + +ghcSuffix :: String +ghcSuffix = if ghcVersion >= GHC910 then ".ghc910" else "" diff --git a/plugins/hls-code-range-plugin/test/testdata/folding-range/Function.golden.txt.ghc910 b/plugins/hls-code-range-plugin/test/testdata/folding-range/Function.golden.txt.ghc910 new file mode 100644 index 0000000000..937654b5b7 --- /dev/null +++ b/plugins/hls-code-range-plugin/test/testdata/folding-range/Function.golden.txt.ghc910 @@ -0,0 +1,42 @@ +((2, 7) : (2, 15)) : FoldingRangeKind_Region +((2, 16) : (2, 22)) : FoldingRangeKind_Region +((4, 0) : (7, 21)) : FoldingRangeKind_Region +((4, 0) : (4, 25)) : FoldingRangeKind_Region +((4, 0) : (4, 6)) : FoldingRangeKind_Region +((4, 10) : (4, 25)) : FoldingRangeKind_Region +((4, 10) : (4, 17)) : FoldingRangeKind_Region +((4, 21) : (4, 25)) : FoldingRangeKind_Region +((5, 0) : (7, 21)) : FoldingRangeKind_Region +((5, 0) : (5, 6)) : FoldingRangeKind_Region +((5, 7) : (5, 8)) : FoldingRangeKind_Region +((5, 9) : (7, 21)) : FoldingRangeKind_Region +((5, 11) : (7, 21)) : FoldingRangeKind_Region +((5, 14) : (5, 28)) : FoldingRangeKind_Region +((5, 14) : (5, 23)) : FoldingRangeKind_Region +((5, 14) : (5, 15)) : FoldingRangeKind_Region +((5, 16) : (5, 21)) : FoldingRangeKind_Region +((5, 22) : (5, 23)) : FoldingRangeKind_Region +((5, 24) : (5, 26)) : FoldingRangeKind_Region +((5, 27) : (5, 28)) : FoldingRangeKind_Region +((6, 16) : (6, 20)) : FoldingRangeKind_Region +((7, 16) : (7, 21)) : FoldingRangeKind_Region +((9, 0) : (12, 20)) : FoldingRangeKind_Region +((9, 0) : (9, 24)) : FoldingRangeKind_Region +((9, 0) : (9, 5)) : FoldingRangeKind_Region +((9, 9) : (9, 24)) : FoldingRangeKind_Region +((9, 9) : (9, 16)) : FoldingRangeKind_Region +((9, 20) : (9, 24)) : FoldingRangeKind_Region +((10, 0) : (12, 20)) : FoldingRangeKind_Region +((10, 0) : (10, 5)) : FoldingRangeKind_Region +((10, 6) : (10, 7)) : FoldingRangeKind_Region +((10, 8) : (12, 20)) : FoldingRangeKind_Region +((10, 10) : (12, 20)) : FoldingRangeKind_Region +((10, 13) : (10, 27)) : FoldingRangeKind_Region +((10, 13) : (10, 22)) : FoldingRangeKind_Region +((10, 13) : (10, 14)) : FoldingRangeKind_Region +((10, 15) : (10, 20)) : FoldingRangeKind_Region +((10, 21) : (10, 22)) : FoldingRangeKind_Region +((10, 23) : (10, 25)) : FoldingRangeKind_Region +((10, 26) : (10, 27)) : FoldingRangeKind_Region +((11, 16) : (11, 21)) : FoldingRangeKind_Region +((12, 16) : (12, 20)) : FoldingRangeKind_Region diff --git a/plugins/hls-code-range-plugin/test/testdata/selection-range/Empty.golden.txt.ghc910 b/plugins/hls-code-range-plugin/test/testdata/selection-range/Empty.golden.txt.ghc910 new file mode 100644 index 0000000000..7689c89086 --- /dev/null +++ b/plugins/hls-code-range-plugin/test/testdata/selection-range/Empty.golden.txt.ghc910 @@ -0,0 +1 @@ +(1,5) (1,5) \ No newline at end of file diff --git a/plugins/hls-code-range-plugin/test/testdata/selection-range/Function.golden.txt.ghc910 b/plugins/hls-code-range-plugin/test/testdata/selection-range/Function.golden.txt.ghc910 new file mode 100644 index 0000000000..eb359fb12b --- /dev/null +++ b/plugins/hls-code-range-plugin/test/testdata/selection-range/Function.golden.txt.ghc910 @@ -0,0 +1,4 @@ +(5,16) (5,20) => (5,16) (5,40) => (5,14) (5,40) => (5,1) (11,20) => (4,1) (11,20) => (3,1) (11,20) => (1,8) (14,15) +(5,12) (5,13) => (5,1) (11,20) => (4,1) (11,20) => (3,1) (11,20) => (1,8) (14,15) +(4,1) (4,9) => (4,1) (4,29) => (4,1) (11,20) => (3,1) (11,20) => (1,8) (14,15) +(3,1) (3,9) => (3,1) (3,61) => (3,1) (11,20) => (1,8) (14,15) \ No newline at end of file diff --git a/plugins/hls-code-range-plugin/test/testdata/selection-range/Import.golden.txt.ghc910 b/plugins/hls-code-range-plugin/test/testdata/selection-range/Import.golden.txt.ghc910 new file mode 100644 index 0000000000..4011ddb913 --- /dev/null +++ b/plugins/hls-code-range-plugin/test/testdata/selection-range/Import.golden.txt.ghc910 @@ -0,0 +1,2 @@ +(4,33) (4,38) => (4,32) (4,47) => (4,1) (4,47) => (3,1) (4,47) => (1,8) (4,47) +(1,8) (1,22) => (1,8) (4,47) \ No newline at end of file diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs index 07667cc1bd..6f8b303302 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -24,7 +25,7 @@ import Data.Function ((&)) import Data.Functor ((<&>)) import Data.Functor.Identity import Data.List.NonEmpty (NonEmpty ((:|))) -import qualified Data.List.NonEmpty as NE +import qualified Data.List.NonEmpty as NE hiding (unzip) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import qualified Data.Text as T @@ -40,6 +41,12 @@ import Text.Megaparsec.Char (alphaNumChar, char, eol, hspace, letterChar) +#if MIN_VERSION_base(4,19,0) +import qualified Data.Functor as NE (unzip) +#else +import qualified Data.List.NonEmpty as NE (unzip) +#endif + {- We build parsers combining the following three kinds of them: diff --git a/plugins/hls-eval-plugin/test/Main.hs b/plugins/hls-eval-plugin/test/Main.hs index ceb1620bac..10158531d2 100644 --- a/plugins/hls-eval-plugin/test/Main.hs +++ b/plugins/hls-eval-plugin/test/Main.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} @@ -85,7 +84,6 @@ tests = , goldenWithEval "Shows a kind with :kind" "T12" "hs" , goldenWithEval "Reports an error for an incorrect type with :kind" "T13" "hs" , goldenWithEval' "Returns a fully-instantiated type for :type" "T14" "hs" (if ghcVersion >= GHC98 then "ghc98.expected" else "expected") -- See https://gitlab.haskell.org/ghc/ghc/-/issues/24069 - , knownBrokenForGhcVersions [GHC92, GHC94, GHC96, GHC98] "type +v does not work anymore with 9.2" $ goldenWithEval "Returns an uninstantiated type for :type +v, admitting multiple whitespaces around arguments" "T15" "hs" , goldenWithEval "Doesn't break in module containing main function" "T4139" "hs" , goldenWithEval "Returns defaulted type for :type +d, admitting multiple whitespaces around arguments" "T16" "hs" , goldenWithEval ":type reports an error when given with unknown +x option" "T17" "hs" @@ -128,16 +126,14 @@ tests = , 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" $ goldenWithEvalAndFs' "Property checking with exception" cabalProjectFS "TPropertyError" "hs" ( - if ghcVersion >= GHC98 then - "ghc98.expected" - else if ghcVersion >= GHC96 then - "ghc96.expected" - else if ghcVersion >= GHC94 then - "ghc94.expected" - else - "expected" - ) + , knownBrokenInEnv [HostOS Windows] "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 + 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" diff --git a/plugins/hls-eval-plugin/test/testdata/T15.expected.hs b/plugins/hls-eval-plugin/test/testdata/T15.expected.hs deleted file mode 100644 index 54f0f38ef5..0000000000 --- a/plugins/hls-eval-plugin/test/testdata/T15.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE TypeApplications #-} -module T15 where - -foo :: Show a => a -> String -foo = show - --- >>> :type +v foo @Int --- foo @Int :: Show Int => Int -> String diff --git a/plugins/hls-eval-plugin/test/testdata/T15.hs b/plugins/hls-eval-plugin/test/testdata/T15.hs deleted file mode 100644 index 684333fbbd..0000000000 --- a/plugins/hls-eval-plugin/test/testdata/T15.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE TypeApplications #-} -module T15 where - -foo :: Show a => a -> String -foo = show - --- >>> :type +v foo @Int diff --git a/plugins/hls-eval-plugin/test/testdata/TPropertyError.ghc910.expected.hs b/plugins/hls-eval-plugin/test/testdata/TPropertyError.ghc910.expected.hs new file mode 100644 index 0000000000..e3208e37f5 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TPropertyError.ghc910.expected.hs @@ -0,0 +1,13 @@ +-- Support for property checking +module TProperty where + +-- prop> \(l::[Bool]) -> head l +-- *** Failed! (after 1 test): +-- Exception: +-- Prelude.head: empty list +-- CallStack (from HasCallStack): +-- error, called at libraries/ghc-internal/src/GHC/Internal/List.hs:2030:3 in ghc-internal:GHC.Internal.List +-- errorEmptyList, called at libraries/ghc-internal/src/GHC/Internal/List.hs:96:11 in ghc-internal:GHC.Internal.List +-- badHead, called at libraries/ghc-internal/src/GHC/Internal/List.hs:90:28 in ghc-internal:GHC.Internal.List +-- head, called at :1:27 in interactive:Ghci2 +-- [] diff --git a/plugins/hls-eval-plugin/test/testdata/TPropertyError.expected.hs b/plugins/hls-eval-plugin/test/testdata/TPropertyError.ghc92.expected.hs similarity index 100% rename from plugins/hls-eval-plugin/test/testdata/TPropertyError.expected.hs rename to plugins/hls-eval-plugin/test/testdata/TPropertyError.ghc92.expected.hs diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index c3e6de6091..13526c0535 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -360,7 +360,11 @@ extractMinimalImports :: extractMinimalImports hsc TcModuleResult {..} = runMaybeT $ do -- extract the original imports and the typechecking environment let tcEnv = tmrTypechecked +#if MIN_VERSION_ghc(9,9,0) + (_, imports, _, _, _) = tmrRenamed +#else (_, imports, _, _) = tmrRenamed +#endif ParsedModule {pm_parsed_source = L loc _} = tmrParsed emss = exportedModuleStrings tmrParsed Just srcSpan <- pure $ realSpan loc diff --git a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs index 75d6e06ed8..a1a2017c8d 100644 --- a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs +++ b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs @@ -35,7 +35,6 @@ import Development.IDE.Core.RuleTypes (TcModuleResult (..), TypeCheck (..)) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat (HsConDetails (RecCon), - HsExpansion (HsExpanded), HsExpr (XExpr), HsRecFields (..), LPat, Outputable, getLoc, @@ -82,6 +81,11 @@ import Language.LSP.Protocol.Types (CodeAction (..), WorkspaceEdit (WorkspaceEdit), type (|?) (InL, InR)) +#if __GLASGOW_HASKELL__ < 910 +import Development.IDE.GHC.Compat (HsExpansion (HsExpanded)) +#else +import Development.IDE.GHC.Compat (XXExprGhcRn (..)) +#endif data Log = LogShake Shake.Log @@ -176,8 +180,11 @@ collectRecordsRule recorder = toRangeAndUnique (uid, recordInfo) = (recordInfoToRange recordInfo, uid) getRecords :: TcModuleResult -> [RecordInfo] -getRecords (tmrRenamed -> (hs_valds -> valBinds,_,_,_)) = - collectRecords valBinds +#if __GLASGOW_HASKELL__ < 910 +getRecords (tmrRenamed -> (hs_valds -> valBinds,_,_,_)) = collectRecords valBinds +#else +getRecords (tmrRenamed -> (hs_valds -> valBinds,_,_,_, _)) = collectRecords valBinds +#endif collectNamesRule :: Rules () collectNamesRule = defineNoDiagnostics mempty $ \CollectNames nfp -> runMaybeT $ do @@ -187,7 +194,11 @@ collectNamesRule = defineNoDiagnostics mempty $ \CollectNames nfp -> runMaybeT $ -- | Collects all 'Name's of a given source file, to be used -- in the variable usage analysis. getNames :: TcModuleResult -> UniqFM Name [Name] -getNames (tmrRenamed -> (group,_,_,_)) = collectNames group +#if __GLASGOW_HASKELL__ < 910 +getNames (tmrRenamed -> (group,_,_,_)) = collectNames group +#else +getNames (tmrRenamed -> (group,_,_,_,_)) = collectNames group +#endif data CollectRecords = CollectRecords deriving (Eq, Show, Generic) @@ -357,7 +368,11 @@ getRecCons :: LHsExpr (GhcPass 'Renamed) -> ([RecordInfo], Bool) -- because there is a possibility that there were be more than one result per -- branch +#if __GLASGOW_HASKELL__ >= 910 +getRecCons (unLoc -> XExpr (ExpandedThingRn a _)) = (collectRecords a, True) +#else getRecCons (unLoc -> XExpr (HsExpanded a _)) = (collectRecords a, True) +#endif getRecCons e@(unLoc -> RecordCon _ _ flds) | isJust (rec_dotdot flds) = (mkRecInfo e, False) where diff --git a/plugins/hls-gadt-plugin/src/Ide/Plugin/GHC.hs b/plugins/hls-gadt-plugin/src/Ide/Plugin/GHC.hs index ec19f5e8f0..7db7b0378f 100644 --- a/plugins/hls-gadt-plugin/src/Ide/Plugin/GHC.hs +++ b/plugins/hls-gadt-plugin/src/Ide/Plugin/GHC.hs @@ -14,23 +14,37 @@ import Development.IDE import Development.IDE.GHC.Compat import Development.IDE.GHC.Compat.ExactPrint import GHC.Parser.Annotation (AddEpAnn (..), - Anchor (Anchor), - AnchorOperation (MovedAnchor), DeltaPos (..), EpAnn (..), - EpAnnComments (EpaComments), - EpaLocation (EpaDelta), - SrcSpanAnn' (SrcSpanAnn), - spanAsAnchor) + EpAnnComments (EpaComments)) import Ide.PluginUtils (subRange) -import Language.Haskell.GHC.ExactPrint (showAst) import Language.Haskell.GHC.ExactPrint.Parsers (parseDecl) +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] + #if MIN_VERSION_ghc(9,5,0) import qualified Data.List.NonEmpty as NE +#endif + +#if MIN_VERSION_ghc(9,5,0) && !MIN_VERSION_ghc(9,9,0) import GHC.Parser.Annotation (TokenLocation (..)) #endif +#if !MIN_VERSION_ghc(9,9,0) +import GHC.Parser.Annotation (Anchor (Anchor), + AnchorOperation (MovedAnchor), + SrcSpanAnn' (SrcSpanAnn), + spanAsAnchor) +#endif + +#if MIN_VERSION_ghc(9,9,0) +import GHC.Parser.Annotation (EpUniToken (..), + EpaLocation' (..), + noAnn) +import Language.Haskell.GHC.ExactPrint.Utils (showAst) +#endif + + type GP = GhcPass Parsed -- | Check if a given range is in the range of located item @@ -83,14 +97,18 @@ h98ToGADTConDecl :: h98ToGADTConDecl dataName tyVars ctxt = \case ConDeclH98{..} -> ConDeclGADT +#if MIN_VERSION_ghc(9,9,0) + (NoEpUniTok, con_ext) +#else con_ext +#endif #if MIN_VERSION_ghc(9,5,0) (NE.singleton con_name) #else [con_name] #endif -#if MIN_VERSION_ghc(9,5,0) +#if MIN_VERSION_ghc(9,5,0) && !MIN_VERSION_ghc(9,9,0) (L NoTokenLoc HsNormalTok) #endif -- Ignore all existential type variable since GADT not needed @@ -103,9 +121,19 @@ h98ToGADTConDecl dataName tyVars ctxt = \case where -- Parameters in the data constructor renderDetails :: HsConDeclH98Details GP -> HsConDeclGADTDetails GP +#if MIN_VERSION_ghc(9,9,0) + renderDetails (PrefixCon _ args) = PrefixConGADT noExtField args +#else renderDetails (PrefixCon _ args) = PrefixConGADT args +#endif +#if MIN_VERSION_ghc(9,9,0) + renderDetails (InfixCon arg1 arg2) = PrefixConGADT noExtField [arg1, arg2] +#else renderDetails (InfixCon arg1 arg2) = PrefixConGADT [arg1, arg2] -#if MIN_VERSION_ghc(9,3,0) +#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 @@ -196,16 +224,24 @@ prettyGADTDecl df decl = -- Make every data constructor start with a new line and 2 spaces adjustCon :: LConDecl GP -> LConDecl GP +#if MIN_VERSION_ghc(9,9,0) + adjustCon (L _ r) = + let delta = EpaDelta (DifferentLine 1 3) [] + in L (EpAnn delta (AnnListItem []) (EpaComments [])) r +#else adjustCon (L (SrcSpanAnn _ loc) r) = - L (SrcSpanAnn (EpAnn (go (spanAsAnchor loc)) (AnnListItem []) (EpaComments [])) loc) r - where - go (Anchor a _) = Anchor a (MovedAnchor (DifferentLine 1 2)) + let go (Anchor a _) = Anchor a (MovedAnchor (DifferentLine 1 2)) + in L (SrcSpanAnn (EpAnn (go (spanAsAnchor loc)) (AnnListItem []) (EpaComments [])) loc) r +#endif -- Adjust where annotation to the same line of the type constructor - adjustWhere tcdDExt = tcdDExt <&> map + adjustWhere tcdDExt = tcdDExt <&> +#if !MIN_VERSION_ghc(9,9,0) + map +#endif (\(AddEpAnn ann l) -> if ann == AnnWhere - then AddEpAnn AnnWhere (EpaDelta (SameLine 1) []) + then AddEpAnn AnnWhere d1 else AddEpAnn ann l ) @@ -220,7 +256,11 @@ wrapCtxt = id emptyCtxt = Nothing unWrap = unXRec @GP mapX = mapXRec @GP +#if MIN_VERSION_ghc(9,9,0) +noUsed = noAnn +#else noUsed = EpAnnNotUsed +#endif pattern UserTyVar' :: LIdP pass -> HsTyVarBndr flag pass pattern UserTyVar' s <- UserTyVar _ _ s diff --git a/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs b/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs index 4fbe89306a..5c3f4ba781 100644 --- a/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs +++ b/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs @@ -58,11 +58,10 @@ import Ide.Types import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types import Language.LSP.VFS (virtualFileText) -import System.FilePath (dropExtension, - isAbsolute, normalise, +import System.FilePath (dropExtension, normalise, pathSeparator, splitDirectories, - takeFileName, ()) + takeFileName) -- |Plugin descriptor descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState diff --git a/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs b/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs index 03b62b4a5b..d5dcde3c2a 100644 --- a/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs +++ b/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs @@ -36,20 +36,12 @@ import Development.IDE.Core.RuleTypes (TcModuleResult (..), import Development.IDE.Core.Shake (define, useWithStale) import qualified Development.IDE.Core.Shake as Shake -#if __GLASGOW_HASKELL__ >= 903 -import Development.IDE.GHC.Compat (HsExpr (HsRecSel)) -#else -import Development.IDE.GHC.Compat (HsExpr (HsRecFld)) -#endif - import Control.DeepSeq (rwhnf) import Development.IDE.Core.PluginUtils import Development.IDE.Core.PositionMapping (PositionMapping, toCurrentRange) import Development.IDE.GHC.Compat (Extension (OverloadedRecordDot), - GhcPass, - HsExpansion (HsExpanded), - HsExpr (HsApp, HsVar, OpApp, XExpr), + GhcPass, HsExpr (..), LHsExpr, Pass (..), appPrec, dollarName, getLoc, hs_valds, @@ -87,6 +79,14 @@ import Language.LSP.Protocol.Types (CodeAction (..), WorkspaceEdit (WorkspaceEdit, _changeAnnotations, _changes, _documentChanges), type (|?) (..)) + +#if __GLASGOW_HASKELL__ < 910 +import Development.IDE.GHC.Compat (HsExpansion (HsExpanded)) +#else +import Development.IDE.GHC.Compat (XXExprGhcRn (..)) +#endif + + data Log = LogShake Shake.Log | LogCollectedRecordSelectors [RecordSelectorExpr] @@ -246,8 +246,11 @@ collectRecSelsRule recorder = define (cmapWithPrio LogShake recorder) $ where getEnabledExtensions :: TcModuleResult -> [Extension] getEnabledExtensions = getExtensions . tmrParsed getRecordSelectors :: TcModuleResult -> [RecordSelectorExpr] - getRecordSelectors (tmrRenamed -> (hs_valds -> valBinds,_,_,_)) = - collectRecordSelectors valBinds +#if __GLASGOW_HASKELL__ >= 910 + getRecordSelectors (tmrRenamed -> (hs_valds -> valBinds,_,_,_,_)) = collectRecordSelectors valBinds +#else + getRecordSelectors (tmrRenamed -> (hs_valds -> valBinds,_,_,_)) = collectRecordSelectors valBinds +#endif rewriteRange :: PositionMapping -> RecordSelectorExpr -> Maybe RecordSelectorExpr rewriteRange pm recSel = @@ -281,7 +284,11 @@ getRecSels :: LHsExpr (GhcPass 'Renamed) -> ([RecordSelectorExpr], Bool) -- branch. We do this here, by explicitly returning occurrences from traversing -- the original branch, and returning True, which keeps syb from implicitly -- continuing to traverse. +#if __GLASGOW_HASKELL__ >= 910 +getRecSels (unLoc -> XExpr (ExpandedThingRn a _)) = (collectRecordSelectors a, True) +#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" diff --git a/plugins/hls-qualify-imported-names-plugin/src/Ide/Plugin/QualifyImportedNames.hs b/plugins/hls-qualify-imported-names-plugin/src/Ide/Plugin/QualifyImportedNames.hs index 7027feeb99..8b73c9114e 100644 --- a/plugins/hls-qualify-imported-names-plugin/src/Ide/Plugin/QualifyImportedNames.hs +++ b/plugins/hls-qualify-imported-names-plugin/src/Ide/Plugin/QualifyImportedNames.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} @@ -12,7 +13,7 @@ import Control.Monad.Trans.State.Strict (State) import qualified Control.Monad.Trans.State.Strict as State import Data.DList (DList) import qualified Data.DList as DList -import Data.Foldable (Foldable (foldl'), find) +import Data.Foldable (find) import Data.List (sortOn) import qualified Data.List as List import qualified Data.Map.Strict as Map @@ -72,6 +73,10 @@ import Language.LSP.Protocol.Types (CodeAction (CodeAction, _comm WorkspaceEdit (WorkspaceEdit, _changeAnnotations, _changes, _documentChanges), type (|?) (InL, InR)) +#if !MIN_VERSION_base(4,20,0) +import Data.Foldable (foldl') +#endif + thenCmp :: Ordering -> Ordering -> Ordering {-# INLINE thenCmp #-} thenCmp EQ ordering = ordering diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Compat/ExactPrint.hs b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Compat/ExactPrint.hs index 453e5477ad..d8b86217d7 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Compat/ExactPrint.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Compat/ExactPrint.hs @@ -2,16 +2,18 @@ -- multiple ghc-exactprint versions, accepting that anything more ambitious is -- pretty much impossible with the GHC 9.2 redesign of ghc-exactprint module Development.IDE.GHC.Compat.ExactPrint - ( ExactPrint - , exactPrint - , makeDeltaAst - , Retrie.Annotated, pattern Annotated, astA, annsA + ( module ExactPrint + , printA + , transformA ) where -import Development.IDE.GHC.Compat.Parser -import Language.Haskell.GHC.ExactPrint as Retrie -import qualified Retrie.ExactPrint as Retrie +import Language.Haskell.GHC.ExactPrint as ExactPrint +printA :: (ExactPrint ast) => ast -> String +printA ast = exactPrint ast -pattern Annotated :: ast -> ApiAnns -> Retrie.Annotated ast -pattern Annotated {astA, annsA} <- ((,()) . Retrie.astA -> (astA, annsA)) +transformA + :: Monad m => ast1 -> (ast1 -> TransformT m ast2) -> m ast2 +transformA ast f = do + (ast',_ ,_) <- runTransformFromT 0 (f ast) + return $ ast' diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs index 93da3ba76f..949e2a700b 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs @@ -4,7 +4,7 @@ import qualified Data.ByteString as B import Data.Data hiding (Fixity) import Development.IDE.GHC.Compat hiding (LocatedA, NameAnn) -import Development.IDE.GHC.Compat.ExactPrint +import Development.IDE.GHC.Compat.ExactPrint (ExactPrint, exactPrint) import Development.IDE.GHC.Compat.Util import Generics.SYB (ext1Q, ext2Q, extQ) import GHC.Hs hiding (AnnLet) @@ -61,7 +61,9 @@ showAstDataHtml a0 = html $ `extQ` sourceText `extQ` deltaPos `extQ` epaAnchor +#if !MIN_VERSION_ghc(9,9,0) `extQ` anchorOp +#endif `extQ` bytestring `extQ` name `extQ` occName `extQ` moduleName `extQ` var `extQ` dataCon @@ -129,16 +131,20 @@ showAstDataHtml a0 = html $ #endif epaAnchor :: EpaLocation -> SDoc -#if MIN_VERSION_ghc(9,5,0) +#if MIN_VERSION_ghc(9,9,0) + epaAnchor (EpaSpan s) = parens $ text "EpaSpan" <+> srcSpan s +#elif MIN_VERSION_ghc(9,5,0) epaAnchor (EpaSpan r _) = text "EpaSpan" <+> realSrcSpan r #else epaAnchor (EpaSpan r) = text "EpaSpan" <+> realSrcSpan r #endif epaAnchor (EpaDelta d cs) = text "EpaDelta" <+> deltaPos d <+> showAstDataHtml' cs +#if !MIN_VERSION_ghc(9,9,0) anchorOp :: AnchorOperation -> SDoc anchorOp UnchangedAnchor = "UnchangedAnchor" anchorOp (MovedAnchor dp) = "MovedAnchor " <> deltaPos dp +#endif deltaPos :: DeltaPos -> SDoc deltaPos (SameLine c) = text "SameLine" <+> ppr c @@ -249,6 +255,31 @@ showAstDataHtml a0 = html $ -- ------------------------- +#if MIN_VERSION_ghc(9,9,0) + srcSpanAnnA :: EpAnn AnnListItem -> SDoc + srcSpanAnnA = locatedAnn'' (text "SrcSpanAnnA") + + srcSpanAnnL :: EpAnn AnnList -> SDoc + srcSpanAnnL = locatedAnn'' (text "SrcSpanAnnL") + + srcSpanAnnP :: EpAnn AnnPragma -> SDoc + srcSpanAnnP = locatedAnn'' (text "SrcSpanAnnP") + + srcSpanAnnC :: EpAnn AnnContext -> SDoc + srcSpanAnnC = locatedAnn'' (text "SrcSpanAnnC") + + srcSpanAnnN :: EpAnn NameAnn -> SDoc + srcSpanAnnN = locatedAnn'' (text "SrcSpanAnnN") + + locatedAnn'' :: forall a. Data a => SDoc -> EpAnn a -> SDoc + locatedAnn'' tag ss = parens $ + case cast ss of + Just (ann :: EpAnn a) -> + text (showConstr (toConstr ann)) + $$ vcat (gmapQ showAstDataHtml' ann) + Nothing -> text "locatedAnn:unmatched" <+> tag + <+> (parens $ text (showConstr (toConstr ss))) +#else srcSpanAnnA :: SrcSpanAnn' (EpAnn AnnListItem) -> SDoc srcSpanAnnA = locatedAnn'' (text "SrcSpanAnnA") @@ -274,6 +305,7 @@ showAstDataHtml a0 = html $ $$ li(srcSpan s)) Nothing -> text "locatedAnn:unmatched" <+> tag <+> text (showConstr (toConstr ss)) +#endif normalize_newlines :: String -> String diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs index cd91743756..e54db25d60 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs @@ -30,7 +30,6 @@ module Development.IDE.GHC.ExactPrint removeComma, -- * Helper function eqSrcSpan, - eqSrcSpanA, epl, epAnn, removeTrailingComma, @@ -55,7 +54,6 @@ import Control.Monad.Trans.Except import Control.Monad.Zip import Data.Bifunctor import Data.Bool (bool) -import Data.Default (Default) import qualified Data.DList as DL import Data.Either.Extra (mapLeft) import Data.Functor.Classes @@ -81,38 +79,54 @@ import Ide.Logger (Pretty (pretty), import Ide.PluginUtils import Language.Haskell.GHC.ExactPrint.Parsers import Language.LSP.Protocol.Types -import Retrie.ExactPrint hiding (parseDecl, - parseExpr, - parsePattern, - parseType) -#if MIN_VERSION_ghc(9,9,0) -import GHC.Plugins (showSDoc) -import GHC.Utils.Outputable (Outputable (ppr)) -#else -import GHC (EpAnn (..), + +import Control.Lens (_last, (&)) +import Control.Lens.Operators ((%~)) +import Data.List (partition) +import GHC (DeltaPos (..), + SrcSpanAnnN) + +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] + +#if !MIN_VERSION_ghc(9,9,0) +import Data.Default (Default) +import GHC (Anchor (..), + AnchorOperation, + EpAnn (..), NameAdornment (NameParens), NameAnn (..), SrcSpanAnn' (SrcSpanAnn), SrcSpanAnnA, TrailingAnn (AddCommaAnn), emptyComments, + realSrcSpan, spanAsAnchor) import GHC.Parser.Annotation (AnnContext (..), EpaLocation (EpaDelta), deltaPos) +import GHC.Types.SrcLoc (generatedSrcSpan) #endif -import Control.Lens (_last, (&)) -import Control.Lens.Operators ((%~)) -import Data.List (partition) -import GHC (Anchor (..), - AnchorOperation, - DeltaPos (..), - SrcSpanAnnN, - realSrcSpan) -import GHC.Types.SrcLoc (generatedSrcSpan) +#if MIN_VERSION_ghc(9,9,0) +import GHC (Anchor, + AnnContext (..), + EpAnn (..), + EpaLocation, + EpaLocation' (..), + NameAdornment (..), + NameAnn (..), + SrcSpanAnnA, + TrailingAnn (..), + deltaPos, + emptyComments, + spanAsAnchor) +#endif -setPrecedingLines :: Default t => LocatedAn t a -> Int -> Int -> LocatedAn t a +setPrecedingLines :: +#if !MIN_VERSION_ghc(9,9,0) + Default t => +#endif + LocatedAn t a -> Int -> Int -> LocatedAn t a setPrecedingLines ast n c = setEntryDP ast (deltaPos n c) ------------------------------------------------------------------------------ @@ -122,18 +136,20 @@ instance Pretty Log where pretty = \case LogShake shakeLog -> pretty shakeLog -instance Show (Annotated ParsedSource) where - show _ = "" - -instance NFData (Annotated ParsedSource) where - rnf = rwhnf - data GetAnnotatedParsedSource = GetAnnotatedParsedSource deriving (Eq, Show, Typeable, GHC.Generic) instance Hashable GetAnnotatedParsedSource instance NFData GetAnnotatedParsedSource -type instance RuleResult GetAnnotatedParsedSource = Annotated ParsedSource +type instance RuleResult GetAnnotatedParsedSource = ParsedSource + +#if MIN_VERSION_ghc(9,5,0) +instance Show (HsModule GhcPs) where + show _ = "" +#else +instance Show HsModule where + show _ = "" +#endif -- | Get the latest version of the annotated parse source with comments. getAnnotatedParsedSourceRule :: Recorder (WithPriority Log) -> Rules () @@ -141,8 +157,13 @@ getAnnotatedParsedSourceRule recorder = define (cmapWithPrio LogShake recorder) pm <- use GetParsedModuleWithComments nfp return ([], fmap annotateParsedSource pm) -annotateParsedSource :: ParsedModule -> Annotated ParsedSource -annotateParsedSource (ParsedModule _ ps _ _) = unsafeMkA (makeDeltaAst ps) 0 +annotateParsedSource :: ParsedModule -> ParsedSource +annotateParsedSource (ParsedModule _ ps _ _) = +#if MIN_VERSION_ghc(9,9,0) + ps +#else + (makeDeltaAst ps) +#endif ------------------------------------------------------------------------------ @@ -195,7 +216,7 @@ transform :: ClientCapabilities -> VersionedTextDocumentIdentifier -> Graft (Either String) ParsedSource -> - Annotated ParsedSource -> + ParsedSource -> Either String WorkspaceEdit transform dflags ccs verTxtDocId f a = do let src = printA a @@ -212,7 +233,7 @@ transformM :: ClientCapabilities -> VersionedTextDocumentIdentifier -> Graft (ExceptStringT m) ParsedSource -> - Annotated ParsedSource -> + ParsedSource -> m (Either String WorkspaceEdit) transformM dflags ccs verTextDocId f a = runExceptT $ runExceptString $ do @@ -232,7 +253,9 @@ needsParensSpace :: -- | (Needs parens, needs space) (All, All) needsParensSpace HsLam{} = (All False, All False) +#if !MIN_VERSION_ghc(9,9,0) needsParensSpace HsLamCase{} = (All False, All True) +#endif needsParensSpace HsApp{} = mempty needsParensSpace HsAppType{} = mempty needsParensSpace OpApp{} = mempty @@ -421,8 +444,8 @@ graftDecls dst decs0 = Graft $ \dflags a -> do -- For example, if you would like to move a where-clause-defined variable to the same -- level as its parent HsDecl, you could use this function. -- --- When matching declaration is found in the sub-declarations of `a`, `Just r` is also returned with the new `a`. If --- not declaration matched, then `Nothing` is returned. +-- When matching declaration is found in the sub-declarations of `a`, `Just r` is also returned with the new `a`. +-- If no declaration matched, then `Nothing` is returned. modifySmallestDeclWithM :: forall a m r. (HasDecls a, Monad m) => @@ -440,19 +463,35 @@ modifySmallestDeclWithM validSpan f a = do False -> first (DL.singleton ldecl <>) <$> modifyMatchingDecl rest modifyDeclsT' (fmap (first DL.toList) . modifyMatchingDecl) a +#if MIN_VERSION_ghc(9,9,0) +generatedAnchor :: DeltaPos -> Anchor +generatedAnchor dp = EpaDelta dp [] +#else generatedAnchor :: AnchorOperation -> Anchor generatedAnchor anchorOp = GHC.Anchor (GHC.realSrcSpan generatedSrcSpan) anchorOp +#endif setAnchor :: Anchor -> SrcSpanAnnN -> SrcSpanAnnN +#if MIN_VERSION_ghc(9,9,0) +setAnchor anc (EpAnn _ nameAnn comments) = + EpAnn anc nameAnn comments +#else setAnchor anc (SrcSpanAnn (EpAnn _ nameAnn comments) span) = SrcSpanAnn (EpAnn anc nameAnn comments) span setAnchor _ spanAnnN = spanAnnN +#endif removeTrailingAnns :: SrcSpanAnnN -> SrcSpanAnnN +#if MIN_VERSION_ghc(9,9,0) +removeTrailingAnns (EpAnn anc nameAnn comments) = + let nameAnnSansTrailings = nameAnn {nann_trailing = []} + in EpAnn anc nameAnnSansTrailings comments +#else removeTrailingAnns (SrcSpanAnn (EpAnn anc nameAnn comments) span) = let nameAnnSansTrailings = nameAnn {nann_trailing = []} in SrcSpanAnn (EpAnn anc nameAnnSansTrailings comments) span removeTrailingAnns spanAnnN = spanAnnN +#endif -- | Modify the type signature for the given IdP. This function handles splitting a multi-sig -- SigD into multiple SigD if the type signature is changed. @@ -471,7 +510,7 @@ removeTrailingAnns spanAnnN = spanAnnN -- + foo :: Bool modifySigWithM :: forall a m. - (HasDecls a, Monad m) => + (HasDecls a, Monad m, ExactPrint a) => IdP GhcPs -> (LHsSigType GhcPs -> LHsSigType GhcPs) -> a -> @@ -490,22 +529,36 @@ modifySigWithM queryId f a = do let matchedId' = L (setAnchor genAnchor0 $ removeTrailingAnns annMatchedId) matchedId matchedIdSig = let sig' = SigD xsig (TypeSig xTypeSig [matchedId'] (HsWC xHsWc newSig)) - epAnn = bool (noAnnSrcSpanDP generatedSrcSpan (DifferentLine 1 0)) annSigD (null otherIds) + epAnn = bool (noAnnSrcSpanDP +#if !MIN_VERSION_ghc(9,9,0) + generatedSrcSpan +#endif + (DifferentLine 1 0)) + annSigD (null otherIds) in L epAnn sig' otherSig = case otherIds of [] -> [] - (L (SrcSpanAnn epAnn span) id1:ids) -> [ +#if MIN_VERSION_ghc(9,9,0) + (L epAnn id1:ids) -> +#else + (L (SrcSpanAnn epAnn span) id1:ids) -> +#endif + [ let epAnn' = case epAnn of EpAnn _ nameAnn commentsId1 -> EpAnn genAnchor0 nameAnn commentsId1 +#if MIN_VERSION_ghc(9,9,0) + ids' = L epAnn' id1:ids +#else EpAnnNotUsed -> EpAnn genAnchor0 mempty emptyComments ids' = L (SrcSpanAnn epAnn' span) id1:ids +#endif ids'' = ids' & _last %~ first removeTrailingAnns in L annSigD (SigD xsig (TypeSig xTypeSig ids'' (HsWC xHsWc lHsSig))) - ] + ] in pure $ DL.fromList otherSig <> DL.singleton matchedIdSig <> DL.fromList rest _ -> error "multiple ids matched" modifyMatchingSigD (ldecl : rest) = (DL.singleton ldecl <>) <$> modifyMatchingSigD rest - modifyDeclsT (fmap DL.toList . modifyMatchingSigD) a + modifyDeclsT (fmap DL.toList . modifyMatchingSigD) $ makeDeltaAst a genAnchor0 :: Anchor genAnchor0 = generatedAnchor m0 @@ -513,6 +566,13 @@ genAnchor0 = generatedAnchor m0 genAnchor1 :: Anchor genAnchor1 = generatedAnchor m1 +#if MIN_VERSION_ghc(9,9,0) +m0, m1 :: DeltaPos +m0 = SameLine 0 +m1 = SameLine 1 +#endif + + -- | Apply a transformation to the decls contained in @t@ modifyDeclsT' :: (HasDecls t, HasTransform m) => ([LHsDecl GhcPs] -> m ([LHsDecl GhcPs], r)) @@ -543,7 +603,7 @@ modifyMgMatchesT' :: modifyMgMatchesT' (MG xMg (L locMatches matches)) f def combineResults = do (unzip -> (matches', rs)) <- mapM f matches r' <- TransformT $ lift $ foldM combineResults def rs - pure $ (MG xMg (L locMatches matches'), r') + pure (MG xMg (L locMatches matches'), r') #else modifyMgMatchesT' (MG xMg (L locMatches matches) originMg) f def combineResults = do (unzip -> (matches', rs)) <- mapM f matches @@ -596,7 +656,9 @@ class , Typeable l , Outputable l , Outputable ast +#if !MIN_VERSION_ghc(9,9,0) , Default l +#endif ) => ASTElement l ast | ast -> l where parseAST :: Parser (LocatedAn l ast) maybeParensAST :: LocatedAn l ast -> LocatedAn l ast @@ -690,11 +752,6 @@ parenthesize = parenthesizeHsExpr appPrec eqSrcSpan :: SrcSpan -> SrcSpan -> Bool eqSrcSpan l r = leftmost_smallest l r == EQ --- | Equality on SrcSpan's. --- Ignores the (Maybe BufSpan) field of SrcSpan's. -eqSrcSpanA :: SrcAnn a -> SrcAnn b -> Bool -eqSrcSpanA l r = leftmost_smallest (locA l) (locA r) == EQ - addParensToCtxt :: Maybe EpaLocation -> AnnContext -> AnnContext addParensToCtxt close_dp = addOpen . addClose where @@ -712,15 +769,27 @@ epAnn :: SrcSpan -> ann -> EpAnn ann epAnn srcSpan anns = EpAnn (spanAsAnchor srcSpan) anns emptyComments modifyAnns :: LocatedAn a ast -> (a -> a) -> LocatedAn a ast +#if MIN_VERSION_ghc(9,9,0) +modifyAnns x f = first (fmap f) x +#else modifyAnns x f = first ((fmap.fmap) f) x +#endif removeComma :: SrcSpanAnnA -> SrcSpanAnnA +#if MIN_VERSION_ghc(9,9,0) +removeComma (EpAnn anc (AnnListItem as) cs) + = EpAnn anc (AnnListItem (filter (not . isCommaAnn) as)) cs + where + isCommaAnn AddCommaAnn{} = True + isCommaAnn _ = False +#else removeComma it@(SrcSpanAnn EpAnnNotUsed _) = it removeComma (SrcSpanAnn (EpAnn anc (AnnListItem as) cs) l) = SrcSpanAnn (EpAnn anc (AnnListItem (filter (not . isCommaAnn) as)) cs) l where isCommaAnn AddCommaAnn{} = True isCommaAnn _ = False +#endif addParens :: Bool -> GHC.NameAnn -> GHC.NameAnn addParens True it@NameAnn{} = diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs index 0fcea4a3ff..175aced38f 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -1,5 +1,6 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} module Development.IDE.Plugin.CodeAction @@ -68,12 +69,9 @@ import Development.IDE.Types.Exports import Development.IDE.Types.Location import Development.IDE.Types.Options import GHC (AddEpAnn (AddEpAnn), - Anchor (anchor_op), - AnchorOperation (..), AnnsModule (am_main), DeltaPos (..), EpAnn (..), - EpaLocation (..), LEpaComment) import qualified GHC.LanguageExtensions as Lang import Ide.Logger hiding @@ -104,6 +102,21 @@ import qualified Text.Fuzzy.Parallel as TFP import qualified Text.Regex.Applicative as RE import Text.Regex.TDFA ((=~), (=~~)) +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] + +#if !MIN_VERSION_ghc(9,9,0) +import GHC (Anchor (anchor_op), + AnchorOperation (..), + EpaLocation (..)) +#endif + +#if MIN_VERSION_ghc(9,9,0) +import GHC (EpaLocation, + EpaLocation' (..), + HasLoc (..)) +import GHC.Types.SrcLoc (srcSpanToRealSrcSpan) +#endif + ------------------------------------------------------------------------------------------------- -- | Generate code actions. @@ -222,7 +235,12 @@ extendImportHandler' ideState ExtendImport {..} Just imp -> do fmap (nfp,) $ liftEither $ rewriteToWEdit df doc $ - extendImport (T.unpack <$> thingParent) (T.unpack newThing) (makeDeltaAst imp) + extendImport (T.unpack <$> thingParent) (T.unpack newThing) +#if MIN_VERSION_ghc(9,9,0) + imp +#else + (makeDeltaAst imp) +#endif Nothing -> do let qns = (,) <$> importQual <*> Just (qualifiedImportStyle df) @@ -252,7 +270,7 @@ isWantedModule wantedModule (Just qual) (L _ ImportDecl{ ideclAs, ideclName , ideclHiding = Just (False, _) #endif }) = - unLoc ideclName == wantedModule && (wantedModule == qual || (unLoc . reLoc <$> ideclAs) == Just qual) + unLoc ideclName == wantedModule && (wantedModule == qual || (unLoc <$> ideclAs) == Just qual) isWantedModule _ _ _ = False @@ -306,7 +324,7 @@ findSigOfBind range bind = findSigOfExpr :: HsExpr p -> Maybe (Sig p) findSigOfExpr = go where -#if MIN_VERSION_ghc(9,3,0) +#if MIN_VERSION_ghc(9,3,0) && !MIN_VERSION_ghc(9,9,0) go (HsLet _ _ binds _ _) = findSigOfBinds range binds #else go (HsLet _ binds _) = findSigOfBinds range binds @@ -337,7 +355,11 @@ findInstanceHead df instanceHead decls = showSDoc df (ppr hsib_body) == instanceHead ] +#if MIN_VERSION_ghc(9,9,0) +findDeclContainingLoc :: (Foldable t, HasLoc l) => Position -> t (GenLocated l e) -> Maybe (GenLocated l e) +#else findDeclContainingLoc :: Foldable t => Position -> t (GenLocated (SrcSpanAnn' a) e) -> Maybe (GenLocated (SrcSpanAnn' a) e) +#endif findDeclContainingLoc loc = find (\(L l _) -> loc `isInsideSrcSpan` locA l) -- Single: @@ -349,7 +371,7 @@ findDeclContainingLoc loc = find (\(L l _) -> loc `isInsideSrcSpan` locA l) -- imported from ‘Data.ByteString’ at B.hs:6:1-22 -- imported from ‘Data.ByteString.Lazy’ at B.hs:8:1-27 -- imported from ‘Data.Text’ at B.hs:7:1-16 -suggestHideShadow :: Annotated ParsedSource -> T.Text -> Maybe TcModuleResult -> Maybe HieAstResult -> Diagnostic -> [(T.Text, [Either TextEdit Rewrite])] +suggestHideShadow :: ParsedSource -> T.Text -> Maybe TcModuleResult -> Maybe HieAstResult -> Diagnostic -> [(T.Text, [Either TextEdit Rewrite])] suggestHideShadow ps fileContents mTcM mHar Diagnostic {_message, _range} | Just [identifier, modName, s] <- matchRegexUnifySpaces @@ -367,7 +389,7 @@ suggestHideShadow ps fileContents mTcM mHar Diagnostic {_message, _range} result <> [hideAll] | otherwise = [] where - L _ HsModule {hsmodImports} = astA ps + L _ HsModule {hsmodImports} = ps suggests identifier modName s | Just tcM <- mTcM, @@ -545,7 +567,7 @@ suggestRemoveRedundantExport :: ParsedModule -> Diagnostic -> Maybe (T.Text, [Ra suggestRemoveRedundantExport ParsedModule{pm_parsed_source = L _ HsModule{..}} Diagnostic{..} | msg <- unifySpaces _message , Just export <- hsmodExports - , Just exportRange <- getLocatedRange $ reLoc export + , Just exportRange <- getLocatedRange $ export , exports <- unLoc export , Just (removeFromExport, !ranges) <- fmap (getRanges exports . notInScope) (extractNotInScopeName msg) <|> (,[_range]) <$> matchExportItem msg @@ -616,16 +638,16 @@ suggestDeleteUnusedBinding let maybeIdx = findIndex (\(L _ id) -> isSameName id name) lnames in case maybeIdx of Nothing -> Nothing - Just _ | [lname] <- lnames -> Just (getLoc $ reLoc lname, True) + Just _ | [lname] <- lnames -> Just (getLoc lname, True) Just idx -> - let targetLname = getLoc $ reLoc $ lnames !! idx + let targetLname = getLoc $ lnames !! idx startLoc = srcSpanStart targetLname endLoc = srcSpanEnd targetLname startLoc' = if idx == 0 then startLoc - else srcSpanEnd . getLoc . reLoc $ lnames !! (idx - 1) + else srcSpanEnd . getLoc $ lnames !! (idx - 1) endLoc' = if idx == 0 && idx < length lnames - 1 - then srcSpanStart . getLoc . reLoc $ lnames !! (idx + 1) + then srcSpanStart . getLoc $ lnames !! (idx + 1) else endLoc in Just (mkSrcSpan startLoc' endLoc', False) findRelatedSigSpan1 _ _ = Nothing @@ -1023,7 +1045,7 @@ isPreludeImplicit = xopt Lang.ImplicitPrelude suggestImportDisambiguation :: DynFlags -> Maybe T.Text -> - Annotated ParsedSource -> + ParsedSource -> T.Text -> Diagnostic -> [(T.Text, [Either TextEdit Rewrite])] @@ -1039,7 +1061,7 @@ suggestImportDisambiguation df (Just txt) ps fileContents diag@Diagnostic {..} suggestions ambiguous modules (isJust local) | otherwise = [] where - L _ HsModule {hsmodImports} = astA ps + L _ HsModule {hsmodImports} = ps locDic = fmap (NE.fromList . DL.toList) $ @@ -1137,7 +1159,7 @@ targetModuleName (ExistingImp (L _ ImportDecl{..} :| _)) = unLoc ideclName disambiguateSymbol :: - Annotated ParsedSource -> + ParsedSource -> T.Text -> Diagnostic -> T.Text -> @@ -1197,7 +1219,7 @@ suggestFixConstructorImport Diagnostic{_range=_range,..} in [("Fix import of " <> fixedImport, TextEdit _range fixedImport)] | otherwise = [] -suggestAddRecordFieldImport :: ExportsMap -> DynFlags -> Annotated ParsedSource -> T.Text -> Diagnostic -> [(T.Text, CodeActionKind, TextEdit)] +suggestAddRecordFieldImport :: ExportsMap -> DynFlags -> ParsedSource -> T.Text -> Diagnostic -> [(T.Text, CodeActionKind, TextEdit)] suggestAddRecordFieldImport exportsMap df ps fileContents Diagnostic {..} | Just fieldName <- findMissingField _message , Just (range, indent) <- newImportInsertRange ps fileContents @@ -1218,11 +1240,17 @@ suggestAddRecordFieldImport exportsMap df ps fileContents Diagnostic {..} -- | Suggests a constraint for a declaration for which a constraint is missing. suggestConstraint :: DynFlags -> ParsedSource -> Diagnostic -> [(T.Text, Rewrite)] -suggestConstraint df (makeDeltaAst -> parsedModule) diag@Diagnostic {..} +suggestConstraint df ps diag@Diagnostic {..} | Just missingConstraint <- findMissingConstraint _message - = let codeAction = if _message =~ ("the type signature for:" :: String) - then suggestFunctionConstraint df parsedModule - else suggestInstanceConstraint df parsedModule + = let +#if MIN_VERSION_ghc(9,9,0) + parsedSource = ps +#else + parsedSource = makeDeltaAst ps +#endif + codeAction = if _message =~ ("the type signature for:" :: String) + then suggestFunctionConstraint df parsedSource + else suggestInstanceConstraint df parsedSource in codeAction diag missingConstraint | otherwise = [] where @@ -1341,7 +1369,11 @@ suggestFunctionConstraint df (L _ HsModule {hsmodDecls}) Diagnostic {..} missing -- | Suggests the removal of a redundant constraint for a type signature. removeRedundantConstraints :: DynFlags -> ParsedSource -> Diagnostic -> [(T.Text, Rewrite)] +#if MIN_VERSION_ghc(9,9,0) +removeRedundantConstraints df (L _ HsModule {hsmodDecls}) Diagnostic{..} +#else removeRedundantConstraints df (makeDeltaAst -> L _ HsModule {hsmodDecls}) Diagnostic{..} +#endif -- • Redundant constraint: Eq a -- • In the type signature for: -- foo :: forall a. Eq a => a -> a @@ -1406,7 +1438,7 @@ removeRedundantConstraints df (makeDeltaAst -> L _ HsModule {hsmodDecls}) Diagno ------------------------------------------------------------------------------------------------- -suggestNewOrExtendImportForClassMethod :: ExportsMap -> Annotated ParsedSource -> T.Text -> Diagnostic -> [(T.Text, CodeActionKind, [Either TextEdit Rewrite])] +suggestNewOrExtendImportForClassMethod :: ExportsMap -> ParsedSource -> T.Text -> Diagnostic -> [(T.Text, CodeActionKind, [Either TextEdit Rewrite])] suggestNewOrExtendImportForClassMethod packageExportsMap ps fileContents Diagnostic {_message} | Just [methodName, className] <- matchRegexUnifySpaces @@ -1420,7 +1452,7 @@ suggestNewOrExtendImportForClassMethod packageExportsMap ps fileContents Diagnos where suggest identInfo | importStyle <- NE.toList $ importStyles identInfo, - mImportDecl <- findImportDeclByModuleName (hsmodImports . unLoc . astA $ ps) (T.unpack moduleText) = + mImportDecl <- findImportDeclByModuleName (hsmodImports . unLoc $ ps) (T.unpack moduleText) = case mImportDecl of -- extend Just decl -> @@ -1443,7 +1475,7 @@ suggestNewOrExtendImportForClassMethod packageExportsMap ps fileContents Diagnos | otherwise -> [] where moduleText = moduleNameText identInfo -suggestNewImport :: DynFlags -> ExportsMap -> Annotated ParsedSource -> T.Text -> Diagnostic -> [(T.Text, CodeActionKind, TextEdit)] +suggestNewImport :: DynFlags -> ExportsMap -> ParsedSource -> T.Text -> Diagnostic -> [(T.Text, CodeActionKind, TextEdit)] suggestNewImport df packageExportsMap ps fileContents Diagnostic{..} | msg <- unifySpaces _message , Just thingMissing <- extractNotInScopeName msg @@ -1485,7 +1517,7 @@ suggestNewImport df packageExportsMap ps fileContents Diagnostic{..} qualify q (NotInScopeTypeConstructorOrClass d) = NotInScopeTypeConstructorOrClass (q <> "." <> d) qualify q (NotInScopeThing d) = NotInScopeThing (q <> "." <> d) - L _ HsModule {..} = astA ps + L _ HsModule {..} = ps suggestNewImport _ _ _ _ _ = [] {- | @@ -1602,7 +1634,7 @@ simpleCompareImportSuggestion (ImportSuggestion s1 _ i1) (ImportSuggestion s2 _ newtype NewImport = NewImport {unNewImport :: T.Text} deriving (Show, Eq, Ord) -newImportToEdit :: NewImport -> Annotated ParsedSource -> T.Text -> Maybe (T.Text, TextEdit) +newImportToEdit :: NewImport -> ParsedSource -> T.Text -> Maybe (T.Text, TextEdit) newImportToEdit (unNewImport -> imp) ps fileContents | Just (range, indent) <- newImportInsertRange ps fileContents = Just (imp, TextEdit range (imp <> "\n" <> T.replicate indent " ")) @@ -1616,48 +1648,51 @@ newImportToEdit (unNewImport -> imp) ps fileContents -- * If the file has neither existing imports nor a module declaration, -- the import will be inserted at line zero if there are no pragmas, -- * otherwise inserted one line after the last file-header pragma -newImportInsertRange :: Annotated ParsedSource -> T.Text -> Maybe (Range, Int) +newImportInsertRange :: ParsedSource -> T.Text -> Maybe (Range, Int) newImportInsertRange ps fileContents | Just ((l, c), col) <- case hsmodImports of -- When there is no existing imports, we only cares about the line number, setting column and indent to zero. [] -> (\line -> ((line, 0), 0)) <$> findPositionNoImports ps fileContents - _ -> findPositionFromImports (map reLoc hsmodImports) last + _ -> findPositionFromImports hsmodImports last , let insertPos = Position (fromIntegral l) (fromIntegral c) = Just (Range insertPos insertPos, col) | otherwise = Nothing where - L _ HsModule {..} = astA ps + L _ HsModule {..} = ps -- | Find the position for a new import when there isn't an existing one. -- * If there is a module declaration, a new import should be inserted under the module declaration (including exports list) -- * Otherwise, a new import should be inserted after any file-header pragma. -findPositionNoImports :: Annotated ParsedSource -> T.Text -> Maybe Int +findPositionNoImports :: ParsedSource -> T.Text -> Maybe Int findPositionNoImports ps fileContents = maybe (Just (findNextPragmaPosition fileContents)) (findPositionAfterModuleName ps) hsmodName where - L _ HsModule {..} = astA ps + L _ HsModule {..} = ps -- | find line number right after module ... where -findPositionAfterModuleName :: Annotated ParsedSource +findPositionAfterModuleName :: ParsedSource -> LocatedA ModuleName -> Maybe Int -findPositionAfterModuleName ps hsmodName' = do +findPositionAfterModuleName ps _hsmodName' = do -- Note that 'where' keyword and comments are not part of the AST. They belongs to -- the exact-print information. To locate it, we need to find the previous AST node, -- calculate the gap between it and 'where', then add them up to produce the absolute -- position of 'where'. lineOffset <- whereKeywordLineOffset -- Calculate the gap before 'where' keyword. +#if MIN_VERSION_ghc(9,9,0) + pure lineOffset +#else + -- The last AST node before 'where' keyword. Might be module name or export list. + let prevSrcSpan = maybe (getLoc _hsmodName') getLoc hsmodExports case prevSrcSpan of UnhelpfulSpan _ -> Nothing (RealSrcSpan prevSrcSpan' _) -> -- add them up produce the absolute location of 'where' keyword Just $ srcLocLine (realSrcSpanEnd prevSrcSpan') + lineOffset +#endif where - L _ HsModule {..} = astA ps - - -- The last AST node before 'where' keyword. Might be module name or export list. - prevSrcSpan = maybe (getLoc hsmodName') getLoc hsmodExports + L _ HsModule {..} = ps -- The relative position of 'where' keyword (in lines, relative to the previous AST node). -- The exact-print API changed a lot in ghc-9.2, so we need to handle it separately for different compiler versions. @@ -1671,12 +1706,17 @@ findPositionAfterModuleName ps hsmodName' = do -- Find the first 'where' whereLocation <- listToMaybe . mapMaybe filterWhere $ am_main annsModule epaLocationToLine whereLocation +#if !MIN_VERSION_ghc(9,9,0) EpAnnNotUsed -> Nothing +#endif filterWhere (AddEpAnn AnnWhere loc) = Just loc filterWhere _ = Nothing epaLocationToLine :: EpaLocation -> Maybe Int -#if MIN_VERSION_ghc(9,5,0) +#if MIN_VERSION_ghc(9,9,0) + epaLocationToLine (EpaSpan sp) + = fmap (srcLocLine . realSrcSpanEnd) $ srcSpanToRealSrcSpan sp +#elif MIN_VERSION_ghc(9,5,0) epaLocationToLine (EpaSpan sp _) = Just . srcLocLine . realSrcSpanEnd $ sp #else @@ -1690,12 +1730,23 @@ findPositionAfterModuleName ps hsmodName' = do epaLocationToLine (EpaDelta (DifferentLine line _) priorComments) = Just (line + sumCommentsOffset priorComments) sumCommentsOffset :: [LEpaComment] -> Int +#if MIN_VERSION_ghc(9,9,0) + sumCommentsOffset = sum . fmap (\(L anchor _) -> anchorOpLine anchor) +#else sumCommentsOffset = sum . fmap (\(L anchor _) -> anchorOpLine (anchor_op anchor)) +#endif +#if MIN_VERSION_ghc(9,9,0) + anchorOpLine :: EpaLocation' a -> Int + anchorOpLine EpaSpan{} = 0 + anchorOpLine (EpaDelta (SameLine _) _) = 0 + anchorOpLine (EpaDelta (DifferentLine line _) _) = line +#else anchorOpLine :: AnchorOperation -> Int anchorOpLine UnchangedAnchor = 0 anchorOpLine (MovedAnchor (SameLine _)) = 0 anchorOpLine (MovedAnchor (DifferentLine line _)) = line +#endif findPositionFromImports :: HasSrcSpan a => t -> (t -> a) -> Maybe ((Int, Int), Int) findPositionFromImports hsField f = case getLoc (f hsField) of @@ -1943,23 +1994,40 @@ smallerRangesForBindingExport lies b = concatMap (mapMaybe srcSpanToRange . ranges') lies where unqualify = snd . breakOnEnd "." - b' = wrapOperatorInParens . unqualify $ b + b' = wrapOperatorInParens $ unqualify b +#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'] ranges' _ = [] rangesForBinding' :: String -> LIE GhcPs -> [SrcSpan] +#if MIN_VERSION_ghc(9,9,0) +rangesForBinding' b (L (locA -> l) (IEVar _ nm _)) +#else rangesForBinding' b (L (locA -> l) (IEVar _ nm)) +#endif | L _ (IEPattern _ (L _ b')) <- nm , T.unpack (printOutputable b') == b = [l] rangesForBinding' b (L (locA -> l) x@IEVar{}) | T.unpack (printOutputable x) == b = [l] rangesForBinding' b (L (locA -> l) x@IEThingAbs{}) | T.unpack (printOutputable x) == b = [l] -rangesForBinding' b (L (locA -> l) (IEThingAll _ x)) | T.unpack (printOutputable x) == b = [l] +#if MIN_VERSION_ghc(9,9,0) +rangesForBinding' b (L (locA -> l) (IEThingAll _ x _)) +#else +rangesForBinding' b (L (locA -> l) (IEThingAll _ x)) +#endif + | T.unpack (printOutputable x) == b = [l] +#if MIN_VERSION_ghc(9,9,0) +rangesForBinding' b (L (locA -> l) (IEThingWith _ thing _ inners _)) +#else rangesForBinding' b (L (locA -> l) (IEThingWith _ thing _ inners)) +#endif | T.unpack (printOutputable thing) == b = [l] | otherwise = [ locA l' | L l' x <- inners, T.unpack (printOutputable x) == b] diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs index 7eed2e1130..0be04656bd 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs @@ -28,7 +28,6 @@ import Development.IDE hiding (pluginHandlers) import Development.IDE.Core.Shake import Development.IDE.GHC.Compat -import Development.IDE.GHC.Compat.ExactPrint import Development.IDE.GHC.ExactPrint import Development.IDE.Plugin.CodeAction.ExactPrint (Rewrite, rewriteToEdit) @@ -140,7 +139,7 @@ data CodeActionArgs = CodeActionArgs caaParsedModule :: IO (Maybe ParsedModule), caaContents :: IO (Maybe T.Text), caaDf :: IO (Maybe DynFlags), - caaAnnSource :: IO (Maybe (Annotated ParsedSource)), + caaAnnSource :: IO (Maybe ParsedSource), caaTmr :: IO (Maybe TcModuleResult), caaHar :: IO (Maybe HieAstResult), caaBindings :: IO (Maybe Bindings), @@ -214,17 +213,7 @@ toCodeAction3 get f = ExceptT . ReaderT $ \caa -> get caa >>= flip runReaderT ca -- | this instance returns a delta AST, useful for exactprint transforms instance ToCodeAction r => ToCodeAction (ParsedSource -> r) where -#if !MIN_VERSION_ghc(9,3,0) - toCodeAction f = ExceptT . ReaderT $ \caa@CodeActionArgs {caaAnnSource = x} -> - x >>= \case - Just s -> flip runReaderT caa . runExceptT . toCodeAction . f . astA $ s - _ -> pure $ Right [] -#else - toCodeAction f = ExceptT . ReaderT $ \caa@CodeActionArgs {caaParsedModule = x} -> - x >>= \case - Just s -> flip runReaderT caa . runExceptT . toCodeAction . f . pm_parsed_source $ s - _ -> pure $ Right [] -#endif + toCodeAction = toCodeAction2 caaAnnSource instance ToCodeAction r => ToCodeAction (ExportsMap -> r) where toCodeAction = toCodeAction3 caaExportsMap @@ -253,12 +242,9 @@ instance ToCodeAction r => ToCodeAction (Maybe DynFlags -> r) where instance ToCodeAction r => ToCodeAction (DynFlags -> r) where toCodeAction = toCodeAction2 caaDf -instance ToCodeAction r => ToCodeAction (Maybe (Annotated ParsedSource) -> r) where +instance ToCodeAction r => ToCodeAction (Maybe ParsedSource -> r) where toCodeAction = toCodeAction1 caaAnnSource -instance ToCodeAction r => ToCodeAction (Annotated ParsedSource -> r) where - toCodeAction = toCodeAction2 caaAnnSource - instance ToCodeAction r => ToCodeAction (Maybe TcModuleResult -> r) where toCodeAction = toCodeAction1 caaTmr diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs index a9d5c48cc1..7326e2d7e2 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs @@ -31,27 +31,31 @@ import GHC.Stack (HasCallStack) import Language.Haskell.GHC.ExactPrint import Language.LSP.Protocol.Types -import Development.IDE.Plugin.CodeAction.Util - --- GHC version specific imports. For any supported GHC version, make sure there is no warning in imports. import Control.Lens (_head, _last, over) import Data.Bifunctor (first) -import Data.Default (Default (..)) -import Data.Maybe (fromMaybe, - mapMaybe) +import Data.Maybe (fromMaybe, mapMaybe) +import Development.IDE.Plugin.CodeAction.Util import GHC (AddEpAnn (..), AnnContext (..), AnnList (..), AnnParen (..), DeltaPos (SameLine), EpAnn (..), - EpaLocation (EpaDelta), IsUnicodeSyntax (NormalSyntax), NameAdornment (NameParens), TrailingAnn (AddCommaAnn), - addAnns, ann, emptyComments, reAnnL) +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] + +#if !MIN_VERSION_ghc(9,9,0) +import Data.Default (Default (..)) +import GHC (addAnns, ann) +#endif + +#if MIN_VERSION_ghc(9,9,0) +import GHC (NoAnn (..)) +#endif ------------------------------------------------------------------------------ @@ -69,9 +73,13 @@ data Rewrite where ------------------------------------------------------------------------------ class ResetEntryDP ann where resetEntryDP :: GenLocated ann ast -> GenLocated ann ast +#if MIN_VERSION_ghc(9,9,0) +instance {-# OVERLAPPING #-} NoAnn an => ResetEntryDP (EpAnn an) where + resetEntryDP (L srcAnn x) = setEntryDP (L srcAnn{anns=noAnn} x) (SameLine 0) +#else instance {-# OVERLAPPING #-} Default an => ResetEntryDP (SrcAnn an) where - -- resetEntryDP = flip setEntryDP (SameLine 0) resetEntryDP (L srcAnn x) = setEntryDP (L srcAnn{ann=EpAnnNotUsed} x) (SameLine 0) +#endif instance {-# OVERLAPPABLE #-} ResetEntryDP fallback where resetEntryDP = id @@ -121,10 +129,12 @@ removeConstraint :: removeConstraint toRemove = go . traceAst "REMOVE_CONSTRAINT_input" where go :: LHsType GhcPs -> Rewrite -#if !MIN_VERSION_ghc(9,4,0) - go (L l it@HsQualTy{hst_ctxt = Just (L l' ctxt), hst_body}) = Rewrite (locA l) $ \_ -> do -#else +#if MIN_VERSION_ghc(9,9,0) + go lHsType@(makeDeltaAst -> L l it@HsQualTy{hst_ctxt = L l' ctxt, hst_body}) = Rewrite (locA lHsType) $ \_ -> do +#elif MIN_VERSION_ghc(9,4,0) go (L l it@HsQualTy{hst_ctxt = L l' ctxt, hst_body}) = Rewrite (locA l) $ \_ -> do +#else + go (L l it@HsQualTy{hst_ctxt = Just (L l' ctxt), hst_body}) = Rewrite (locA l) $ \_ -> do #endif let ctxt' = filter (not . toRemove) ctxt removeStuff = (toRemove <$> headMaybe ctxt) == Just True @@ -161,11 +171,19 @@ appendConstraint constraintT = go . traceAst "appendConstraint" #endif constraint <- liftParseAST df constraintT constraint <- pure $ setEntryDP constraint (SameLine 1) +#if MIN_VERSION_ghc(9,9,0) + let l'' = fmap (addParensToCtxt close_dp) l' +#else let l'' = (fmap.fmap) (addParensToCtxt close_dp) l' +#endif -- For singleton constraints, the close Paren DP is attached to an HsPar wrapping the constraint -- we have to reposition it manually into the AnnContext close_dp = case ctxt of +#if MIN_VERSION_ghc(9,9,0) + [L _ (HsParTy AnnParen{ap_close} _)] -> Just ap_close +#else [L _ (HsParTy EpAnn{anns=AnnParen{ap_close}} _)] -> Just ap_close +#endif _ -> Nothing ctxt' = over _last (first addComma) $ map dropHsParTy ctxt #if MIN_VERSION_ghc(9,4,0) @@ -187,7 +205,7 @@ appendConstraint constraintT = go . traceAst "appendConstraint" #endif annCtxt = AnnContext (Just (NormalSyntax, epl 1)) [epl 0 | needsParens] [epl 0 | needsParens] needsParens = hsTypeNeedsParens sigPrec $ unLoc constraint - ast <- pure $ setEntryDP ast (SameLine 1) + ast <- pure $ setEntryDP (makeDeltaAst ast) (SameLine 1) return $ reLocA $ L lTop $ HsQualTy noExtField context ast @@ -259,6 +277,9 @@ extendImportTopLevel thing (L l it@ImportDecl{..}) noExtField #endif lie +#if MIN_VERSION_ghc(9,9,0) + Nothing +#endif if x `elem` lies then TransformT $ lift (Left $ thing <> " already imported") @@ -304,9 +325,17 @@ extendImportViaParent df parent child (L l it@ImportDecl{..}) | Just (hide, L l' lies) <- ideclHiding = go hide l' [] lies #endif where +#if MIN_VERSION_ghc(9,9,0) + go _hide _l' _pre ((L _ll' (IEThingAll _ (L _ ie) _)) : _xs) +#else go _hide _l' _pre ((L _ll' (IEThingAll _ (L _ ie))) : _xs) +#endif | parent == unIEWrappedName ie = TransformT $ lift . Left $ child <> " already included in " <> parent <> " imports" +#if MIN_VERSION_ghc(9,9,0) + go hide l' pre ((L ll' (IEThingAbs _ absIE@(L _ ie) docs)) : xs) +#else go hide l' pre ((L ll' (IEThingAbs _ absIE@(L _ ie))) : xs) +#endif -- ThingAbs ie => ThingWith ie child | parent == unIEWrappedName ie = do srcChild <- uniqueSrcSpanT @@ -317,12 +346,18 @@ extendImportViaParent df parent child (L l it@ImportDecl{..}) #endif childRdr x :: LIE GhcPs = L ll' $ IEThingWith -#if MIN_VERSION_ghc(9,7,0) - (Nothing, addAnns mempty [AddEpAnn AnnOpenP (EpaDelta (SameLine 1) []), AddEpAnn AnnCloseP def] emptyComments) +#if MIN_VERSION_ghc(9,9,0) + (Nothing, [AddEpAnn AnnOpenP d1, AddEpAnn AnnCloseP noAnn]) +#elif MIN_VERSION_ghc(9,7,0) + (Nothing, addAnns mempty [AddEpAnn AnnOpenP d1, AddEpAnn AnnCloseP def] emptyComments) #else - (addAnns mempty [AddEpAnn AnnOpenP (EpaDelta (SameLine 1) []), AddEpAnn AnnCloseP def] emptyComments) + (addAnns mempty [AddEpAnn AnnOpenP d1, AddEpAnn AnnCloseP def] emptyComments) #endif absIE NoIEWildcard [childLIE] +#if MIN_VERSION_ghc(9,9,0) + docs +#endif + #if MIN_VERSION_ghc(9,5,0) return $ L l it{ideclImportList = Just (hide, L l' $ reverse pre ++ [x] ++ xs)} @@ -330,7 +365,11 @@ extendImportViaParent df parent child (L l it@ImportDecl{..}) return $ L l it{ideclHiding = Just (hide, L l' $ reverse pre ++ [x] ++ xs)} #endif +#if MIN_VERSION_ghc(9,9,0) + go hide l' pre ((L l'' (IEThingWith l''' twIE@(L _ ie) _ lies' docs)) : xs) +#else go hide l' pre ((L l'' (IEThingWith l''' twIE@(L _ ie) _ lies')) : xs) +#endif -- ThingWith ie lies' => ThingWith ie (lies' ++ [child]) | parent == unIEWrappedName ie , child == wildCardSymbol = do @@ -340,7 +379,10 @@ extendImportViaParent df parent child (L l it@ImportDecl{..}) let it' = it{ideclHiding = Just (hide, lies)} #endif thing = IEThingWith newl twIE (IEWildcard 2) [] -#if MIN_VERSION_ghc(9,7,0) +#if MIN_VERSION_ghc(9,9,0) + docs +#endif +#if MIN_VERSION_ghc(9,7,0) && !MIN_VERSION_ghc(9,9,0) newl = fmap (\ann -> ann ++ [AddEpAnn AnnDotdot d0]) <$> l''' #else newl = (\ann -> ann ++ [AddEpAnn AnnDotdot d0]) <$> l''' @@ -369,7 +411,11 @@ extendImportViaParent df parent child (L l it@ImportDecl{..}) let it' = it{ideclHiding = Just (hide, lies)} #endif lies = L l' $ reverse pre ++ - [L l'' (IEThingWith l''' twIE NoIEWildcard (over _last fixLast lies' ++ [childLIE]))] ++ xs + [L l'' (IEThingWith l''' twIE NoIEWildcard (over _last fixLast lies' ++ [childLIE]) +#if MIN_VERSION_ghc(9,9,0) + docs +#endif + )] ++ xs fixLast = if hasSibling then first addComma else id return $ L l it' go hide l' pre (x : xs) = go hide l' (x : pre) xs @@ -395,12 +441,17 @@ extendImportViaParent df parent child (L l it@ImportDecl{..}) noExtField #endif childRdr -#if MIN_VERSION_ghc(9,7,0) +#if MIN_VERSION_ghc(9,9,0) + listAnn = (Nothing, [AddEpAnn AnnOpenP (epl 1), AddEpAnn AnnCloseP (epl 0)]) +#elif MIN_VERSION_ghc(9,7,0) listAnn = (Nothing, epAnn srcParent [AddEpAnn AnnOpenP (epl 1), AddEpAnn AnnCloseP (epl 0)]) #else listAnn = epAnn srcParent [AddEpAnn AnnOpenP (epl 1), AddEpAnn AnnCloseP (epl 0)] #endif x :: LIE GhcPs = reLocA $ L l'' $ IEThingWith listAnn parentLIE NoIEWildcard [childLIE] +#if MIN_VERSION_ghc(9,9,0) + Nothing -- TODO preserve docs? +#endif lies' = addCommaInImportList (reverse pre) x #if MIN_VERSION_ghc(9,5,0) @@ -427,9 +478,14 @@ addCommaInImportList lies x = -- check if there is an existing trailing comma existingTrailingComma = fromMaybe False $ do L lastItemSrcAnn _ <- lastMaybe lies +#if MIN_VERSION_ghc(9,9,0) + lastItemAnn <- case lastItemSrcAnn of + EpAnn _ lastItemAnn _ -> pure lastItemAnn +#else lastItemAnn <- case ann lastItemSrcAnn of EpAnn _ lastItemAnn _ -> pure lastItemAnn _ -> Nothing +#endif pure $ any isTrailingAnnComma (lann_trailing lastItemAnn) hasSibling = not $ null lies @@ -465,7 +521,7 @@ hideSymbol symbol lidecl@(L loc ImportDecl{..}) = case ideclImportList of Nothing -> Rewrite (locA loc) $ extendHiding symbol lidecl Nothing Just (EverythingBut, hides) -> Rewrite (locA loc) $ extendHiding symbol lidecl (Just hides) - Just (Exactly, imports) -> Rewrite (locA loc) $ deleteFromImport symbol lidecl imports + Just (Exactly, imports) -> Rewrite (locA loc) $ deleteFromImport symbol lidecl $ setEntryDP (makeDeltaAst imports) (SameLine 1) #else case ideclHiding of Nothing -> Rewrite (locA loc) $ extendHiding symbol lidecl Nothing @@ -482,9 +538,17 @@ extendHiding :: extendHiding symbol (L l idecls) mlies df = do L l' lies <- case mlies of Nothing -> do +#if MIN_VERSION_ghc(9,9,0) + let ann = noAnnSrcSpanDP0 +#else src <- uniqueSrcSpanT let ann = noAnnSrcSpanDP0 src +#endif +#if MIN_VERSION_ghc(9,9,0) + ann' = flip fmap ann $ \x -> x +#else ann' = flip (fmap.fmap) ann $ \x -> x +#endif {al_rest = [AddEpAnn AnnHiding (epl 1)] ,al_open = Just $ AddEpAnn AnnOpenP (epl 1) ,al_close = Just $ AddEpAnn AnnCloseP (epl 0) @@ -508,6 +572,9 @@ extendHiding symbol (L l idecls) mlies df = do noExtField #endif lie +#if MIN_VERSION_ghc(9,9,0) + Nothing +#endif x <- pure $ if hasSibling then first addComma x else x lies <- pure $ over _head (`setEntryDP` SameLine 1) lies #if MIN_VERSION_ghc(9,5,0) @@ -530,24 +597,35 @@ deleteFromImport (T.pack -> symbol) (L l idecl) (L lieLoc lies) _ = do L l $ idecl #if MIN_VERSION_ghc(9,5,0) - { ideclImportList = Just (Exactly, edited) + { ideclImportList = Just (Exactly, edited) } #else - { ideclHiding = Just (False, edited) + { ideclHiding = Just (False, edited) } #endif - } pure lidecl' where deletedLies = over _last removeTrailingComma $ mapMaybe killLie lies killLie :: LIE GhcPs -> Maybe (LIE GhcPs) +#if MIN_VERSION_ghc(9,9,0) + killLie v@(L _ (IEVar _ (L _ (unqualIEWrapName -> nam)) _)) +#else killLie v@(L _ (IEVar _ (L _ (unqualIEWrapName -> nam)))) +#endif | nam == symbol = Nothing | otherwise = Just v +#if MIN_VERSION_ghc(9,9,0) + killLie v@(L _ (IEThingAbs _ (L _ (unqualIEWrapName -> nam)) _)) +#else killLie v@(L _ (IEThingAbs _ (L _ (unqualIEWrapName -> nam)))) +#endif | nam == symbol = Nothing | otherwise = Just v +#if MIN_VERSION_ghc(9,9,0) + killLie (L lieL (IEThingWith xt ty@(L _ (unqualIEWrapName -> nam)) wild cons docs)) +#else killLie (L lieL (IEThingWith xt ty@(L _ (unqualIEWrapName -> nam)) wild cons)) +#endif | nam == symbol = Nothing | otherwise = Just $ @@ -557,4 +635,7 @@ deleteFromImport (T.pack -> symbol) (L l idecl) (L lieLoc lies) _ = do ty wild (filter ((/= symbol) . unqualIEWrapName . unLoc) cons) +#if MIN_VERSION_ghc(9,9,0) + docs +#endif killLie v = Just v diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs index 17488b44a7..ed2d3b4a73 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs @@ -7,39 +7,51 @@ import Data.Bifunctor (Bifunctor (..)) import Data.Either.Extra (maybeToEither) import qualified Data.Text as T import Development.IDE.GHC.Compat -import Development.IDE.GHC.Compat.ExactPrint (exactPrint, - makeDeltaAst) import Development.IDE.GHC.Error (spanContainsRange) -import Development.IDE.GHC.ExactPrint (genAnchor1, - modifyMgMatchesT', +import Development.IDE.GHC.ExactPrint (modifyMgMatchesT', modifySigWithM, modifySmallestDeclWithM) import Development.IDE.Plugin.Plugins.Diagnostic -import GHC (EpAnn (..), - SrcSpanAnn' (SrcSpanAnn), - SrcSpanAnnA, - SrcSpanAnnN, - emptyComments, - noAnn) -import GHC.Types.SrcLoc (generatedSrcSpan) +import GHC.Parser.Annotation (SrcSpanAnnA, + SrcSpanAnnN, noAnn) import Ide.Plugin.Error (PluginError (PluginInternalError)) import Ide.PluginUtils (makeDiffTextEdit) import Language.Haskell.GHC.ExactPrint (TransformT (..), + exactPrint, noAnnSrcSpanDP1, runTransformT) import Language.LSP.Protocol.Types +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] + #if !MIN_VERSION_ghc(9,4,0) -import GHC (TrailingAnn (..)) -import GHC.Hs (IsUnicodeSyntax (..)) -import Language.Haskell.GHC.ExactPrint.Transform (d1) +import GHC.Parser.Annotation (IsUnicodeSyntax (..), + TrailingAnn (..)) +import Language.Haskell.GHC.ExactPrint (d1) #endif -#if MIN_VERSION_ghc(9,4,0) +#if MIN_VERSION_ghc(9,4,0) && !MIN_VERSION_ghc(9,9,0) import Development.IDE.GHC.ExactPrint (epl) import GHC.Parser.Annotation (TokenLocation (..)) #endif +#if !MIN_VERSION_ghc(9,9,0) +import Development.IDE.GHC.Compat.ExactPrint (makeDeltaAst) +import Development.IDE.GHC.ExactPrint (genAnchor1) +import GHC.Parser.Annotation (EpAnn (..), + SrcSpanAnn' (..), + emptyComments) +import GHC.Types.SrcLoc (generatedSrcSpan) +#endif + +#if MIN_VERSION_ghc(9,9,0) +import GHC (DeltaPos (..), + EpUniToken (..), + IsUnicodeSyntax (NormalSyntax)) +import Language.Haskell.GHC.ExactPrint (d1, setEntryDP) +#endif + + -- When GHC tells us that a variable is not bound, it will tell us either: -- - there is an unbound variable with a given type -- - there is an unbound variable (GHC provides no type suggestion) @@ -64,11 +76,20 @@ plugin parsedModule Diagnostic {_message, _range} -- returning how many patterns there were in this match prior to the transformation: -- addArgToMatch "foo" `bar arg1 arg2 = ...` -- => (`bar arg1 arg2 foo = ...`, 2) -addArgToMatch :: T.Text -> GenLocated l (Match GhcPs body) -> (GenLocated l (Match GhcPs body), Int) +addArgToMatch :: T.Text -> GenLocated l (Match GhcPs (LocatedA (HsExpr GhcPs))) -> (GenLocated l (Match GhcPs (LocatedA (HsExpr GhcPs))), Int) addArgToMatch name (L locMatch (Match xMatch ctxMatch pats rhs)) = let unqualName = mkRdrUnqual $ mkVarOcc $ T.unpack name +#if MIN_VERSION_ghc(9,9,0) + newPat = L noAnnSrcSpanDP1 $ VarPat NoExtField $ L noAnn unqualName + -- The intention is to move `= ...` (right-hand side with equals) to the right so there's 1 space between + -- the newly added pattern and the rest + indentRhs :: GRHSs GhcPs (LocatedA (HsExpr GhcPs)) -> GRHSs GhcPs (LocatedA (HsExpr GhcPs)) + indentRhs rhs@GRHSs{grhssGRHSs} = rhs {grhssGRHSs = fmap (`setEntryDP` (SameLine 1)) grhssGRHSs } +#else newPat = L (noAnnSrcSpanDP1 generatedSrcSpan) $ VarPat NoExtField (noLocA unqualName) - in (L locMatch (Match xMatch ctxMatch (pats <> [newPat]) rhs), Prelude.length pats) + indentRhs = id +#endif + in (L locMatch (Match xMatch ctxMatch (pats <> [newPat]) (indentRhs rhs)), Prelude.length pats) -- Attempt to insert a binding pattern into each match for the given LHsDecl; succeeds only if the function is a FunBind. -- Also return: @@ -107,7 +128,12 @@ appendFinalPatToMatches name = \case addArgumentAction :: ParsedModule -> Range -> T.Text -> Maybe T.Text -> Either PluginError [(T.Text, [TextEdit])] addArgumentAction (ParsedModule _ moduleSrc _ _) range name _typ = do (newSource, _, _) <- runTransformT $ do - (moduleSrc', join -> matchedDeclNameMay) <- addNameAsLastArgOfMatchingDecl (makeDeltaAst moduleSrc) + (moduleSrc', join -> matchedDeclNameMay) <- addNameAsLastArgOfMatchingDecl +#if MIN_VERSION_ghc(9,9,0) + moduleSrc +#else + (makeDeltaAst moduleSrc) +#endif case matchedDeclNameMay of Just (matchedDeclName, numPats) -> modifySigWithM (unLoc matchedDeclName) (addTyHoleToTySigArg numPats) moduleSrc' Nothing -> pure moduleSrc' @@ -136,16 +162,34 @@ hsTypeFromFunTypeAsList (args, res) = -- 0 `foo :: ()` => foo :: _ -> () -- 2 `foo :: FunctionTySyn` => foo :: FunctionTySyn -- 1 `foo :: () -> () -> Int` => foo :: () -> _ -> () -> Int -addTyHoleToTySigArg :: Int -> LHsSigType GhcPs -> (LHsSigType GhcPs) +addTyHoleToTySigArg :: Int -> LHsSigType GhcPs -> LHsSigType GhcPs addTyHoleToTySigArg loc (L annHsSig (HsSig xHsSig tyVarBndrs lsigTy)) = let (args, res) = hsTypeToFunTypeAsList lsigTy -#if MIN_VERSION_ghc(9,4,0) +#if MIN_VERSION_ghc(9,9,0) + wildCardAnn = noAnnSrcSpanDP1 + newArg = + ( noAnn + , noExtField + , HsUnrestrictedArrow (EpUniTok d1 NormalSyntax) + , L wildCardAnn $ HsWildCardTy noExtField + ) +#elif MIN_VERSION_ghc(9,4,0) wildCardAnn = SrcSpanAnn (EpAnn genAnchor1 (AnnListItem []) emptyComments) generatedSrcSpan arrowAnn = TokenLoc (epl 1) - newArg = (SrcSpanAnn mempty generatedSrcSpan, noAnn, HsUnrestrictedArrow (L arrowAnn HsNormalTok), L wildCardAnn $ HsWildCardTy noExtField) + newArg = + ( SrcSpanAnn mempty generatedSrcSpan + , noAnn + , HsUnrestrictedArrow (L arrowAnn HsNormalTok) + , L wildCardAnn $ HsWildCardTy noExtField + ) #else wildCardAnn = SrcSpanAnn (EpAnn genAnchor1 (AnnListItem [AddRarrowAnn d1]) emptyComments) generatedSrcSpan - newArg = (SrcSpanAnn mempty generatedSrcSpan, noAnn, HsUnrestrictedArrow NormalSyntax, L wildCardAnn $ HsWildCardTy noExtField) + newArg = + ( SrcSpanAnn mempty generatedSrcSpan + , noAnn + , HsUnrestrictedArrow NormalSyntax + , L wildCardAnn $ HsWildCardTy noExtField + ) #endif -- NOTE if the location that the argument wants to be placed at is not one more than the number of arguments -- in the signature, then we return the original type signature. @@ -156,4 +200,3 @@ addTyHoleToTySigArg loc (L annHsSig (HsSig xHsSig tyVarBndrs lsigTy)) = insertArg n (a:as) = a : insertArg (n - 1) as lsigTy' = hsTypeFromFunTypeAsList (insertArg loc args, res) in L annHsSig (HsSig xHsSig tyVarBndrs lsigTy') - diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs index 029561af55..f913e71b55 100644 --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -642,7 +642,7 @@ typeWildCardActionTests = testGroup "type wildcard actions" [ "func :: _" , "func x = x" ] - [ "func :: p -> p" + [ if ghcVersion >= GHC910 then "func :: t -> t" else "func :: p -> p" , "func x = x" ] , testUseTypeSignature "local signature" @@ -662,9 +662,12 @@ typeWildCardActionTests = testGroup "type wildcard actions" [ "func :: _" , "func x y = x + y" ] - [ if ghcVersion >= GHC98 - then "func :: a -> a -> a" -- since 9.8 GHC no longer does type defaulting (see https://gitlab.haskell.org/ghc/ghc/-/issues/24522) - else "func :: Integer -> Integer -> Integer" + [ if ghcVersion >= GHC910 then + "func :: t -> t -> t" + else if ghcVersion >= GHC98 then + "func :: a -> a -> a" -- since 9.8 GHC no longer does type defaulting (see https://gitlab.haskell.org/ghc/ghc/-/issues/24522) + else + "func :: Integer -> Integer -> Integer" , "func x y = x + y" ] , testUseTypeSignature "type in parentheses" @@ -692,9 +695,12 @@ typeWildCardActionTests = testGroup "type wildcard actions" [ "func::_" , "func x y = x + y" ] - [ if ghcVersion >= GHC98 - then "func::a -> a -> a" -- since 9.8 GHC no longer does type defaulting (see https://gitlab.haskell.org/ghc/ghc/-/issues/24522) - else "func::Integer -> Integer -> Integer" + [ if ghcVersion >= GHC910 then + "func::t -> t -> t" + else if ghcVersion >= GHC98 then + "func::a -> a -> a" -- since 9.8 GHC no longer does type defaulting (see https://gitlab.haskell.org/ghc/ghc/-/issues/24522) + else + "func::Integer -> Integer -> Integer" , "func x y = x + y" ] , testGroup "add parens if hole is part of bigger type" diff --git a/plugins/hls-refactor-plugin/test/Test/AddArgument.hs b/plugins/hls-refactor-plugin/test/Test/AddArgument.hs index 1816bd2a90..2f741c0003 100644 --- a/plugins/hls-refactor-plugin/test/Test/AddArgument.hs +++ b/plugins/hls-refactor-plugin/test/Test/AddArgument.hs @@ -34,7 +34,9 @@ tests = mkGoldenAddArgTest "AddArgWithSigAndDocs" (r 8 0 8 50), mkGoldenAddArgTest "AddArgFromLet" (r 2 0 2 50), mkGoldenAddArgTest "AddArgFromWhere" (r 3 0 3 50), - mkGoldenAddArgTest "AddArgFromWhereComments" (r 3 0 3 50), + -- TODO can we make this work for GHC 9.10? + knownBrokenForGhcVersions [GHC910] "In GHC 9.10 end-of-line comment annotation is in different place" $ + mkGoldenAddArgTest "AddArgFromWhereComments" (r 3 0 3 50), mkGoldenAddArgTest "AddArgWithTypeSynSig" (r 2 0 2 50), mkGoldenAddArgTest "AddArgWithTypeSynSigContravariant" (r 2 0 2 50), mkGoldenAddArgTest "AddArgWithLambda" (r 1 0 1 50), diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index 7d415fb092..2aeb16a808 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -147,7 +147,7 @@ getSrcEdit state verTxtDocId updatePs = do nfp <- getNormalizedFilePathE (verTxtDocId ^. L.uri) annAst <- runActionE "Rename.GetAnnotatedParsedSource" state (useE GetAnnotatedParsedSource nfp) - let ps = astA annAst + let ps = annAst src = T.pack $ exactPrint ps res = T.pack $ exactPrint (updatePs ps) pure $ diffText ccs (verTxtDocId, src) res IncludeDeletions diff --git a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs index 15fc8fb097..ca82fc73e8 100644 --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -219,7 +219,7 @@ runRetrieInlineThisCmd recorder state _token RunRetrieInlineThisParams{..} = do useE GetAnnotatedParsedSource nfpSource let fromRange = rangeToRealSrcSpan nfpSource $ getLocationRange inlineFromThisLocation intoRange = rangeToRealSrcSpan nfp $ getLocationRange inlineIntoThisLocation - inlineRewrite <- liftIO $ constructInlineFromIdentifer astSrc fromRange + inlineRewrite <- liftIO $ constructInlineFromIdentifer (unsafeMkA astSrc 0) fromRange when (null inlineRewrite) $ throwError $ PluginInternalError "Empty rewrite" (session, _) <- runActionE "retrie" state $ useWithStaleE GhcSessionDeps nfp @@ -345,7 +345,11 @@ getBinds nfp = do -- so that we can include adding the required imports in the retrie command let rn = tmrRenamed tm case rn of +#if MIN_VERSION_ghc(9,9,0) + (HsGroup{hs_valds, hs_ruleds, hs_tyclds}, _, _, _, _) -> do +#else (HsGroup{hs_valds, hs_ruleds, hs_tyclds}, _, _, _) -> do +#endif topLevelBinds <- case hs_valds of ValBinds{} -> throwError $ PluginInternalError "getBinds: ValBinds not supported" XValBindsLR (GHC.NValBinds binds _sigs :: GHC.NHsValBindsLR GhcRn) -> @@ -740,7 +744,12 @@ toImportDecl AddImport {..} = GHC.ImportDecl {ideclSource = ideclSource', ..} #if MIN_VERSION_ghc(9,5,0) ideclImportList = Nothing ideclExt = GHCGHC.XImportDeclPass - { ideclAnn = GHCGHC.EpAnnNotUsed + { ideclAnn = +#if MIN_VERSION_ghc(9,9,0) + GHCGHC.noAnn +#else + GHCGHC.EpAnnNotUsed +#endif , ideclSourceText = ideclSourceSrc , ideclImplicit = ideclImplicit } diff --git a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs index 2f0fcc1b92..f5613fa42a 100644 --- a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs +++ b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs @@ -7,12 +7,14 @@ import Data.Aeson (KeyValue (..), Object) import qualified Data.Aeson.KeyMap as KV import Data.Default import Data.Functor (void) +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 qualified Data.Text as Text import qualified Data.Text.Utf16.Rope.Mixed as Rope +import Data.Version (Version (..)) import Development.IDE (Pretty) import Development.IDE.Plugin.Test (WaitForIdeRuleResult (..)) import Ide.Plugin.SemanticTokens @@ -24,12 +26,13 @@ import Language.LSP.Protocol.Types import qualified Language.LSP.Test as Test import Language.LSP.VFS (VirtualFile (..)) import System.FilePath +import System.Info (compilerVersion) import Test.Hls import qualified Test.Hls.FileSystem as FS import Test.Hls.FileSystem (file, text) testDataDir :: FilePath -testDataDir = "plugins" "hls-semantic-tokens-plugin" "test" "testdata" +testDataDir = "plugins" "hls-semantic-tokens-plugin" "test" "testdata" testVersionDir mkFs :: [FS.FileTree] -> FS.VirtualFileTree mkFs = FS.mkVirtualFileTree testDataDir @@ -49,6 +52,14 @@ semanticTokensPlugin = Test.Hls.mkPluginTestDescriptor enabledSemanticDescriptor } } +-- if 9_10 and after we change the directory to the testdata/before_9_10 directory +-- if 9_10 and after we change the directory to the testdata/after_9_10 directory + +testVersionDir :: FilePath +testVersionDir + | compilerVersion >= Version [9, 10] [] = "after_9_10" + | otherwise = "before_9_10" + goldenWithHaskellAndCapsOutPut :: (Pretty b) => Config -> PluginTestDescriptor b -> TestName -> FS.VirtualFileTree -> FilePath -> String -> (TextDocumentIdentifier -> Session String) -> TestTree goldenWithHaskellAndCapsOutPut config plugin title tree path desc act = goldenGitDiff title (FS.vftOriginalRoot tree path <.> desc) $ @@ -151,9 +162,12 @@ semanticTokensConfigTest = doc <- openDoc "Hello.hs" "haskell" void waitForBuildQueue result1 <- docLspSemanticTokensString doc - liftIO $ unlines (map show result1) @?= "2:1-3 SemanticTokenTypes_Variable \"go\"\n" + liftIO $ unlines (map show result1) @?= + T.unlines (["1:8-13 SemanticTokenTypes_Namespace \"Hello\"" | compilerVersion >= Version [9, 10] []] + ++ ["2:1-3 SemanticTokenTypes_Variable \"go\""]) ] + semanticTokensFullDeltaTests :: TestTree semanticTokensFullDeltaTests = testGroup "semanticTokensFullDeltaTests" @@ -168,7 +182,9 @@ semanticTokensFullDeltaTests = liftIO $ delta @?= expectDelta, testCase "add tokens" $ do let file1 = "TModuleA.hs" - let expectDelta = InR (InL (SemanticTokensDelta (Just "1") [SemanticTokensEdit 20 0 (Just [2, 0, 3, 8, 0])])) + let expectDelta + | compilerVersion >= Version [9, 10] [] = InR (InL (SemanticTokensDelta (Just "1") [SemanticTokensEdit 25 0 (Just [2, 0, 3, 8, 0])])) + | otherwise = InR (InL (SemanticTokensDelta (Just "1") [SemanticTokensEdit 20 0 (Just [2, 0, 3, 8, 0])])) -- r c l t m -- where r = row, c = column, l = length, t = token, m = modifier Test.Hls.runSessionWithServerInTmpDir def semanticTokensPlugin (mkFs $ FS.directProjectMulti [file1]) $ do @@ -187,7 +203,9 @@ semanticTokensFullDeltaTests = liftIO $ delta @?= expectDelta, testCase "remove tokens" $ do let file1 = "TModuleA.hs" - let expectDelta = InR (InL (SemanticTokensDelta (Just "1") [SemanticTokensEdit 0 20 (Just [])])) + let expectDelta + | compilerVersion >= Version [9, 10] [] = InR (InL (SemanticTokensDelta (Just "1") [SemanticTokensEdit 5 20 (Just [])])) + | otherwise = InR (InL (SemanticTokensDelta (Just "1") [SemanticTokensEdit 0 20 (Just [])])) -- delete all tokens Test.Hls.runSessionWithServerInTmpDir def semanticTokensPlugin (mkFs $ FS.directProjectMulti [file1]) $ do doc1 <- openDoc file1 "haskell" @@ -226,7 +244,12 @@ semanticTokensTests = result <- docSemanticTokensString def doc2 let expect = unlines - [ "3:8-16 TModule \"TModuleA\"", + ( + -- > 9.10 have module name in the token + (["1:8-16 TModule \"TModuleB\"" | compilerVersion >= Version [9, 10] []]) + ++ + [ + "3:8-16 TModule \"TModuleA\"", "4:18-26 TModule \"TModuleA\"", "6:1-3 TVariable \"go\"", "6:6-10 TDataConstructor \"Game\"", @@ -234,7 +257,7 @@ semanticTokensTests = "8:8-17 TModule \"TModuleA.\"", "8:17-20 TRecordField \"a\\66560b\"", "8:21-23 TVariable \"go\"" - ] + ]) liftIO $ result @?= expect, goldenWithSemanticTokensWithDefaultConfig "mixed constancy test result generated from one ghc version" "T1", goldenWithSemanticTokensWithDefaultConfig "pattern bind" "TPatternSynonym", diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/T1.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/T1.expected new file mode 100644 index 0000000000..eff5c79768 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/T1.expected @@ -0,0 +1,82 @@ +4:8-12 TModule "Main" +9:6-9 TTypeConstructor "Foo" +9:12-15 TDataConstructor "Foo" +9:18-21 TRecordField "foo" +9:25-28 TTypeConstructor "Int" +11:7-10 TClass "Boo" +11:11-12 TTypeVariable "a" +12:3-6 TClassMethod "boo" +12:10-11 TTypeVariable "a" +12:15-16 TTypeVariable "a" +14:10-13 TClass "Boo" +14:14-17 TTypeConstructor "Int" +15:5-8 TClassMethod "boo" +15:9-10 TVariable "x" +15:13-14 TVariable "x" +15:15-16 TOperator "+" +17:6-8 TTypeConstructor "Dd" +17:11-13 TDataConstructor "Dd" +17:14-17 TTypeConstructor "Int" +19:9-12 TPatternSynonym "One" +19:15-18 TDataConstructor "Foo" +21:1-4 TVariable "ggg" +21:7-10 TPatternSynonym "One" +23:6-9 TTypeConstructor "Doo" +23:12-15 TDataConstructor "Doo" +23:16-24 TModule "Prelude." +23:24-27 TTypeConstructor "Int" +24:6-10 TTypeSynonym "Bar1" +24:13-16 TTypeConstructor "Int" +25:6-10 TTypeSynonym "Bar2" +25:13-16 TTypeConstructor "Doo" +27:1-3 TFunction "bb" +27:8-11 TClass "Boo" +27:12-13 TTypeVariable "a" +27:18-19 TTypeVariable "a" +27:23-24 TTypeVariable "a" +28:1-3 TFunction "bb" +28:4-5 TVariable "x" +28:9-12 TClassMethod "boo" +28:13-14 TVariable "x" +29:1-3 TFunction "aa" +29:7-11 TTypeVariable "cool" +29:15-18 TTypeConstructor "Int" +29:22-26 TTypeVariable "cool" +30:1-3 TFunction "aa" +30:4-5 TVariable "x" +30:9-10 TVariable "c" +30:14-16 TFunction "aa" +30:17-18 TVariable "x" +30:19-20 TVariable "c" +31:12-14 TVariable "xx" +31:16-18 TVariable "yy" +32:11-13 TVariable "dd" +34:2-4 TVariable "zz" +34:6-8 TVariable "kk" +35:1-3 TFunction "cc" +35:7-10 TTypeConstructor "Foo" +35:15-18 TTypeConstructor "Int" +35:20-23 TTypeConstructor "Int" +35:28-31 TTypeConstructor "Int" +36:1-3 TFunction "cc" +36:4-5 TVariable "f" +36:7-9 TVariable "gg" +36:11-13 TVariable "vv" +37:10-12 TVariable "gg" +38:14-17 TRecordField "foo" +38:18-19 TOperator "$" +38:20-21 TVariable "f" +38:24-27 TRecordField "foo" +39:14-17 TRecordField "foo" +39:18-19 TOperator "$" +39:20-21 TVariable "f" +39:24-27 TRecordField "foo" +41:1-3 TFunction "go" +41:6-9 TRecordField "foo" +42:1-4 TFunction "add" +42:8-16 TModule "Prelude." +42:16-17 TOperator "+" +47:1-5 TVariable "main" +47:9-11 TTypeConstructor "IO" +48:1-5 TVariable "main" +48:8-16 TFunction "putStrLn" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/T1.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/T1.hs similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/T1.hs rename to plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/T1.hs diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TClass.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TClass.expected new file mode 100644 index 0000000000..f7bb4cd513 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TClass.expected @@ -0,0 +1,6 @@ +1:8-14 TModule "TClass" +4:7-10 TClass "Foo" +4:11-12 TTypeVariable "a" +5:3-6 TClassMethod "foo" +5:10-11 TTypeVariable "a" +5:15-18 TTypeConstructor "Int" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TClass.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TClass.hs similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TClass.hs rename to plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TClass.hs diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TClassImportedDeriving.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TClassImportedDeriving.expected new file mode 100644 index 0000000000..9ca97d9082 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TClassImportedDeriving.expected @@ -0,0 +1,4 @@ +2:8-30 TModule "TClassImportedDeriving" +4:6-9 TTypeConstructor "Foo" +4:12-15 TDataConstructor "Foo" +4:26-30 TClass "Show" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TClassImportedDeriving.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TClassImportedDeriving.hs similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TClassImportedDeriving.hs rename to plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TClassImportedDeriving.hs diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDataFamily.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDataFamily.expected new file mode 100644 index 0000000000..b3b477e541 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDataFamily.expected @@ -0,0 +1,13 @@ +2:8-19 TModule "TDatafamily" +5:13-18 TTypeFamily "XList" +5:19-20 TTypeVariable "a" +8:15-20 TTypeFamily "XList" +8:21-25 TTypeConstructor "Char" +8:28-33 TDataConstructor "XCons" +8:35-39 TTypeConstructor "Char" +8:42-47 TTypeFamily "XList" +8:48-52 TTypeConstructor "Char" +8:56-60 TDataConstructor "XNil" +11:15-20 TTypeFamily "XList" +11:26-35 TDataConstructor "XListUnit" +11:37-40 TTypeConstructor "Int" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TDataFamily.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDataFamily.hs similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TDataFamily.hs rename to plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDataFamily.hs diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDataType.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDataType.expected new file mode 100644 index 0000000000..7f03f4ed54 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDataType.expected @@ -0,0 +1,5 @@ +1:8-17 TModule "TDataType" +3:6-9 TTypeConstructor "Foo" +3:12-15 TDataConstructor "Foo" +3:16-19 TTypeConstructor "Int" +3:30-32 TClass "Eq" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TDataType.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDataType.hs similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TDataType.hs rename to plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDataType.hs diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDatatypeImported.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDatatypeImported.expected new file mode 100644 index 0000000000..78ebf2bc22 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDatatypeImported.expected @@ -0,0 +1,6 @@ +1:8-25 TModule "TDatatypeImported" +3:8-17 TModule "System.IO" +5:1-3 TVariable "go" +5:7-9 TTypeConstructor "IO" +6:1-3 TVariable "go" +6:6-11 TFunction "print" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TDatatypeImported.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDatatypeImported.hs similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TDatatypeImported.hs rename to plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDatatypeImported.hs diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDoc.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDoc.expected new file mode 100644 index 0000000000..30b1cdb345 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDoc.expected @@ -0,0 +1,6 @@ +1:8-12 TModule "TDoc" +4:5-10 TVariable "hello" +5:1-6 TVariable "hello" +5:10-13 TTypeConstructor "Int" +6:1-6 TVariable "hello" +6:9-15 TClassMethod "length" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TDoc.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDoc.hs similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TDoc.hs rename to plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TDoc.hs diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunction.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunction.expected new file mode 100644 index 0000000000..2b715e0a40 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunction.expected @@ -0,0 +1,12 @@ +1:8-17 TModule "TFunction" +3:1-2 TFunction "f" +3:13-14 TTypeVariable "a" +3:16-17 TTypeVariable "a" +3:21-22 TTypeVariable "a" +4:1-2 TFunction "f" +4:3-4 TVariable "x" +4:7-8 TVariable "x" +6:1-2 TVariable "x" +6:6-7 TTypeVariable "a" +7:1-2 TVariable "x" +7:5-14 TVariable "undefined" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TFunction.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunction.hs similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TFunction.hs rename to plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunction.hs diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunctionLet.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunctionLet.expected new file mode 100644 index 0000000000..f51938a712 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunctionLet.expected @@ -0,0 +1,6 @@ +1:8-20 TModule "TFunctionLet" +3:1-2 TVariable "y" +3:6-9 TTypeConstructor "Int" +4:1-2 TVariable "y" +4:9-10 TFunction "f" +4:11-12 TVariable "x" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLet.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunctionLet.hs similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLet.hs rename to plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunctionLet.hs diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunctionLocal.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunctionLocal.expected new file mode 100644 index 0000000000..34e040d641 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunctionLocal.expected @@ -0,0 +1,8 @@ +1:8-22 TModule "TFunctionLocal" +3:1-2 TFunction "f" +3:6-9 TTypeConstructor "Int" +3:13-16 TTypeConstructor "Int" +4:1-2 TFunction "f" +4:7-8 TFunction "g" +6:5-6 TFunction "g" +6:7-8 TVariable "x" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLocal.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunctionLocal.hs similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLocal.hs rename to plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunctionLocal.hs diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunctionUnderTypeSynonym.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunctionUnderTypeSynonym.expected new file mode 100644 index 0000000000..0779402a83 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunctionUnderTypeSynonym.expected @@ -0,0 +1,18 @@ +1:8-33 TModule "TFunctionUnderTypeSynonym" +3:6-8 TTypeSynonym "T1" +3:11-14 TTypeConstructor "Int" +3:18-21 TTypeConstructor "Int" +4:6-8 TTypeSynonym "T2" +4:18-19 TTypeVariable "a" +4:21-22 TTypeVariable "a" +4:26-27 TTypeVariable "a" +5:1-3 TFunction "f1" +5:7-9 TTypeSynonym "T1" +6:1-3 TFunction "f1" +6:4-5 TVariable "x" +6:8-9 TVariable "x" +7:1-3 TFunction "f2" +7:7-9 TTypeSynonym "T2" +8:1-3 TFunction "f2" +8:4-5 TVariable "x" +8:8-9 TVariable "x" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionUnderTypeSynonym.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunctionUnderTypeSynonym.hs similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionUnderTypeSynonym.hs rename to plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TFunctionUnderTypeSynonym.hs diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TGADT.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TGADT.expected new file mode 100644 index 0000000000..3f07298543 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TGADT.expected @@ -0,0 +1,14 @@ +3:8-13 TModule "TGADT" +5:6-9 TTypeConstructor "Lam" +6:3-7 TDataConstructor "Lift" +6:11-12 TTypeVariable "a" +6:36-39 TTypeConstructor "Lam" +6:40-41 TTypeVariable "a" +7:3-6 TDataConstructor "Lam" +7:12-15 TTypeConstructor "Lam" +7:16-17 TTypeVariable "a" +7:21-24 TTypeConstructor "Lam" +7:25-26 TTypeVariable "b" +7:36-39 TTypeConstructor "Lam" +7:41-42 TTypeVariable "a" +7:46-47 TTypeVariable "b" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TGADT.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TGADT.hs similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TGADT.hs rename to plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TGADT.hs diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TInstanceClassMethodBind.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TInstanceClassMethodBind.expected new file mode 100644 index 0000000000..b93e340ac3 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TInstanceClassMethodBind.expected @@ -0,0 +1,8 @@ +1:8-32 TModule "TInstanceClassMethodBind" +4:6-9 TTypeConstructor "Foo" +4:12-15 TDataConstructor "Foo" +4:16-19 TTypeConstructor "Int" +5:10-14 TClass "Show" +5:15-18 TTypeConstructor "Foo" +6:5-9 TClassMethod "show" +6:12-21 TVariable "undefined" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodBind.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TInstanceClassMethodBind.hs similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodBind.hs rename to plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TInstanceClassMethodBind.hs diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TInstanceClassMethodUse.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TInstanceClassMethodUse.expected new file mode 100644 index 0000000000..3fc60caab3 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TInstanceClassMethodUse.expected @@ -0,0 +1,3 @@ +1:8-31 TModule "TInstanceClassMethodUse" +4:1-3 TFunction "go" +4:8-12 TClassMethod "show" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodUse.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TInstanceClassMethodUse.hs similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodUse.hs rename to plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TInstanceClassMethodUse.hs diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TModuleA.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TModuleA.hs similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TModuleA.hs rename to plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TModuleA.hs diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TModuleB.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TModuleB.hs similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TModuleB.hs rename to plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TModuleB.hs diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TNoneFunctionWithConstraint.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TNoneFunctionWithConstraint.expected new file mode 100644 index 0000000000..a004142952 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TNoneFunctionWithConstraint.expected @@ -0,0 +1,7 @@ +1:8-35 TModule "TNoneFunctionWithConstraint" +3:1-2 TVariable "x" +3:7-9 TClass "Eq" +3:10-11 TTypeVariable "a" +3:16-17 TTypeVariable "a" +4:1-2 TVariable "x" +4:5-14 TVariable "undefined" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TNoneFunctionWithConstraint.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TNoneFunctionWithConstraint.hs similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TNoneFunctionWithConstraint.hs rename to plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TNoneFunctionWithConstraint.hs diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TOperator.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TOperator.expected new file mode 100644 index 0000000000..c8b2ecb29d --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TOperator.expected @@ -0,0 +1,34 @@ +1:8-17 TModule "TOperator" +4:1-3 TFunction "go" +4:4-5 TFunction "f" +4:6-7 TVariable "x" +4:10-11 TFunction "f" +4:11-12 TOperator "$" +4:12-13 TVariable "x" +6:2-6 TOperator "$$$$" +7:1-2 TVariable "x" +7:7-11 TOperator "$$$$" +8:6-7 TTypeVariable "a" +8:8-11 TOperator ":+:" +8:12-13 TTypeVariable "b" +8:16-19 TDataConstructor "Add" +8:20-21 TTypeVariable "a" +8:22-23 TTypeVariable "b" +9:7-10 TOperator ":-:" +9:12-13 TTypeVariable "a" +9:14-15 TTypeVariable "b" +9:19-20 TTypeVariable "a" +9:22-23 TTypeVariable "b" +11:1-4 TFunction "add" +11:8-11 TTypeConstructor "Int" +11:12-15 TOperator ":+:" +11:16-19 TTypeConstructor "Int" +11:23-26 TTypeConstructor "Int" +11:27-30 TOperator ":-:" +11:31-34 TTypeConstructor "Int" +13:1-4 TFunction "add" +13:6-9 TDataConstructor "Add" +13:10-11 TVariable "x" +13:12-13 TVariable "y" +13:18-19 TVariable "x" +13:21-22 TVariable "y" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TOperator.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TOperator.hs similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TOperator.hs rename to plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TOperator.hs diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TPatternMatch.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TPatternMatch.expected new file mode 100644 index 0000000000..b17e52e27f --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TPatternMatch.expected @@ -0,0 +1,3 @@ +1:8-21 TModule "TPatternMatch" +4:1-2 TFunction "g" +4:4-11 TDataConstructor "Nothing" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternMatch.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TPatternMatch.hs similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TPatternMatch.hs rename to plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TPatternMatch.hs diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TPatternSynonym.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TPatternSynonym.expected new file mode 100644 index 0000000000..b9cff7321a --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TPatternSynonym.expected @@ -0,0 +1,2 @@ +2:8-23 TModule "TPatternSynonym" +5:9-12 TPatternSynonym "Foo" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternSynonym.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TPatternSynonym.hs similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TPatternSynonym.hs rename to plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TPatternSynonym.hs diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TPatternbind.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TPatternbind.expected new file mode 100644 index 0000000000..ab12539d12 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TPatternbind.expected @@ -0,0 +1,8 @@ +1:8-17 TModule "TVariable" +3:2-3 TVariable "a" +3:5-6 TVariable "b" +5:1-2 TFunction "f" +5:3-4 TFunction "g" +5:5-6 TVariable "y" +5:9-10 TFunction "g" +5:11-12 TVariable "y" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternbind.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TPatternbind.hs similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TPatternbind.hs rename to plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TPatternbind.hs diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TQualifiedName.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TQualifiedName.expected new file mode 100644 index 0000000000..df305195ed --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TQualifiedName.expected @@ -0,0 +1,13 @@ +1:8-22 TModule "TQualifiedName" +3:18-27 TModule "Data.List" +6:1-2 TVariable "a" +6:5-13 TModule "Prelude." +6:13-22 TVariable "undefined" +7:1-2 TVariable "b" +7:8-18 TModule "Data.List." +7:18-22 TClassMethod "elem" +8:1-2 TVariable "c" +8:6-14 TModule "Prelude." +8:14-15 TOperator "+" +9:1-2 TVariable "d" +9:6-7 TOperator "+" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TQualifiedName.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TQualifiedName.hs similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TQualifiedName.hs rename to plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TQualifiedName.hs diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TRecord.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TRecord.expected new file mode 100644 index 0000000000..5be40a4a39 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TRecord.expected @@ -0,0 +1,5 @@ +1:8-15 TModule "TRecord" +4:6-9 TTypeConstructor "Foo" +4:12-15 TDataConstructor "Foo" +4:18-21 TRecordField "foo" +4:25-28 TTypeConstructor "Int" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TRecord.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TRecord.hs similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TRecord.hs rename to plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TRecord.hs diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TRecordDuplicateRecordFields.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TRecordDuplicateRecordFields.expected new file mode 100644 index 0000000000..04ef050ab0 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TRecordDuplicateRecordFields.expected @@ -0,0 +1,5 @@ +3:8-36 TModule "TRecordDuplicateRecordFields" +5:6-9 TTypeConstructor "Foo" +5:12-15 TDataConstructor "Foo" +5:18-21 TRecordField "boo" +5:26-32 TTypeSynonym "String" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TRecordDuplicateRecordFields.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TRecordDuplicateRecordFields.hs similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TRecordDuplicateRecordFields.hs rename to plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TRecordDuplicateRecordFields.hs diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TTypefamily.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TTypefamily.expected new file mode 100644 index 0000000000..1aa6bf4687 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TTypefamily.expected @@ -0,0 +1,9 @@ +2:8-19 TModule "TTypefamily" +4:13-16 TTypeFamily "Foo" +4:17-18 TTypeVariable "a" +5:3-6 TTypeFamily "Foo" +5:7-10 TTypeConstructor "Int" +5:13-16 TTypeConstructor "Int" +6:3-6 TTypeFamily "Foo" +6:7-8 TTypeVariable "a" +6:11-17 TTypeSynonym "String" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TTypefamily.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TTypefamily.hs similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TTypefamily.hs rename to plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TTypefamily.hs diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TUnicodeSyntax.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TUnicodeSyntax.expected new file mode 100644 index 0000000000..ad9f6ea762 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TUnicodeSyntax.expected @@ -0,0 +1,2 @@ +1:8-22 TModule "TUnicodeSyntax" +3:1-4 TVariable "a\66560b" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TUnicodeSyntax.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TUnicodeSyntax.hs similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TUnicodeSyntax.hs rename to plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TUnicodeSyntax.hs diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TValBind.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TValBind.expected new file mode 100644 index 0000000000..700509c968 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TValBind.expected @@ -0,0 +1,5 @@ +1:8-16 TModule "TValBind" +4:1-6 TVariable "hello" +4:10-13 TTypeConstructor "Int" +5:1-6 TVariable "hello" +5:9-15 TClassMethod "length" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TValBind.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TValBind.hs similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TValBind.hs rename to plugins/hls-semantic-tokens-plugin/test/testdata/after_9_10/TValBind.hs diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/T1.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/T1.expected similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/T1.expected rename to plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/T1.expected diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/T1.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/T1.hs new file mode 100644 index 0000000000..07b0476c1e --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/T1.hs @@ -0,0 +1,48 @@ +-- patter syn +{-# LANGUAGE PatternSynonyms #-} + +module Main where + +-- import Data.Set (Set, insert) + + +data Foo = Foo { foo :: Int } + +class Boo a where + boo :: a -> a + +instance Boo Int where + boo x = x + 1 + +data Dd = Dd Int + +pattern One = Foo 1 + +ggg = One + +data Doo = Doo Prelude.Int +type Bar1 = Int +type Bar2 = Doo + +bb :: (Boo a) => a -> a +bb x = boo x +aa :: cool -> Int -> cool +aa x = \c -> aa x c + where (xx, yy) = (1, 2) + dd = 1 + +(zz, kk) = (1, 2) +cc :: Foo -> (Int, Int) -> Int +cc f (gg, vv)= + case gg of + 1 -> foo $ f { foo = 1 } + 2 -> foo $ f { foo = 1 } + +go = foo +add = (Prelude.+) + +-- sub :: Int -> Int -> Int +-- sub x y = add x y + +main :: IO () +main = putStrLn "Hello, Haskell!" diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TClass.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TClass.expected similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TClass.expected rename to plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TClass.expected diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TClass.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TClass.hs new file mode 100644 index 0000000000..692754ec71 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TClass.hs @@ -0,0 +1,6 @@ +module TClass where + + +class Foo a where + foo :: a -> Int + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TClassImportedDeriving.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TClassImportedDeriving.expected similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TClassImportedDeriving.expected rename to plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TClassImportedDeriving.expected diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TClassImportedDeriving.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TClassImportedDeriving.hs new file mode 100644 index 0000000000..8afd8afbd9 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TClassImportedDeriving.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE StandaloneDeriving #-} +module TClassImportedDeriving where +-- deriving method source span of Show occurrence +data Foo = Foo deriving (Show) + +-- standalone deriving method not in the same position +-- deriving instance Eq Foo + +-- a :: Foo -> Foo -> Bool +-- a = (==) diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TDataFamily.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDataFamily.expected similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TDataFamily.expected rename to plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDataFamily.expected diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDataFamily.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDataFamily.hs new file mode 100644 index 0000000000..b9047a72d2 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDataFamily.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TypeFamilies #-} +module TDatafamily where + +-- Declare a list-like data family +data family XList a + +-- Declare a list-like instance for Char +data instance XList Char = XCons !Char !(XList Char) | XNil + +-- Declare a number-like instance for () +data instance XList () = XListUnit !Int diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TDataType.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDataType.expected similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TDataType.expected rename to plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDataType.expected diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDataType.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDataType.hs new file mode 100644 index 0000000000..894065e391 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDataType.hs @@ -0,0 +1,3 @@ +module TDataType where + +data Foo = Foo Int deriving (Eq) diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TDatatypeImported.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDatatypeImported.expected similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TDatatypeImported.expected rename to plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDatatypeImported.expected diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDatatypeImported.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDatatypeImported.hs new file mode 100644 index 0000000000..f6ac8996d9 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDatatypeImported.hs @@ -0,0 +1,6 @@ +module TDatatypeImported where + +import System.IO + +go :: IO () +go = print 1 diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TDoc.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDoc.expected similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TDoc.expected rename to plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDoc.expected diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDoc.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDoc.hs new file mode 100644 index 0000000000..dc5801b0e6 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TDoc.hs @@ -0,0 +1,9 @@ +module TDoc where + +-- | +-- `hello` +hello :: Int +hello = length "Hello, Haskell!" + + + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TFunction.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunction.expected similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TFunction.expected rename to plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunction.expected diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunction.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunction.hs new file mode 100644 index 0000000000..4efe5cecc4 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunction.hs @@ -0,0 +1,7 @@ +module TFunction where + +f :: forall a. a -> a +f x = x + +x :: a +x = undefined diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLet.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunctionLet.expected similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLet.expected rename to plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunctionLet.expected diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunctionLet.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunctionLet.hs new file mode 100644 index 0000000000..96854c34ad --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunctionLet.hs @@ -0,0 +1,4 @@ +module TFunctionLet where + +y :: Int +y = let f x = 1 in 1 diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLocal.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunctionLocal.expected similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionLocal.expected rename to plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunctionLocal.expected diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunctionLocal.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunctionLocal.hs new file mode 100644 index 0000000000..fed144b00c --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunctionLocal.hs @@ -0,0 +1,8 @@ +module TFunctionLocal where + +f :: Int -> Int +f 1 = g 1 + where + g x = 1 + + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionUnderTypeSynonym.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunctionUnderTypeSynonym.expected similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TFunctionUnderTypeSynonym.expected rename to plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunctionUnderTypeSynonym.expected diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunctionUnderTypeSynonym.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunctionUnderTypeSynonym.hs new file mode 100644 index 0000000000..6485232394 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TFunctionUnderTypeSynonym.hs @@ -0,0 +1,9 @@ +module TFunctionUnderTypeSynonym where + +type T1 = Int -> Int +type T2 = forall a. a -> a +f1 :: T1 +f1 x = x +f2 :: T2 +f2 x = x + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TGADT.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TGADT.expected similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TGADT.expected rename to plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TGADT.expected diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TGADT.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TGADT.hs new file mode 100644 index 0000000000..e0cccf8bed --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TGADT.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} +module TGADT where + +data Lam :: * -> * where + Lift :: a -> Lam a -- ^ lifted value + Lam :: (Lam a -> Lam b) -> Lam (a -> b) -- ^ lambda abstraction diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodBind.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TInstanceClassMethodBind.expected similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodBind.expected rename to plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TInstanceClassMethodBind.expected diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TInstanceClassMethodBind.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TInstanceClassMethodBind.hs new file mode 100644 index 0000000000..33976a48c1 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TInstanceClassMethodBind.hs @@ -0,0 +1,6 @@ +module TInstanceClassMethodBind where + + +data Foo = Foo Int +instance Show Foo where + show = undefined diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodUse.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TInstanceClassMethodUse.expected similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TInstanceClassMethodUse.expected rename to plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TInstanceClassMethodUse.expected diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TInstanceClassMethodUse.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TInstanceClassMethodUse.hs new file mode 100644 index 0000000000..689d1643d4 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TInstanceClassMethodUse.hs @@ -0,0 +1,5 @@ +module TInstanceClassMethodUse where + + +go = show + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TModuleA.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TModuleA.hs new file mode 100644 index 0000000000..d76f64fc1f --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TModuleA.hs @@ -0,0 +1,5 @@ +module TModuleA where + +data Game = Game {a𐐀b :: Int} + + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TModuleB.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TModuleB.hs new file mode 100644 index 0000000000..d2bfe4b7fa --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TModuleB.hs @@ -0,0 +1,8 @@ +module TModuleB where + +import TModuleA +import qualified TModuleA + +go = Game 1 + +a𐐀bb = TModuleA.a𐐀b go diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TNoneFunctionWithConstraint.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TNoneFunctionWithConstraint.expected similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TNoneFunctionWithConstraint.expected rename to plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TNoneFunctionWithConstraint.expected diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TNoneFunctionWithConstraint.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TNoneFunctionWithConstraint.hs new file mode 100644 index 0000000000..9a7119dbdb --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TNoneFunctionWithConstraint.hs @@ -0,0 +1,5 @@ +module TNoneFunctionWithConstraint where + +x :: (Eq a) => a +x = undefined + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TOperator.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TOperator.expected similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TOperator.expected rename to plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TOperator.expected diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TOperator.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TOperator.hs new file mode 100644 index 0000000000..e2f06c92fa --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TOperator.hs @@ -0,0 +1,13 @@ +module TOperator where + +-- imported operator +go f x = f$x +-- operator defined in local module +($$$$) = b +x = 1 $$$$ 2 +data a :+: b = Add a b +type (:-:) a b = (a, b) +-- type take precedence over operator +add :: Int :+: Int -> Int :-: Int +-- class method take precedence over operator +add (Add x y) = (x, y) diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternMatch.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TPatternMatch.expected similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TPatternMatch.expected rename to plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TPatternMatch.expected diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TPatternMatch.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TPatternMatch.hs new file mode 100644 index 0000000000..95e97c1abb --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TPatternMatch.hs @@ -0,0 +1,6 @@ +module TPatternMatch where + + +g (Nothing, _) = 1 + + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternSynonym.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TPatternSynonym.expected similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TPatternSynonym.expected rename to plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TPatternSynonym.expected diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TPatternSynonym.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TPatternSynonym.hs new file mode 100644 index 0000000000..adff673ce8 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TPatternSynonym.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PatternSynonyms #-} +module TPatternSynonym where + + +pattern Foo = 1 + + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TPatternbind.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TPatternbind.expected similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TPatternbind.expected rename to plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TPatternbind.expected diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TPatternbind.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TPatternbind.hs new file mode 100644 index 0000000000..49e642a35d --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TPatternbind.hs @@ -0,0 +1,9 @@ +module TVariable where + +(a, b) = (1, 2) + +f g y = g y + + + + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TQualifiedName.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TQualifiedName.expected similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TQualifiedName.expected rename to plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TQualifiedName.expected diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TQualifiedName.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TQualifiedName.hs new file mode 100644 index 0000000000..5dbdcc1d52 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TQualifiedName.hs @@ -0,0 +1,9 @@ +module TQualifiedName where + +import qualified Data.List + + +a = Prelude.undefined +b = 1 `Data.List.elem` [1, 2] +c = (Prelude.+) 1 1 +d = (+) 1 1 diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TRecord.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TRecord.expected similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TRecord.expected rename to plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TRecord.expected diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TRecord.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TRecord.hs new file mode 100644 index 0000000000..b3176a154f --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TRecord.hs @@ -0,0 +1,7 @@ +module TRecord where + + +data Foo = Foo { foo :: Int } + + + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TRecordDuplicateRecordFields.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TRecordDuplicateRecordFields.expected similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TRecordDuplicateRecordFields.expected rename to plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TRecordDuplicateRecordFields.expected diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TRecordDuplicateRecordFields.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TRecordDuplicateRecordFields.hs new file mode 100644 index 0000000000..395a1d3731 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TRecordDuplicateRecordFields.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +module TRecordDuplicateRecordFields where + +data Foo = Foo { boo :: !String } diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TTypefamily.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TTypefamily.expected similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TTypefamily.expected rename to plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TTypefamily.expected diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TTypefamily.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TTypefamily.hs new file mode 100644 index 0000000000..d8c925e370 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TTypefamily.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TypeFamilies #-} +module TTypefamily where + +type family Foo a where + Foo Int = Int + Foo a = String diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TUnicodeSyntax.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TUnicodeSyntax.expected similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TUnicodeSyntax.expected rename to plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TUnicodeSyntax.expected diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TUnicodeSyntax.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TUnicodeSyntax.hs new file mode 100644 index 0000000000..1b8c7c1baa --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TUnicodeSyntax.hs @@ -0,0 +1,5 @@ +module TUnicodeSyntax where + +a𐐀b = "a𐐀b" + + diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/TValBind.expected b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TValBind.expected similarity index 100% rename from plugins/hls-semantic-tokens-plugin/test/testdata/TValBind.expected rename to plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TValBind.expected diff --git a/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TValBind.hs b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TValBind.hs new file mode 100644 index 0000000000..506af37a42 --- /dev/null +++ b/plugins/hls-semantic-tokens-plugin/test/testdata/before_9_10/TValBind.hs @@ -0,0 +1,8 @@ +module TValBind where + + +hello :: Int +hello = length "Hello, Haskell!" + + + diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index 9ec6ea8c2d..6e913d8367 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -10,69 +10,63 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} -module Ide.Plugin.Splice - ( descriptor, - ) -where - -import Control.Applicative (Alternative ((<|>))) -import Control.Arrow (Arrow (first)) -import Control.Exception (SomeException) -import qualified Control.Foldl as L -import Control.Lens (Identity (..), ix, - view, (%~), (<&>), - (^.)) -import Control.Monad (forM, guard, unless) -import Control.Monad.Error.Class (MonadError (throwError)) -import Control.Monad.Extra (eitherM) -import qualified Control.Monad.Fail as Fail -import Control.Monad.IO.Unlift (MonadIO (..), - askRunInIO) -import Control.Monad.Trans.Class (MonadTrans (lift)) -import Control.Monad.Trans.Except (ExceptT (..), - runExceptT) +module Ide.Plugin.Splice (descriptor) where + +import Control.Applicative (Alternative ((<|>))) +import Control.Arrow (Arrow (first)) +import Control.Exception (SomeException) +import qualified Control.Foldl as L +import Control.Lens (Identity (..), ix, view, + (%~), (<&>), (^.)) +import Control.Monad (forM, guard, unless) +import Control.Monad.Error.Class (MonadError (throwError)) +import Control.Monad.Extra (eitherM) +import qualified Control.Monad.Fail as Fail +import Control.Monad.IO.Unlift (MonadIO (..), + askRunInIO) +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Control.Monad.Trans.Except (ExceptT (..), + runExceptT) import Control.Monad.Trans.Maybe -import Data.Aeson hiding (Null) -import qualified Data.Bifunctor as B (first) -import Data.Foldable (Foldable (foldl')) +import Data.Aeson hiding (Null) +import qualified Data.Bifunctor as B (first) import Data.Function import Data.Generics -import qualified Data.Kind as Kinds -import Data.List (sortOn) -import Data.Maybe (fromMaybe, - listToMaybe, - mapMaybe) -import qualified Data.Text as T +import qualified Data.Kind as Kinds +import Data.List (sortOn) +import Data.Maybe (fromMaybe, listToMaybe, + mapMaybe) +import qualified Data.Text as T import Development.IDE import Development.IDE.Core.PluginUtils -import Development.IDE.GHC.Compat as Compat hiding - (getLoc) +import Development.IDE.GHC.Compat as Compat import Development.IDE.GHC.Compat.ExactPrint -import qualified Development.IDE.GHC.Compat.Util as Util +import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.GHC.ExactPrint -import Language.Haskell.GHC.ExactPrint.Transform (TransformT (TransformT)) - -#if MIN_VERSION_ghc(9,4,1) - -import GHC.Data.Bag (Bag) - -#endif - import GHC.Exts - - -import GHC.Parser.Annotation (SrcSpanAnn' (..)) -import qualified GHC.Types.Error as Error - - -import Ide.Plugin.Error (PluginError (PluginInternalError)) +import qualified GHC.Types.Error as Error +import Ide.Plugin.Error (PluginError (PluginInternalError)) import Ide.Plugin.Splice.Types import Ide.Types -import Language.Haskell.GHC.ExactPrint (uniqueSrcSpanT) -import qualified Language.LSP.Protocol.Lens as J +import qualified Language.LSP.Protocol.Lens as J import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types +#if !MIN_VERSION_base(4,20,0) +import Data.Foldable (Foldable (foldl')) +#endif + +#if MIN_VERSION_ghc(9,4,1) +import GHC.Data.Bag (Bag) +#endif + +#if MIN_VERSION_ghc(9,9,0) +import GHC.Parser.Annotation (EpAnn (..)) +#else +import GHC.Parser.Annotation (SrcSpanAnn' (..)) +#endif + + descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId "Provides a code action to evaluate a TemplateHaskell splice") @@ -211,7 +205,7 @@ setupHscEnv :: IdeState -> NormalizedFilePath -> ParsedModule - -> ExceptT PluginError IO (Annotated ParsedSource, HscEnv, DynFlags) + -> ExceptT PluginError IO (ParsedSource, HscEnv, DynFlags) setupHscEnv ideState fp pm = do hscEnvEq <- runActionE "expandTHSplice.fallback.ghcSessionDeps" ideState $ useE GhcSessionDeps fp @@ -227,10 +221,10 @@ setupDynFlagsForGHCiLike env dflags = do platform = targetPlatform dflags3 dflags3a = setWays hostFullWays dflags3 dflags3b = - foldl gopt_set dflags3a $ + foldl' gopt_set dflags3a $ concatMap (wayGeneralFlags platform) hostFullWays dflags3c = - foldl gopt_unset dflags3b $ + foldl' gopt_unset dflags3b $ concatMap (wayUnsetGeneralFlags platform) hostFullWays dflags4 = dflags3c @@ -277,8 +271,13 @@ adjustToRange uri ran (WorkspaceEdit mhult mlt x) = -- `GenLocated`. In GHC >= 9.2 this will be a SrcSpanAnn', with annotations; -- earlier it will just be a plain `SrcSpan`. {-# COMPLETE AsSrcSpan #-} +#if MIN_VERSION_ghc(9,9,0) +pattern AsSrcSpan :: SrcSpan -> EpAnn ann +pattern AsSrcSpan locA <- (getLoc -> locA) +#else pattern AsSrcSpan :: SrcSpan -> SrcSpanAnn' a pattern AsSrcSpan locA <- SrcSpanAnn {locA} +#endif findSubSpansDesc :: SrcSpan -> [(LHsExpr GhcTc, a)] -> [(SrcSpan, a)] findSubSpansDesc srcSpan = @@ -360,7 +359,7 @@ manualCalcEdit :: ClientCapabilities -> ReportEditor -> Range -> - Annotated ParsedSource -> + ParsedSource -> HscEnv -> TcGblEnv -> RealSrcSpan -> diff --git a/shake-bench/shake-bench.cabal b/shake-bench/shake-bench.cabal index eccd84edeb..d5852a6310 100644 --- a/shake-bench/shake-bench.cabal +++ b/shake-bench/shake-bench.cabal @@ -16,6 +16,8 @@ source-repository head location: https://github.com/haskell/haskell-language-server.git library + if impl(ghc >= 9.10) + buildable: False exposed-modules: Development.Benchmark.Rules hs-source-dirs: src build-depends: