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/cabal.project b/cabal.project index d7339b4d80..ae5930a9aa 100644 --- a/cabal.project +++ b/cabal.project @@ -7,12 +7,12 @@ packages: ./hls-plugin-api ./hls-test-utils -index-state: 2024-04-30T10:44:19Z +index-state: 2024-05-18T02:15:01Z tests: True test-show-details: direct -benchmarks: True +-- benchmarks: True write-ghc-environment-files: never @@ -40,4 +40,37 @@ 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 + source-repository-package + type:git + location: https://github.com/wz1000/retrie.git + tag: 7bf599856f055aefa86a6db10c12dcbc10c7130a + constraints: + lens >= 5.3.2, + haskell-language-server -stylishHaskell -ormolu -fourmolu -floskell -hlint, + allow-newer: + co-log-core:base, + constraints-extras:base, + constraints-extras:template-haskell, + commutative-semigroups:base, + dependent-map:containers, + entropy:base, + entropy:directory, + entropy:filepath, + entropy:process, + free:template-haskell, + haddock-library:base, + haddock-library:containers, + hie-bios:ghc, + hiedb:base, + hiedb:ghc, + monoid-subclasses:containers, + quickcheck-instances:base, + quickcheck-instances:containers, + uuid-types:template-haskell, +else + benchmarks: True diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 0d70f31bb7..2b5be914d4 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -88,7 +88,7 @@ library , implicit-hie >= 0.1.4.0 && < 0.1.5 , lens , list-t - , lsp ^>=2.5.0.0 + , lsp ^>=2.6.0.0 , lsp-types ^>=2.2.0.0 , mtl , opentelemetry >=0.6.1 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/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 75590d0596..b377fec0c7 100644 --- a/ghcide/src/Development/IDE/GHC/Compat.hs +++ b/ghcide/src/Development/IDE/GHC/Compat.hs @@ -334,7 +334,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) @@ -510,13 +514,16 @@ data GhcVersion | GHC94 | GHC96 | GHC98 + | GHC910 deriving (Eq, Ord, Show) 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/exe/CodeLensTests.hs b/ghcide/test/exe/CodeLensTests.hs index 6bebeda002..5fa86de3ae 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/FindDefinitionAndHoverTests.hs b/ghcide/test/exe/FindDefinitionAndHoverTests.hs index d315c84c75..3035f9fd73 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"], mkL bar 3 (if ghcVersion >= GHC94 && ghcVersion < GHC910 then 5 else 0) 3 (if ghcVersion >= GHC94 && ghcVersion < GHC910 then 8 else 14)] thLocL57 = Position 59 10 ; thLoc = [ExpectHoverText ["Identity"]] cmtL68 = Position 67 0 ; lackOfdEq = [ExpectHoverExcludeText ["$dEq"]] import310 = Position 3 10; pkgTxt = [ExpectHoverText ["Data.Text\n\ntext-"]] diff --git a/ghcide/test/exe/OutlineTests.hs b/ghcide/test/exe/OutlineTests.hs index 640e13a907..82d2131050 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 cc5b5eba6c..169e8b2e39 100644 --- a/ghcide/test/exe/PluginSimpleTests.hs +++ b/ghcide/test/exe/PluginSimpleTests.hs @@ -36,7 +36,7 @@ tests = -- Error: cabal: Failed to build ghc-typelits-natnormalise-0.7.7 (which is -- required by plugin-1.0.0). See the build log above for details. - ignoreFor (BrokenForGHC [GHC96, GHC98]) "fragile, frequently times out" $ + ignoreFor (BrokenForGHC [GHC96, GHC98, GHC910]) "fragile, frequently times out" $ ignoreFor (BrokenSpecific Windows [GHC94]) "ghc-typelist-natnormalise fails to build on GHC 9.4.2 for windows only" $ testSessionWithExtraFiles "plugin-knownnat" "simple plugin" $ \dir -> do _ <- openDoc (dir "KnownNat.hs") "haskell" diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 5f673caafe..3beb1ccff0 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -258,7 +258,7 @@ library hls-cabal-plugin , hls-plugin-api == 2.8.0.0 , hls-graph == 2.8.0.0 , lens - , lsp ^>=2.5 + , lsp ^>=2.6 , lsp-types ^>=2.2 , regex-tdfa ^>=1.3.1 , text @@ -389,7 +389,7 @@ library hls-call-hierarchy-plugin , hiedb ^>= 0.6.0.0 , hls-plugin-api == 2.8.0.0 , lens - , lsp >=2.5 + , lsp >=2.6 , sqlite-simple , text @@ -1002,7 +1002,7 @@ library hls-alternate-number-format-plugin , hls-graph , hls-plugin-api == 2.8.0.0 , lens - , lsp ^>=2.5 + , lsp ^>=2.6 , mtl , regex-tdfa , syb @@ -1232,7 +1232,7 @@ library hls-gadt-plugin , hls-plugin-api == 2.8.0.0 , haskell-language-server:hls-refactor-plugin , lens - , lsp >=2.5 + , lsp >=2.6 , mtl , text , transformers @@ -1281,7 +1281,7 @@ library hls-explicit-fixity-plugin , ghcide == 2.8.0.0 , hashable , hls-plugin-api == 2.8.0.0 - , lsp >=2.5 + , lsp >=2.6 , text default-extensions: DataKinds @@ -1662,11 +1662,12 @@ library hls-refactor-plugin , 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 @@ -1736,7 +1737,7 @@ library hls-semantic-tokens-plugin , ghcide == 2.8.0.0 , hls-plugin-api == 2.8.0.0 , lens - , lsp >=2.5 + , lsp >=2.6 , text , transformers , bytestring @@ -1804,7 +1805,7 @@ library hls-notes-plugin , hls-graph == 2.8.0.0 , hls-plugin-api == 2.8.0.0 , lens - , lsp >=2.5 + , lsp >=2.6 , mtl >= 2.2 , regex-tdfa >= 1.3.1 , text 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 7f2cee0a8c..e49b9ad91d 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/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index eb00b42e00..8ab49c789f 100644 --- a/hls-plugin-api/hls-plugin-api.cabal +++ b/hls-plugin-api/hls-plugin-api.cabal @@ -69,7 +69,7 @@ library , hls-graph == 2.8.0.0 , lens , lens-aeson - , lsp ^>=2.5 + , lsp ^>=2.6 , megaparsec >=9.0 , mtl , opentelemetry >=0.4 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 5212b2c6da..faacaceacf 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -70,7 +70,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) @@ -103,6 +102,10 @@ import Prettyprinter as PP import System.FilePath import System.IO.Unsafe import Text.Regex.TDFA.Text () + +#if !MIN_VERSION_base(4,20,0) +import Data.Foldable (foldl') +#endif -- --------------------------------------------------------------------- data IdePlugins ideState = IdePlugins_ 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..c08e4344a6 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/ExactPrint.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/ExactPrint.hs @@ -56,8 +56,17 @@ 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 instd@(InstD xInstD (ClsInstD ext decl@ClsInstDecl{..})) = + addWhere :: HsDecl GhcPs -> HsDecl GhcPs + addWhere _instd@(InstD xInstD (ClsInstD ext decl@ClsInstDecl{..})) = case cid_ext of +#if MIN_VERSION_ghc(9,9,0) + (warnings, anns, key) -> + InstD xInstD (ClsInstD ext decl { + cid_ext = ( warnings + , AddEpAnn AnnWhere (EpaDelta (SameLine 1) []) : anns + , key) + }) +#else (EpAnn entry anns comments, key) -> InstD xInstD (ClsInstD ext decl { cid_ext = (EpAnn @@ -66,10 +75,15 @@ addMethodDecls ps mDecls range withSig comments , key) }) - _ -> instd + _ -> _instd +#endif addWhere decl = decl newLine (L l e) = let dp = deltaPos 1 defaultIndent +#if MIN_VERSION_ghc(9,9,0) + in L (noAnnSrcSpanDP dp <> l) e +#else in L (noAnnSrcSpanDP (getLoc l) dp <> l) e +#endif 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-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-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index 2c599b5b6b..04b0b3c3a6 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -361,7 +361,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..9545865efc 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,11 @@ import Development.IDE.Core.RuleTypes (TcModuleResult (..), TypeCheck (..)) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat (HsConDetails (RecCon), +#if __GLASGOW_HASKELL__ < 910 HsExpansion (HsExpanded), +#else + XXExprGhcRn(..), +#endif HsExpr (XExpr), HsRecFields (..), LPat, Outputable, getLoc, @@ -176,7 +180,11 @@ collectRecordsRule recorder = toRangeAndUnique (uid, recordInfo) = (recordInfoToRange recordInfo, uid) getRecords :: TcModuleResult -> [RecordInfo] +#if __GLASGOW_HASKELL__ < 910 getRecords (tmrRenamed -> (hs_valds -> valBinds,_,_,_)) = +#else +getRecords (tmrRenamed -> (hs_valds -> valBinds,_,_,_, _)) = +#endif collectRecords valBinds collectNamesRule :: Rules () @@ -187,7 +195,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] +#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 +369,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..fff2096d44 100644 --- a/plugins/hls-gadt-plugin/src/Ide/Plugin/GHC.hs +++ b/plugins/hls-gadt-plugin/src/Ide/Plugin/GHC.hs @@ -14,23 +14,39 @@ 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) 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), + EpaLocation (EpaDelta), + SrcSpanAnn' (SrcSpanAnn)) +import Language.Haskell.GHC.ExactPrint (showAst) +#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 +99,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 +123,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,13 +226,25 @@ 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 ann r) = + L (EpAnn (go (spanAsAnchor (getLoc ann))) (AnnListItem []) (EpaComments [])) r +#else adjustCon (L (SrcSpanAnn _ loc) r) = L (SrcSpanAnn (EpAnn (go (spanAsAnchor loc)) (AnnListItem []) (EpaComments [])) loc) r +#endif where +#if MIN_VERSION_ghc(9,9,0) + go _ = EpaDelta (DifferentLine 1 2) [] +#else go (Anchor a _) = Anchor a (MovedAnchor (DifferentLine 1 2)) +#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) []) @@ -220,7 +262,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-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs b/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs index 03b62b4a5b..e7e365ac24 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 @@ -48,7 +48,11 @@ import Development.IDE.Core.PositionMapping (PositionMapping, toCurrentRange) import Development.IDE.GHC.Compat (Extension (OverloadedRecordDot), GhcPass, +#if __GLASGOW_HASKELL__ < 910 HsExpansion (HsExpanded), +#else + XXExprGhcRn(..), +#endif HsExpr (HsApp, HsVar, OpApp, XExpr), LHsExpr, Pass (..), appPrec, dollarName, @@ -246,7 +250,11 @@ collectRecSelsRule recorder = define (cmapWithPrio LogShake recorder) $ where getEnabledExtensions :: TcModuleResult -> [Extension] getEnabledExtensions = getExtensions . tmrParsed getRecordSelectors :: TcModuleResult -> [RecordSelectorExpr] +#if __GLASGOW_HASKELL__ >= 910 + getRecordSelectors (tmrRenamed -> (hs_valds -> valBinds,_,_,_,_)) = +#else getRecordSelectors (tmrRenamed -> (hs_valds -> valBinds,_,_,_)) = +#endif collectRecordSelectors valBinds rewriteRange :: PositionMapping -> RecordSelectorExpr -> Maybe RecordSelectorExpr @@ -281,7 +289,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/Dump.hs b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs index 93da3ba76f..8aee3d5bad 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs @@ -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..c20c216f16 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 @@ -85,34 +83,55 @@ 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) ------------------------------------------------------------------------------ @@ -232,7 +251,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 @@ -440,19 +461,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. @@ -490,15 +527,28 @@ 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 [] -> [] +#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))) ] @@ -513,6 +563,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)) @@ -596,7 +653,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 +749,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 +766,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 5c25c5f960..39b362e20b 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 @@ -105,6 +103,22 @@ 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. @@ -253,7 +267,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 @@ -307,7 +321,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 @@ -338,7 +352,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: @@ -537,7 +555,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 @@ -608,16 +626,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 @@ -1613,7 +1631,7 @@ 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 @@ -1663,12 +1681,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 @@ -1682,12 +1705,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 @@ -1936,22 +1970,39 @@ smallerRangesForBindingExport lies b = where unqualify = snd . breakOnEnd "." 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/ExactPrint.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs index a9d5c48cc1..70a76ea73a 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,33 @@ 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 (EpaLocation (EpaDelta), + addAnns, ann) +#endif + +#if MIN_VERSION_ghc(9,9,0) +import GHC (EpaLocation' (..), + NoAnn (..)) +#endif ------------------------------------------------------------------------------ @@ -69,9 +75,15 @@ 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 = flip setEntryDP (SameLine 0) + 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 @@ -161,11 +173,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 +207,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 +279,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 +327,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 +348,18 @@ extendImportViaParent df parent child (L l it@ImportDecl{..}) #endif childRdr x :: LIE GhcPs = L ll' $ IEThingWith -#if MIN_VERSION_ghc(9,7,0) +#if MIN_VERSION_ghc(9,9,0) + (Nothing, [AddEpAnn AnnOpenP (EpaDelta (SameLine 1) []), AddEpAnn AnnCloseP noAnn]) +#elif MIN_VERSION_ghc(9,7,0) (Nothing, addAnns mempty [AddEpAnn AnnOpenP (EpaDelta (SameLine 1) []), AddEpAnn AnnCloseP def] emptyComments) #else (addAnns mempty [AddEpAnn AnnOpenP (EpaDelta (SameLine 1) []), 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 +367,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 +381,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 +413,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 +443,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 +480,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 @@ -482,9 +540,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 +574,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) @@ -541,13 +610,25 @@ deleteFromImport (T.pack -> symbol) (L l idecl) (L lieLoc lies) _ = do 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 +638,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..184ab93e79 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 @@ -16,12 +16,10 @@ import Development.IDE.GHC.ExactPrint (genAnchor1, modifySmallestDeclWithM) import Development.IDE.Plugin.Plugins.Diagnostic import GHC (EpAnn (..), - SrcSpanAnn' (SrcSpanAnn), SrcSpanAnnA, SrcSpanAnnN, emptyComments, noAnn) -import GHC.Types.SrcLoc (generatedSrcSpan) import Ide.Plugin.Error (PluginError (PluginInternalError)) import Ide.PluginUtils (makeDiffTextEdit) import Language.Haskell.GHC.ExactPrint (TransformT (..), @@ -29,17 +27,28 @@ import Language.Haskell.GHC.ExactPrint (TransformT (..), 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) #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 GHC (SrcSpanAnn' (SrcSpanAnn)) +import GHC.Types.SrcLoc (generatedSrcSpan) +#endif + +#if MIN_VERSION_ghc(9,9,0) +import GHC (EpUniToken (..)) +#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) @@ -67,7 +76,11 @@ plugin parsedModule Diagnostic {_message, _range} addArgToMatch :: T.Text -> GenLocated l (Match GhcPs body) -> (GenLocated l (Match GhcPs body), 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 (noLocA unqualName) +#else newPat = L (noAnnSrcSpanDP1 generatedSrcSpan) $ VarPat NoExtField (noLocA unqualName) +#endif in (L locMatch (Match xMatch ctxMatch (pats <> [newPat]) 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. @@ -139,7 +152,10 @@ hsTypeFromFunTypeAsList (args, res) = 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 = EpAnn genAnchor1 (AnnListItem []) emptyComments + newArg = (noAnn, noExtField, HsUnrestrictedArrow NoEpUniTok, 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) @@ -156,4 +172,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-retrie-plugin/src/Ide/Plugin/Retrie.hs b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs index 48d2886ff0..34b92a68cc 100644 --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -349,7 +349,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) -> @@ -744,7 +748,11 @@ toImportDecl AddImport {..} = GHC.ImportDecl {ideclSource = ideclSource', ..} #if MIN_VERSION_ghc(9,5,0) ideclImportList = Nothing ideclExt = GHCGHC.XImportDeclPass +#if MIN_VERSION_ghc(9,9,0) + { ideclAnn = GHCGHC.noAnn +#else { ideclAnn = GHCGHC.EpAnnNotUsed +#endif , ideclSourceText = ideclSourceSrc , ideclImplicit = ideclImplicit } diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index a756fd301e..4a62f1cec4 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -5,69 +5,74 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE PatternSynonyms #-} 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 ( guard, unless, forM ) -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.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 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 Language.LSP.Server -import Language.LSP.Protocol.Types +import Language.Haskell.GHC.ExactPrint (uniqueSrcSpanT) +import Language.Haskell.GHC.ExactPrint.Transform (TransformT (TransformT)) +import qualified Language.LSP.Protocol.Lens as J import Language.LSP.Protocol.Message -import qualified Language.LSP.Protocol.Lens as J -import Ide.Plugin.Error (PluginError(PluginInternalError)) +import Language.LSP.Protocol.Types +import Language.LSP.Server + +#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 = @@ -223,10 +228,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 @@ -245,7 +250,7 @@ adjustToRange uri ran (WorkspaceEdit mhult mlt x) = let minStart = case L.fold (L.premap (view J.range) L.minimum) eds of Nothing -> error "impossible" - Just v -> v + Just v -> v in adjustLine minStart <$> eds adjustATextEdits :: Traversable f => f (TextEdit |? AnnotatedTextEdit) -> f (TextEdit |? AnnotatedTextEdit) @@ -273,8 +278,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 = @@ -305,7 +315,7 @@ instance HasSplice AnnListItem HsExpr where #if MIN_VERSION_ghc(9,5,0) type SpliceOf HsExpr = HsSpliceCompat matchSplice _ (HsUntypedSplice _ spl) = Just (UntypedSplice spl) - matchSplice _ (HsTypedSplice _ spl) = Just (TypedSplice spl) + matchSplice _ (HsTypedSplice _ spl) = Just (TypedSplice spl) #else type SpliceOf HsExpr = HsSplice matchSplice _ (HsSpliceE _ spl) = Just spl @@ -394,7 +404,7 @@ manualCalcEdit clientCapabilities reportEditor ran ps hscEnv typechkd srcSpan _e (fst <$> expandSplice astP spl) ) Just <$> case eExpr of - Left x -> pure $ L _spn x + Left x -> pure $ L _spn x Right y -> unRenamedE dflags y _ -> pure Nothing let (warns, errs) = @@ -506,12 +516,12 @@ codeAction state plId (CodeActionParams _ _ docId ran _) = do | spanIsRelevant l -> case expr of #if MIN_VERSION_ghc(9,5,0) - HsTypedSplice{} -> Here (spLoc, Expr) + HsTypedSplice{} -> Here (spLoc, Expr) HsUntypedSplice{} -> Here (spLoc, Expr) #else - HsSpliceE {} -> Here (spLoc, Expr) + HsSpliceE {} -> Here (spLoc, Expr) #endif - _ -> Continue + _ -> Continue _ -> Stop ) `extQ` \case 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: