diff --git a/.github/workflows/bench.yml b/.github/workflows/bench.yml index 76ad770f4c..4bf2bedd27 100644 --- a/.github/workflows/bench.yml +++ b/.github/workflows/bench.yml @@ -47,8 +47,8 @@ jobs: fail-fast: false matrix: ghc: - - '8.10' - '9.2' + - '9.4' os: - ubuntu-latest @@ -115,7 +115,7 @@ jobs: strategy: fail-fast: false matrix: - ghc: ['8.10', '9.2'] + ghc: ['9.2', '9.4'] os: [ubuntu-latest] cabal: ['3.10'] example: ['cabal', 'lsp-types'] diff --git a/.github/workflows/caching.yml b/.github/workflows/caching.yml index e572f46da5..76bf204d82 100644 --- a/.github/workflows/caching.yml +++ b/.github/workflows/caching.yml @@ -102,7 +102,7 @@ jobs: # Fetching from github cache is faster than doing it from hackage # Sources does not change per ghc and ghc version son only doing it # for one matrix job (it is arbitrary) - - if: steps.compiled-deps.outputs.cache-hit != 'true' && runner.os == 'Linux' && matrix.ghc == '8.10' + - if: steps.compiled-deps.outputs.cache-hit != 'true' && runner.os == 'Linux' && matrix.ghc == '9.2' name: Download sources run: | cabal $cabalBuild --only-download --enable-benchmarks --enable-tests @@ -117,7 +117,7 @@ jobs: # We build ghcide with benchs and test enabled to include its dependencies in the cache # (including shake-bench) # Only for the same ghc and os used in the bench workflow, so we save cache space - - if: steps.compiled-deps.outputs.cache-hit != 'true' && runner.os == 'Linux' && matrix.ghc == '8.10' + - if: steps.compiled-deps.outputs.cache-hit != 'true' && runner.os == 'Linux' && matrix.ghc == '9.2' name: Build ghcide benchmark run: | cabal $cabalBuild ghcide --enable-benchmarks --enable-tests diff --git a/.github/workflows/supported-ghc-versions.json b/.github/workflows/supported-ghc-versions.json index 1d3ad1f540..0bccbd7e47 100644 --- a/.github/workflows/supported-ghc-versions.json +++ b/.github/workflows/supported-ghc-versions.json @@ -1 +1 @@ -[ "9.6", "9.4" , "9.2" , "9.0" , "8.10" ] +[ "9.6", "9.4" , "9.2" , "9.0" ] diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index fbe12277c1..ed63e13dfd 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -220,7 +220,7 @@ jobs: run: cabal test hls-explicit-record-fields-plugin --test-options="$TEST_OPTS" || cabal test hls-explicit-record-fields-plugin --test-options="$TEST_OPTS" ## version needs to be limited since the tests depend on cabal-fmt which only builds using specific ghc versions - - if: matrix.test && matrix.ghc == '8.10' + - if: matrix.test && matrix.ghc == '9.2' name: Test hls-cabal-fmt-plugin test suite run: cabal test hls-cabal-fmt-plugin --flag=isolateTests --test-options="$TEST_OPTS" || cabal test hls-cabal-fmt-plugin --flag=isolateTests --test-options="$TEST_OPTS" @@ -232,7 +232,7 @@ jobs: name: Test hls-retrie-plugin test suite run: cabal test hls-retrie-plugin --test-options="$TEST_OPTS" || cabal test hls-retrie-plugin --test-options="$TEST_OPTS" - - if: matrix.test && matrix.ghc != '8.10' && matrix.ghc != '9.0' + - if: matrix.test && matrix.ghc != '9.0' name: Test hls-overloaded-record-dot-plugin test suite run: cabal test hls-overloaded-record-dot-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-overloaded-record-dot-plugin --test-options="$TEST_OPTS" diff --git a/docs/contributing/plugin-tutorial.md b/docs/contributing/plugin-tutorial.md index 3939e7720c..63d0de1a58 100644 --- a/docs/contributing/plugin-tutorial.md +++ b/docs/contributing/plugin-tutorial.md @@ -34,7 +34,7 @@ And here is the gist of the algorithm: ## Setup -To get started, let’s fetch the HLS repo and build it. You need at least GHC 8.10 for this: +To get started, let’s fetch the HLS repo and build it. You need at least GHC 9.0 for this: ``` git clone --recursive http://github.com/haskell/haskell-language-server hls diff --git a/docs/support/ghc-version-support.md b/docs/support/ghc-version-support.md index 4fd42a3c23..a5cd049728 100644 --- a/docs/support/ghc-version-support.md +++ b/docs/support/ghc-version-support.md @@ -31,7 +31,7 @@ Support status (see the support policy below for more details): | 9.2.(1,2) | [1.7.0.0](https://github.com/haskell/haskell-language-server/releases/tag/1.7.0.0) | deprecated | | 9.0.2 | [latest](https://github.com/haskell/haskell-language-server/releases/latest) | full support | | 9.0.1 | [1.6.1.0](https://github.com/haskell/haskell-language-server/releases/tag/1.6.1.0) | deprecated | -| 8.10.7 | [latest](https://github.com/haskell/haskell-language-server/releases/latest) | full support | +| 8.10.7 | [2.2.0.0](https://github.com/haskell/haskell-language-server/releases/tag/2.2.0.0) | full support | | 8.10.6 | [1.6.1.0](https://github.com/haskell/haskell-language-server/releases/tag/1.6.1.0) | deprecated | | 8.10.5 | [1.5.1](https://github.com/haskell/haskell-language-server/releases/tag/1.5.1) | deprecated | | 8.10.(4,3,2) | [1.4.0](https://github.com/haskell/haskell-language-server/releases/tag/1.4.0) | deprecated | @@ -42,7 +42,6 @@ Support status (see the support policy below for more details): | 8.6.5 | [1.8.0.0](https://github.com/haskell/haskell-language-server/releases/tag/1.8.0.0) | deprecated | | 8.6.4 | [1.4.0](https://github.com/haskell/haskell-language-server/releases/tag/1.4.0) | deprecated | - GHC versions not in the list have never been supported by HLS. LTS stands for [Stackage](https://www.stackage.org/) Long Term Support. diff --git a/docs/troubleshooting.md b/docs/troubleshooting.md index 8947fd8eb7..8a60854ccb 100644 --- a/docs/troubleshooting.md +++ b/docs/troubleshooting.md @@ -189,7 +189,7 @@ stack install haskell-language-server You also can leverage `ghcup compile hls`: ```bash -ghcup compile hls -v 1.6.1.0 --ghc 8.10.7 +ghcup compile hls -v 1.9.0.0 --ghc 9.2.5 ``` ### Preprocessors diff --git a/ghcide-bench/ghcide-bench.cabal b/ghcide-bench/ghcide-bench.cabal index c036a8a465..7d0e0bfbe5 100644 --- a/ghcide-bench/ghcide-bench.cabal +++ b/ghcide-bench/ghcide-bench.cabal @@ -12,7 +12,7 @@ synopsis: An LSP client for running performance experiments on HLS description: An LSP client for running performance experiments on HLS 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 == 8.10.7 || == 9.0.2 || == 9.2.5 +tested-with: GHC == 9.0.2 || == 9.2.5 source-repository head type: git diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 9b7d502a4c..8f5ff94b36 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -13,7 +13,7 @@ description: A library for building Haskell IDE's on top of the GHC API. 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 == 8.10.7 || == 9.0.2 || == 9.2.5 +tested-with: GHC == 9.0.2 || == 9.2.5 extra-source-files: README.md CHANGELOG.md test/data/**/*.project test/data/**/*.cabal @@ -44,7 +44,6 @@ library default-language: Haskell2010 build-depends: aeson, - aeson-pretty, array, async, base == 4.*, @@ -104,7 +103,7 @@ library unliftio-core, ghc-boot-th, ghc-boot, - ghc >= 8.10, + ghc >= 9.0, ghc-check >=0.5.0.8, ghc-paths, cryptohash-sha1 >=0.11.100 && <0.12, @@ -228,6 +227,7 @@ library -Wall -Wincomplete-uni-patterns -Wno-unticked-promoted-constructors + -Wunused-packages -fno-ignore-asserts if flag(ghc-patched-unboxed-bytecode) @@ -254,9 +254,6 @@ library if impl(ghc >= 9.2) && flag(pedantic) ghc-options: -Wwarn=ambiguous-fields - if impl(ghc >= 9) - ghc-options: -Wunused-packages - if flag(ekg) build-depends: ekg-wai, @@ -397,10 +394,8 @@ test-suite ghcide-tests record-hasfield if impl(ghc < 9.3) build-depends: ghc-typelits-knownnat - if impl(ghc >= 9) - ghc-options: -Wunused-packages hs-source-dirs: test/cabal test/exe test/src - ghc-options: -threaded -Wall -Wno-name-shadowing -O0 -Wno-unticked-promoted-constructors + ghc-options: -threaded -Wall -Wno-name-shadowing -O0 -Wno-unticked-promoted-constructors -Wunused-packages main-is: Main.hs other-modules: Development.IDE.Test.Runfiles diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 6dfb9a7b01..1a14d2fe64 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -768,7 +768,6 @@ emptyHscEnv :: IORef NameCache -> FilePath -> IO HscEnv #endif emptyHscEnv nc libDir = do env <- runGhc (Just libDir) getSession - initDynLinker env pure $ setNameCache nc (hscSetFlags ((hsc_dflags env){useUnicode = True }) env) data TargetDetails = TargetDetails diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 2b35563975..b47c28742d 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -108,16 +108,9 @@ import System.IO.Extra (fixIO, newTempFileWithin) -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if !MIN_VERSION_ghc(9,0,1) -import HscTypes -import TcSplice -#endif - -#if MIN_VERSION_ghc(9,0,1) import GHC.Tc.Gen.Splice -#endif -#if MIN_VERSION_ghc(9,0,1) && !MIN_VERSION_ghc(9,2,1) +#if !MIN_VERSION_ghc(9,2,1) import GHC.Driver.Types #endif @@ -525,7 +518,6 @@ mkHiFileResultCompile se session' tcm simplified_guts = catchErrs $ do (guts, details) <- tidyProgram tidy_opts simplified_guts pure (details, guts) -#if MIN_VERSION_ghc(9,0,1) let !partial_iface = force $ mkPartialIface session #if MIN_VERSION_ghc(9,5,0) (cg_binds guts) @@ -540,11 +532,6 @@ mkHiFileResultCompile se session' tcm simplified_guts = catchErrs $ do #if MIN_VERSION_ghc(9,4,2) Nothing #endif - -#else - let !partial_iface = force (mkPartialIface session details simplified_guts) - final_iface' <- mkFullIface session partial_iface -#endif let final_iface = final_iface' {mi_globals = Nothing, mi_usages = filterUsages (mi_usages final_iface')} -- See Note [Clearing mi_globals after generating an iface] -- Write the core file now @@ -693,10 +680,8 @@ generateObjectCode session summary guts = do session' = hscSetFlags newFlags session #if MIN_VERSION_ghc(9,4,2) (outputFilename, _mStub, _foreign_files, _cinfos, _stgcinfos) <- hscGenHardCode session' guts -#elif MIN_VERSION_ghc(9,0,1) - (outputFilename, _mStub, _foreign_files, _cinfos) <- hscGenHardCode session' guts #else - (outputFilename, _mStub, _foreign_files) <- hscGenHardCode session' guts + (outputFilename, _mStub, _foreign_files, _cinfos) <- hscGenHardCode session' guts #endif (ms_location summary) fp @@ -839,7 +824,6 @@ generateHieAsts hscEnv tcm = -- don't export an interface which allows for additional information to be added to hie files. let fake_splice_binds = Util.listToBag (map (mkVarBind unitDataConId) (spliceExpressions $ tmrTopLevelSplices tcm)) real_binds = tcg_binds $ tmrTypechecked tcm -#if MIN_VERSION_ghc(9,0,1) ts = tmrTypechecked tcm :: TcGblEnv top_ev_binds = tcg_ev_binds ts :: Util.Bag EvBind insts = tcg_insts ts :: [ClsInst] @@ -851,19 +835,14 @@ generateHieAsts hscEnv tcm = Just <$> #endif GHC.enrichHie (fake_splice_binds `Util.unionBags` real_binds) (tmrRenamed tcm) top_ev_binds insts tcs -#else - Just <$> GHC.enrichHie (fake_splice_binds `Util.unionBags` real_binds) (tmrRenamed tcm) -#endif where dflags = hsc_dflags hscEnv -#if MIN_VERSION_ghc(9,0,0) run _ts = -- ts is only used in GHC 9.2 #if MIN_VERSION_ghc(9,2,0) && !MIN_VERSION_ghc(9,3,0) fmap (join . snd) . liftIO . initDs hscEnv _ts #else id #endif -#endif spliceExpressions :: Splices -> [LHsExpr GhcTc] spliceExpressions Splices{..} = @@ -1258,10 +1237,8 @@ parseHeader -> Util.StringBuffer -- ^ Haskell module source text (full Unicode is supported) #if MIN_VERSION_ghc(9,5,0) -> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located(HsModule GhcPs)) -#elif MIN_VERSION_ghc(9,0,1) - -> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located(HsModule)) #else - -> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located(HsModule GhcPs)) + -> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located(HsModule)) #endif parseHeader dflags filename contents = do let loc = mkRealSrcLoc (Util.mkFastString filename) 1 1 @@ -1774,4 +1751,4 @@ pathToModuleName = mkModuleName . map rep GHC numbers is identical, with the only preference being to use what is already there. (i.e. (`MIN_VERSION_GHC(9,2,0)` and `MIN_VERSION_GHC(9,1,0)` are functionally equivalent) --} \ No newline at end of file +-} diff --git a/ghcide/src/Development/IDE/GHC/CPP.hs b/ghcide/src/Development/IDE/GHC/CPP.hs index 87d25c7fa9..5bc7530aac 100644 --- a/ghcide/src/Development/IDE/GHC/CPP.hs +++ b/ghcide/src/Development/IDE/GHC/CPP.hs @@ -21,16 +21,9 @@ import GHC -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if MIN_VERSION_ghc (8,10,0) && !MIN_VERSION_ghc(9,0,0) -import qualified DriverPipeline as Pipeline -import ToolSettings -#endif - -#if MIN_VERSION_ghc(9,0,0) import GHC.Settings -#endif -#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,3,0) +#if !MIN_VERSION_ghc(9,3,0) import qualified GHC.Driver.Pipeline as Pipeline #endif diff --git a/ghcide/src/Development/IDE/GHC/Compat.hs b/ghcide/src/Development/IDE/GHC/Compat.hs index 3fade3a314..5e58e88975 100644 --- a/ghcide/src/Development/IDE/GHC/Compat.hs +++ b/ghcide/src/Development/IDE/GHC/Compat.hs @@ -31,10 +31,6 @@ module Development.IDE.GHC.Compat( pattern PFailedWithErrorMessages, isObjectLinkable, -#if !MIN_VERSION_ghc(9,0,1) - RefMap, -#endif - #if MIN_VERSION_ghc(9,2,0) #if !MIN_VERSION_ghc(9,3,0) extendModSummaryNoDeps, @@ -72,7 +68,6 @@ module Development.IDE.GHC.Compat( enrichHie, writeHieFile, readHieFile, - supportsHieFiles, setHieDir, dontWriteHieFiles, module Compat.HieTypes, @@ -170,39 +165,6 @@ import qualified Data.Set as S -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if !MIN_VERSION_ghc(9,0,0) -import Annotations (AnnTarget (ModuleTarget), - Annotation (..), - extendAnnEnvList) -import ByteCodeAsm (bcoFreeNames) -import ByteCodeGen (coreExprToBCOs) -import CoreLint (lintInteractiveExpr) -import CorePrep (corePrepExpr, - corePrepPgm) -import CoreSyn (CoreExpr, - Unfolding (..), - flattenBinds, - noUnfolding) -import CoreTidy (tidyExpr) -import Hooks (hscCompileCoreExprHook) -import Linker (linkExpr) -import qualified SimplCore as GHC -import UniqDFM -import UniqDSet -import UniqSet -import VarEnv (emptyInScopeSet, - emptyTidyEnv, mkRnEnv2) -import FastString -import qualified Avail -import DynFlags hiding (ExposePackage) -import HscTypes -import MkIface hiding (writeIfaceFile) - -import StringBuffer (hPutStringBuffer) -import qualified SysTools -#endif - -#if MIN_VERSION_ghc(9,0,0) import qualified GHC.Core.Opt.Pipeline as GHC import GHC.Core.Tidy (tidyExpr) import GHC.CoreToStg.Prep (corePrepPgm) @@ -224,16 +186,15 @@ import GHC.Types.Var.Env import GHC.Iface.Make (mkIfaceExports) import qualified GHC.SysTools.Tasks as SysTools import qualified GHC.Types.Avail as Avail -#endif -#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0) +#if !MIN_VERSION_ghc(9,2,0) import GHC.Utils.Error import GHC.CoreToByteCode (coreExprToBCOs) import GHC.Runtime.Linker (linkExpr) import GHC.Driver.Types #endif -#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,5,0) +#if !MIN_VERSION_ghc(9,5,0) import GHC.Core.Lint (lintInteractiveExpr) #endif @@ -400,14 +361,11 @@ reLocA = id getDependentMods :: ModIface -> [ModuleName] #if MIN_VERSION_ghc(9,3,0) getDependentMods = map (gwib_mod . snd) . S.toList . dep_direct_mods . mi_deps -#elif MIN_VERSION_ghc(9,0,0) -getDependentMods = map gwib_mod . dep_mods . mi_deps #else -getDependentMods = map fst . dep_mods . mi_deps +getDependentMods = map gwib_mod . dep_mods . mi_deps #endif simplifyExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr -#if MIN_VERSION_ghc(9,0,0) #if MIN_VERSION_ghc(9,5,0) simplifyExpr _ env = GHC.simplifyExpr (Development.IDE.GHC.Compat.Env.hsc_logger env) (ue_eps (Development.IDE.GHC.Compat.Env.hsc_unit_env env)) (initSimplifyExprOpts (hsc_dflags env) (hsc_IC env)) #else @@ -423,10 +381,6 @@ corePrepExpr _ env expr = do corePrepExpr _ = GHC.corePrepExpr #endif -#else -simplifyExpr df _ = GHC.simplifyExpr df -#endif - renderMessages :: PsMessages -> (Bag WarnMsg, Bag ErrMsg) renderMessages msgs = #if MIN_VERSION_ghc(9,3,0) @@ -451,9 +405,6 @@ pattern PFailedWithErrorMessages msgs #endif {-# COMPLETE POk, PFailedWithErrorMessages #-} -supportsHieFiles :: Bool -supportsHieFiles = True - hieExportNames :: HieFile -> [(SrcSpan, Name)] hieExportNames = nameListFromAvails . hie_exports @@ -483,10 +434,6 @@ upNameCache :: IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c upNameCache = updNameCache #endif -#if !MIN_VERSION_ghc(9,0,1) -type RefMap a = Map.Map Identifier [(Span, IdentifierDetails a)] -#endif - mkHieFile' :: ModSummary -> [Avail.AvailInfo] -> HieASTs Type @@ -554,7 +501,6 @@ isQualifiedImport _ = False -#if MIN_VERSION_ghc(9,0,0) getNodeIds :: HieAST a -> Map.Map Identifier (IdentifierDetails a) getNodeIds = Map.foldl' combineNodeIds Map.empty . getSourcedNodeInfo . sourcedNodeInfo @@ -579,35 +525,11 @@ combineNodeInfo' :: Ord a => NodeInfo a -> NodeInfo a -> NodeInfo a mergeSorted axs [] = axs mergeSorted [] bxs = bxs -#else - -getNodeIds :: HieAST a -> NodeIdentifiers a -getNodeIds = nodeIdentifiers . nodeInfo --- import qualified FastString as FS - --- nodeInfo' :: HieAST TypeIndex -> NodeInfo TypeIndex -nodeInfo' :: Ord a => HieAST a -> NodeInfo a -nodeInfo' = nodeInfo --- type Unit = UnitId --- moduleUnit :: Module -> Unit --- moduleUnit = moduleUnitId --- unhelpfulSpanFS :: FS.FastString -> FS.FastString --- unhelpfulSpanFS = id -#endif - sourceNodeInfo :: HieAST a -> Maybe (NodeInfo a) -#if MIN_VERSION_ghc(9,0,0) sourceNodeInfo = Map.lookup SourceInfo . getSourcedNodeInfo . sourcedNodeInfo -#else -sourceNodeInfo = Just . nodeInfo -#endif generatedNodeInfo :: HieAST a -> Maybe (NodeInfo a) -#if MIN_VERSION_ghc(9,0,0) generatedNodeInfo = Map.lookup GeneratedInfo . getSourcedNodeInfo . sourcedNodeInfo -#else -generatedNodeInfo = sourceNodeInfo -- before ghc 9.0, we don't distinguish the source -#endif data GhcVersion = GHC810 @@ -677,11 +599,7 @@ instance IsString FastStringCompat where #endif mkAstNode :: NodeInfo a -> Span -> [HieAST a] -> HieAST a -#if MIN_VERSION_ghc(9,0,0) mkAstNode n = Node (SourcedNodeInfo $ Map.singleton GeneratedInfo n) -#else -mkAstNode = Node -#endif combineRealSrcSpans :: RealSrcSpan -> RealSrcSpan -> RealSrcSpan #if MIN_VERSION_ghc(9,2,0) diff --git a/ghcide/src/Development/IDE/GHC/Compat/Core.hs b/ghcide/src/Development/IDE/GHC/Compat/Core.hs index b6067167e2..bee32cbfd4 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Core.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Core.hs @@ -40,9 +40,7 @@ module Development.IDE.GHC.Compat.Core ( readIface, loadSysInterface, importDecl, -#if MIN_VERSION_ghc(8,8,0) CommandLineOption, -#endif #if !MIN_VERSION_ghc(9,2,0) staticPlugins, #endif @@ -74,10 +72,6 @@ module Development.IDE.GHC.Compat.Core ( -- slightly unsafe setUnsafeGlobalDynFlags, -- * Linear Haskell -#if !MIN_VERSION_ghc(9,0,0) - Scaled, - unrestricted, -#endif scaledThing, -- * Interface Files IfaceExport, @@ -95,12 +89,7 @@ module Development.IDE.GHC.Compat.Core ( mkPartialIface, mkFullIface, checkOldIface, -#if MIN_VERSION_ghc(9,0,0) IsBootInterface(..), -#else - pattern IsBoot, - pattern NotBoot, -#endif -- * Fixity LexicalFixity(..), Fixity (..), @@ -142,7 +131,6 @@ module Development.IDE.GHC.Compat.Core ( Development.IDE.GHC.Compat.Core.splitForAllTyCoVars, #endif mkVisFunTys, - Development.IDE.GHC.Compat.Core.mkInfForAllTys, -- * Specs ImpDeclSpec(..), ImportSpec(..), @@ -276,7 +264,6 @@ module Development.IDE.GHC.Compat.Core ( Unlinked(..), Linkable(..), unload, - initDynLinker, -- * Hooks Hooks, runMetaHook, @@ -329,7 +316,6 @@ module Development.IDE.GHC.Compat.Core ( collectHsBindsBinders, #endif -- * Util Module re-exports -#if MIN_VERSION_ghc(9,0,0) module GHC.Builtin.Names, module GHC.Builtin.Types, module GHC.Builtin.Types.Prim, @@ -399,63 +385,12 @@ module Development.IDE.GHC.Compat.Core ( module GHC.Types.Unique.Supply, module GHC.Types.Var, module GHC.Unit.Module, -#else - module BasicTypes, - module Class, - module Coercion, - module Predicate, - module ConLike, - module CoreUtils, - module DataCon, - module DsExpr, - module DsMonad, - module ErrUtils, - module FamInst, - module FamInstEnv, - module HeaderInfo, - module Id, - module InstEnv, - module IfaceSyn, - module Module, - module Name, - module NameCache, - module NameEnv, - module NameSet, - module PatSyn, - module PprTyThing, - module PrelInfo, - module PrelNames, - module RdrName, - module RnSplice, - module RnNames, - module TcEnv, - module TcEvidence, - module TcType, - module TcRnTypes, - module TcRnDriver, - module TcRnMonad, - module TyCon, - module TysPrim, - module TysWiredIn, - module Type, - module Unify, - module UniqFM, - module UniqSupply, - module Var, -#endif -- * Syntax re-exports -#if MIN_VERSION_ghc(9,0,0) module GHC.Hs, module GHC.Hs.Binds, module GHC.Parser, module GHC.Parser.Header, module GHC.Parser.Lexer, -#else - module GHC.Hs, - module ExtractDocs, - module Parser, - module Lexer, -#endif #if MIN_VERSION_ghc(9,3,0) CompileReason(..), hsc_type_env_vars, @@ -509,94 +444,6 @@ import GHC.Hs.Binds -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if !MIN_VERSION_ghc(9,0,0) -import qualified Avail -import BasicTypes hiding (Version) -import Class -import CmdLineParser (Warn (..)) -import ConLike -import CoreUtils -import DataCon hiding (dataConExTyCoVars) -import qualified DataCon -import DriverPhases -import DriverPipeline -import DsExpr -import DsMonad hiding (foldrM) -import DynFlags hiding (ExposePackage) -import qualified DynFlags -import ErrUtils hiding (logInfo, mkWarnMsg) -import ExtractDocs -import FamInst -import FamInstEnv -import Finder hiding (mkHomeModLocation) -import GHC.Hs hiding (HsLet, LetStmt) -import qualified GHCi -import GhcMonad -import HeaderInfo hiding (getImports) -import Hooks -import HscMain as GHC -import HscTypes -import Id -import IfaceSyn -import InstEnv -import Lexer -import qualified Linker -import LoadIface -import MkIface as GHC -import Module hiding (ModLocation (..), UnitId, - addBootSuffixLocnOut, - moduleUnitId) -import qualified Module -import Name hiding (varName) -import NameCache -import NameEnv -import NameSet -import Packages -import Panic hiding (try) -import qualified PlainPanic as Plain -import Parser -import PatSyn -import RnFixity -import Plugins -import PprTyThing hiding (pprFamInst) -import PrelInfo -import PrelNames hiding (Unique, printName) -import RdrName hiding (GRE, gre_name, gre_imp, gre_lcl, gre_par) -import qualified RdrName -import RnNames -import RnSplice -import qualified SrcLoc -import TcEnv -import TcEvidence hiding ((<.>)) -import TcIface -import TcRnDriver -import TcRnMonad hiding (Applicative (..), IORef, - MonadFix (..), MonadIO (..), - allM, anyM, concatMapM, foldrM, - mapMaybeM, (<$>)) -import TcRnTypes -import TcType -import TidyPgm as GHC -import qualified TyCoRep -import TyCon -import Type -import TysPrim -import TysWiredIn -import Unify -import UniqFM hiding (UniqFM) -import qualified UniqFM -import UniqSupply -import Var (Var (varName), setTyVarUnique, - setVarUnique, varType) - -import Coercion (coercionKind) -import Predicate -import SrcLoc (Located, SrcLoc (UnhelpfulLoc), - SrcSpan (UnhelpfulSpan)) -import qualified Finder as GHC -#endif - -#if MIN_VERSION_ghc(9,0,0) import GHC.Builtin.Names hiding (Unique, printName) import GHC.Builtin.Types import GHC.Builtin.Types.Prim @@ -608,14 +455,13 @@ import GHC.Core.DataCon hiding (dataConExTyCoVars) import qualified GHC.Core.DataCon as DataCon import GHC.Core.FamInstEnv hiding (pprFamInst) import GHC.Core.InstEnv -import GHC.Types.Unique.FM hiding (UniqFM) -import qualified GHC.Types.Unique.FM as UniqFM +import GHC.Types.Unique.FM import GHC.Core.PatSyn import GHC.Core.Predicate import GHC.Core.TyCo.Ppr import qualified GHC.Core.TyCo.Rep as TyCoRep import GHC.Core.TyCon -import GHC.Core.Type hiding (mkInfForAllTys) +import GHC.Core.Type import GHC.Core.Unify import GHC.Core.Utils import GHC.Driver.CmdLine (Warn (..)) @@ -676,9 +522,8 @@ import GHC.Unit.State (ModuleOrigin (..)) import GHC.Utils.Error (Severity (..), emptyMessages) import GHC.Utils.Panic hiding (try) import qualified GHC.Utils.Panic.Plain as Plain -#endif -#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0) +#if !MIN_VERSION_ghc(9,2,0) import GHC.Core.Ppr.TyThing hiding (pprFamInst) import GHC.Core.TyCo.Rep (scaledThing) import GHC.Driver.Finder hiding (mkHomeModLocation) @@ -761,12 +606,6 @@ mkHomeModLocation df mn f = pure $ GHC.mkHomeModLocation (GHC.initFinderOpts df) mkHomeModLocation = GHC.mkHomeModLocation #endif - -#if !MIN_VERSION_ghc(9,0,0) -type BufSpan = () -type BufPos = () -#endif - #if MIN_VERSION_ghc(9,3,0) pattern RealSrcSpan :: SrcLoc.RealSrcSpan -> Maybe BufSpan -> SrcLoc.SrcSpan #else @@ -777,11 +616,8 @@ pattern RealSrcSpan :: SrcLoc.RealSrcSpan -> Maybe BufSpan -> SrcLoc.SrcSpan pattern RealSrcSpan x y <- SrcLoc.RealSrcSpan x ((\case Strict.Nothing -> Nothing; Strict.Just a -> Just a) -> y) where RealSrcSpan x y = SrcLoc.RealSrcSpan x (case y of Nothing -> Strict.Nothing; Just a -> Strict.Just a) -#elif MIN_VERSION_ghc(9,0,0) -pattern RealSrcSpan x y = SrcLoc.RealSrcSpan x y #else -pattern RealSrcSpan x y <- ((,Nothing) -> (SrcLoc.RealSrcSpan x, y)) where - RealSrcSpan x _ = SrcLoc.RealSrcSpan x +pattern RealSrcSpan x y = SrcLoc.RealSrcSpan x y #endif {-# COMPLETE RealSrcSpan, UnhelpfulSpan #-} @@ -790,12 +626,7 @@ pattern RealSrcLoc :: SrcLoc.RealSrcLoc -> Strict.Maybe BufPos-> SrcLoc.SrcLoc #else pattern RealSrcLoc :: SrcLoc.RealSrcLoc -> Maybe BufPos-> SrcLoc.SrcLoc #endif -#if MIN_VERSION_ghc(9,0,0) pattern RealSrcLoc x y = SrcLoc.RealSrcLoc x y -#else -pattern RealSrcLoc x y <- ((,Nothing) -> (SrcLoc.RealSrcLoc x, y)) where - RealSrcLoc x _ = SrcLoc.RealSrcLoc x -#endif {-# COMPLETE RealSrcLoc, UnhelpfulLoc #-} @@ -839,7 +670,6 @@ pattern ExposePackage s a mr = DynFlags.ExposePackage s a mr pattern FunTy :: Type -> Type -> Type pattern FunTy arg res <- TyCoRep.FunTy {ft_arg = arg, ft_res = res} -#if MIN_VERSION_ghc(8,10,0) -- type HasSrcSpan x a = (GenLocated SrcSpan a ~ x) -- type HasSrcSpan x = () :: Constraint @@ -863,35 +693,11 @@ pattern L l a <- GHC.L (getLoc -> l) a {-# COMPLETE L #-} #endif -#else -type HasSrcSpan = SrcLoc.HasSrcSpan -getLoc :: SrcLoc.HasSrcSpan a => a -> SrcLoc.SrcSpan -getLoc = SrcLoc.getLoc -#endif - -- | Add the @-boot@ suffix to all output file paths associated with the -- module, not including the input file itself addBootSuffixLocnOut :: GHC.ModLocation -> GHC.ModLocation addBootSuffixLocnOut = Module.addBootSuffixLocnOut -#if !MIN_VERSION_ghc(9,0,0) --- Linear Haskell -type Scaled a = a -scaledThing :: Scaled a -> a -scaledThing = id - -unrestricted :: a -> Scaled a -unrestricted = id -#endif - -mkInfForAllTys :: [TyVar] -> Type -> Type -mkInfForAllTys = -#if MIN_VERSION_ghc(9,0,0) - TcType.mkInfForAllTys -#else - mkInvForAllTys -#endif - #if !MIN_VERSION_ghc(9,2,0) splitForAllTyCoVars :: Type -> ([TyCoVar], Type) splitForAllTyCoVars = @@ -915,14 +721,6 @@ tcSplitForAllTyVarBinder_maybe = tcSplitForAllTy_maybe #endif - -#if !MIN_VERSION_ghc(9,0,0) -pattern NotBoot, IsBoot :: IsBootInterface -pattern NotBoot = False -pattern IsBoot = True -#endif - -#if MIN_VERSION_ghc(9,0,0) -- 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,2,0) @@ -932,36 +730,17 @@ pattern ConPatIn con args <- ConPat EpAnnNotUsed (L _ (SrcLoc.noLoc -> con)) arg #else pattern ConPatIn con args = ConPat NoExtField con args #endif -#endif conPatDetails :: Pat p -> Maybe (HsConPatDetails p) -#if MIN_VERSION_ghc(9,0,0) conPatDetails (ConPat _ _ args) = Just args conPatDetails _ = Nothing -#else -conPatDetails (ConPatIn _ args) = Just args -conPatDetails _ = Nothing -#endif mapConPatDetail :: (HsConPatDetails p -> Maybe (HsConPatDetails p)) -> Pat p -> Maybe (Pat p) -#if MIN_VERSION_ghc(9,0,0) mapConPatDetail f pat@(ConPat _ _ args) = (\args' -> pat { pat_args = args'}) <$> f args mapConPatDetail _ _ = Nothing -#else -mapConPatDetail f (ConPatIn ss args) = ConPatIn ss <$> f args -mapConPatDetail _ _ = Nothing -#endif -initDynLinker, initObjLinker :: HscEnv -> IO () -initDynLinker = -#if !MIN_VERSION_ghc(9,0,0) - Linker.initDynLinker -#else - -- It errors out in GHC 9.0 and doesn't exist in 9.2 - const $ return () -#endif - +initObjLinker :: HscEnv -> IO () initObjLinker env = #if !MIN_VERSION_ghc(9,2,0) GHCi.initObjLinker env @@ -1143,12 +922,6 @@ pattern NamedFieldPuns :: Extension pattern NamedFieldPuns = RecordPuns #endif -#if MIN_VERSION_ghc(9,0,0) -type UniqFM = UniqFM.UniqFM -#else -type UniqFM k = UniqFM.UniqFM -#endif - #if MIN_VERSION_ghc(9,5,0) mkVisFunTys = mkScaledFunctionTys mapLoc :: (a -> b) -> SrcLoc.GenLocated l a -> SrcLoc.GenLocated l b diff --git a/ghcide/src/Development/IDE/GHC/Compat/Env.hs b/ghcide/src/Development/IDE/GHC/Compat/Env.hs index 1cd9350945..4c5e14c757 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Env.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Env.hs @@ -57,20 +57,11 @@ import GHC (setInteractiveDynFlags) -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if !MIN_VERSION_ghc(9,0,0) -import DynFlags -import Hooks -import HscTypes as Env -import Module -#endif - -#if MIN_VERSION_ghc(9,0,0) import GHC.Driver.Hooks (Hooks) import GHC.Driver.Session hiding (mkHomeModule) import GHC.Unit.Types (Module, UnitId) -#endif -#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0) +#if !MIN_VERSION_ghc(9,2,0) import qualified Data.Set as Set import qualified GHC.Driver.Session as DynFlags import GHC.Driver.Types (HscEnv, @@ -78,12 +69,11 @@ import GHC.Driver.Types (HscEnv, hsc_EPS, setInteractivePrintName) import qualified GHC.Driver.Types as Env -import GHC.Driver.Ways hiding (hostFullWays) -import qualified GHC.Driver.Ways as Ways +import GHC.Driver.Ways import GHC.Unit.Types (Unit, mkModule) #endif -#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,5,0) +#if !MIN_VERSION_ghc(9,5,0) import GHC.Unit.Module.Name #endif @@ -95,8 +85,7 @@ import Data.IORef import GHC.Driver.Backend as Backend import qualified GHC.Driver.Env as Env import qualified GHC.Driver.Session as Session -import GHC.Platform.Ways hiding (hostFullWays) -import qualified GHC.Platform.Ways as Ways +import GHC.Platform.Ways import GHC.Runtime.Context import GHC.Unit.Env (UnitEnv) import GHC.Unit.Home as Home @@ -130,10 +119,8 @@ type TmpFs = () setHomeUnitId_ :: UnitId -> DynFlags -> DynFlags #if MIN_VERSION_ghc(9,2,0) setHomeUnitId_ uid df = df { Session.homeUnitId_ = uid } -#elif MIN_VERSION_ghc(9,0,0) -setHomeUnitId_ uid df = df { homeUnitId = uid } #else -setHomeUnitId_ uid df = df { thisInstalledUnitId = toInstalledUnitId uid } +setHomeUnitId_ uid df = df { homeUnitId = uid } #endif hscSetFlags :: DynFlags -> HscEnv -> HscEnv @@ -202,10 +189,8 @@ homeUnitId_ :: DynFlags -> UnitId homeUnitId_ = #if MIN_VERSION_ghc(9,2,0) Session.homeUnitId_ -#elif MIN_VERSION_ghc(9,0,0) - homeUnitId #else - thisPackage + homeUnitId #endif safeImportsOn :: DynFlags -> Bool @@ -216,20 +201,16 @@ safeImportsOn = DynFlags.safeImportsOn #endif -#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0) +#if !MIN_VERSION_ghc(9,2,0) type HomeUnit = Unit -#elif !MIN_VERSION_ghc(9,0,0) -type HomeUnit = UnitId #endif hscHomeUnit :: HscEnv -> HomeUnit hscHomeUnit = #if MIN_VERSION_ghc(9,2,0) Env.hsc_home_unit -#elif MIN_VERSION_ghc(9,0,0) - homeUnit . Env.hsc_dflags #else - homeUnitId_ . hsc_dflags + homeUnit . Env.hsc_dflags #endif mkHomeModule :: HomeUnit -> ModuleName -> Module @@ -273,28 +254,16 @@ setInterpreterLinkerOptions df = df { -- Ways helpers -- ------------------------------------------------------- -#if !MIN_VERSION_ghc(9,2,0) && MIN_VERSION_ghc(9,0,0) +#if !MIN_VERSION_ghc(9,2,0) type Ways = Set.Set Way -#elif !MIN_VERSION_ghc(9,0,0) -type Ways = [Way] -#endif - -hostFullWays :: Ways -hostFullWays = -#if MIN_VERSION_ghc(9,0,0) - Ways.hostFullWays -#else - interpWays #endif setWays :: Ways -> DynFlags -> DynFlags setWays newWays flags = #if MIN_VERSION_ghc(9,2,0) flags { Session.targetWays_ = newWays} -#elif MIN_VERSION_ghc(9,0,0) - flags {ways = newWays} #else - updateWays $ flags {ways = newWays} + flags {ways = newWays} #endif -- ------------------------------------------------------- diff --git a/ghcide/src/Development/IDE/GHC/Compat/Iface.hs b/ghcide/src/Development/IDE/GHC/Compat/Iface.hs index c9531469bc..f2c5bc4222 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Iface.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Iface.hs @@ -12,13 +12,7 @@ import GHC -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if !MIN_VERSION_ghc(9,0,0) -import Finder (FindResult) -import qualified Finder -import qualified MkIface -#endif - -#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0) +#if !MIN_VERSION_ghc(9,2,0) import qualified GHC.Driver.Finder as Finder import GHC.Driver.Types (FindResult) import qualified GHC.Iface.Load as Iface @@ -38,10 +32,8 @@ writeIfaceFile :: HscEnv -> FilePath -> ModIface -> IO () writeIfaceFile env fp iface = Iface.writeIface (hsc_logger env) (targetProfile $ hsc_dflags env) fp iface #elif MIN_VERSION_ghc(9,2,0) writeIfaceFile env fp iface = Iface.writeIface (hsc_logger env) (hsc_dflags env) fp iface -#elif MIN_VERSION_ghc(9,0,0) -writeIfaceFile env = Iface.writeIface (hsc_dflags env) #else -writeIfaceFile env = MkIface.writeIfaceFile (hsc_dflags env) +writeIfaceFile env = Iface.writeIface (hsc_dflags env) #endif cannotFindModule :: HscEnv -> ModuleName -> FindResult -> SDoc diff --git a/ghcide/src/Development/IDE/GHC/Compat/Logger.hs b/ghcide/src/Development/IDE/GHC/Compat/Logger.hs index 6c520dc2a7..1b553c5cae 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Logger.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Logger.hs @@ -15,16 +15,9 @@ import Development.IDE.GHC.Compat.Outputable -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if !MIN_VERSION_ghc(9,0,0) -import DynFlags -import Outputable (queryQual) -#endif - -#if MIN_VERSION_ghc(9,0,0) import GHC.Utils.Outputable -#endif -#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0) +#if !MIN_VERSION_ghc(9,2,0) import GHC.Driver.Session as DynFlags #endif @@ -66,17 +59,10 @@ logActionCompat logAction logFlags (MCDiagnostic severity wr) loc = logAction lo logActionCompat logAction logFlags _cls loc = logAction logFlags Nothing Nothing loc alwaysQualify #else -#if MIN_VERSION_ghc(9,0,0) type LogActionCompat = DynFlags -> WarnReason -> Severity -> SrcSpan -> PrintUnqualified -> SDoc -> IO () -- alwaysQualify seems to still do the right thing here, according to the "unqualified warnings" test. logActionCompat :: LogActionCompat -> LogAction logActionCompat logAction dynFlags wr severity loc = logAction dynFlags wr severity loc alwaysQualify -#else -type LogActionCompat = DynFlags -> WarnReason -> Severity -> SrcSpan -> PrintUnqualified -> SDoc -> IO () - -logActionCompat :: LogActionCompat -> LogAction -logActionCompat logAction dynFlags wr severity loc style = logAction dynFlags wr severity loc (queryQual style) -#endif #endif diff --git a/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs b/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs index c3d8fef64c..25ae8f961a 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs @@ -51,50 +51,35 @@ module Development.IDE.GHC.Compat.Outputable ( -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if !MIN_VERSION_ghc(9,0,0) -import Development.IDE.GHC.Compat.Core (GlobalRdrEnv) -import DynFlags -import ErrUtils hiding (mkWarnMsg) -import qualified ErrUtils as Err -import HscTypes -import Outputable as Out hiding - (defaultUserStyle) -import qualified Outputable as Out -import SrcLoc -#endif - -#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0) +#if !MIN_VERSION_ghc(9,2,0) import GHC.Driver.Session -import GHC.Driver.Types as HscTypes -import GHC.Types.Name.Reader (GlobalRdrEnv) +import GHC.Driver.Types as HscTypes +import GHC.Types.Name.Reader (GlobalRdrEnv) import GHC.Types.SrcLoc -import GHC.Utils.Error as Err hiding (mkWarnMsg) -import qualified GHC.Utils.Error as Err -import GHC.Utils.Outputable as Out hiding - (defaultUserStyle) -import qualified GHC.Utils.Outputable as Out +import GHC.Utils.Error as Err hiding (mkWarnMsg) +import qualified GHC.Utils.Error as Err +import GHC.Utils.Outputable as Out +import qualified GHC.Utils.Outputable as Out #endif #if MIN_VERSION_ghc(9,2,0) import GHC.Driver.Env import GHC.Driver.Ppr import GHC.Driver.Session -import qualified GHC.Types.Error as Error +import qualified GHC.Types.Error as Error import GHC.Types.Name.Ppr import GHC.Types.Name.Reader import GHC.Types.SourceError import GHC.Types.SrcLoc import GHC.Unit.State -import GHC.Utils.Error hiding (mkWarnMsg) -import GHC.Utils.Outputable as Out hiding - (defaultUserStyle) -import qualified GHC.Utils.Outputable as Out +import GHC.Utils.Error hiding (mkWarnMsg) +import GHC.Utils.Outputable as Out import GHC.Utils.Panic #endif #if MIN_VERSION_ghc(9,2,0) && !MIN_VERSION_ghc(9,3,0) import GHC.Parser.Errors -import qualified GHC.Parser.Errors.Ppr as Ppr +import qualified GHC.Parser.Errors.Ppr as Ppr #endif #if MIN_VERSION_ghc(9,3,0) @@ -104,7 +89,7 @@ import GHC.Parser.Errors.Types #endif #if MIN_VERSION_ghc(9,5,0) -import GHC.Driver.Errors.Types (GhcMessage) +import GHC.Driver.Errors.Types (GhcMessage) #endif #if MIN_VERSION_ghc(9,5,0) @@ -144,7 +129,7 @@ printSDocQualifiedUnsafe unqual doc = showSDocForUser unsafeGlobalDynFlags unqual doc #endif -#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0) +#if !MIN_VERSION_ghc(9,2,0) oldRenderWithStyle dflags sdoc sty = Out.renderWithStyle (initSDocContext dflags sty) sdoc oldMkUserStyle _ = Out.mkUserStyle oldMkErrStyle _ = Out.mkErrStyle @@ -152,18 +137,6 @@ oldMkErrStyle _ = Out.mkErrStyle oldFormatErrDoc :: DynFlags -> Err.ErrDoc -> Out.SDoc oldFormatErrDoc dflags = Err.formatErrDoc dummySDocContext where dummySDocContext = initSDocContext dflags Out.defaultUserStyle -#elif !MIN_VERSION_ghc(9,0,0) -oldRenderWithStyle :: DynFlags -> Out.SDoc -> Out.PprStyle -> String -oldRenderWithStyle = Out.renderWithStyle - -oldMkUserStyle :: DynFlags -> Out.PrintUnqualified -> Out.Depth -> Out.PprStyle -oldMkUserStyle = Out.mkUserStyle - -oldMkErrStyle :: DynFlags -> Out.PrintUnqualified -> Out.PprStyle -oldMkErrStyle = Out.mkErrStyle - -oldFormatErrDoc :: DynFlags -> Err.ErrDoc -> Out.SDoc -oldFormatErrDoc = Err.formatErrDoc #endif #if !MIN_VERSION_ghc(9,3,0) @@ -265,12 +238,5 @@ mkWarnMsg _ _ = #endif #endif -defaultUserStyle :: PprStyle -#if MIN_VERSION_ghc(9,0,0) -defaultUserStyle = Out.defaultUserStyle -#else -defaultUserStyle = Out.defaultUserStyle unsafeGlobalDynFlags -#endif - textDoc :: String -> SDoc textDoc = text diff --git a/ghcide/src/Development/IDE/GHC/Compat/Parser.hs b/ghcide/src/Development/IDE/GHC/Compat/Parser.hs index cb3cece8e1..e1effb1a6e 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Parser.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Parser.hs @@ -6,7 +6,7 @@ module Development.IDE.GHC.Compat.Parser ( initParserOpts, initParserState, -#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0) +#if !MIN_VERSION_ghc(9,2,0) -- in GHC == 9.2 the type doesn't exist -- In GHC == 9.0 it is a data-type -- and GHC < 9.0 it is type-def @@ -16,9 +16,7 @@ module Development.IDE.GHC.Compat.Parser ( #else ApiAnns, #endif -#if MIN_VERSION_ghc(9,0,0) PsSpan(..), -#endif #if MIN_VERSION_ghc(9,2,0) pattern HsParsedModule, type GHC.HsParsedModule, @@ -50,20 +48,11 @@ import Development.IDE.GHC.Compat.Util -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if !MIN_VERSION_ghc(9,0,0) -import qualified ApiAnnotation as Anno -import qualified HscTypes as GHC -import Lexer -import qualified SrcLoc -#endif - -#if MIN_VERSION_ghc(9,0,0) import qualified GHC.Parser.Annotation as Anno import qualified GHC.Parser.Lexer as Lexer import GHC.Types.SrcLoc (PsSpan (..)) -#endif -#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0) +#if !MIN_VERSION_ghc(9,2,0) import qualified GHC.Driver.Types as GHC #endif @@ -90,9 +79,7 @@ import qualified GHC.Driver.Config.Parser as Config #endif -#if !MIN_VERSION_ghc(9,0,0) -type ParserOpts = DynFlags -#elif !MIN_VERSION_ghc(9,2,0) +#if !MIN_VERSION_ghc(9,2,0) type ParserOpts = Lexer.ParserFlags #endif @@ -100,20 +87,16 @@ initParserOpts :: DynFlags -> ParserOpts initParserOpts = #if MIN_VERSION_ghc(9,2,0) Config.initParserOpts -#elif MIN_VERSION_ghc(9,0,0) - Lexer.mkParserFlags #else - id + Lexer.mkParserFlags #endif initParserState :: ParserOpts -> StringBuffer -> RealSrcLoc -> PState initParserState = #if MIN_VERSION_ghc(9,2,0) Lexer.initParserState -#elif MIN_VERSION_ghc(9,0,0) - Lexer.mkPStatePure #else - Lexer.mkPState + Lexer.mkPStatePure #endif #if MIN_VERSION_ghc(9,2,0) @@ -164,7 +147,6 @@ mkApiAnns :: PState -> ApiAnns mkApiAnns = const () #else mkApiAnns pst = -#if MIN_VERSION_ghc(9,0,1) -- Copied from GHC.Driver.Main Anno.ApiAnns { apiAnnItems = Map.fromListWith (++) $ annotations pst, @@ -172,11 +154,6 @@ mkApiAnns pst = apiAnnComments = Map.fromList (annotations_comments pst), apiAnnRogueComments = comment_q pst } -#else - (Map.fromListWith (++) $ annotations pst, - Map.fromList ((SrcLoc.noSrcSpan,comment_q pst) - :annotations_comments pst)) -#endif #endif #if !MIN_VERSION_ghc(9,2,0) diff --git a/ghcide/src/Development/IDE/GHC/Compat/Plugins.hs b/ghcide/src/Development/IDE/GHC/Compat/Plugins.hs index 9f5ea50ab7..0289b9d7fb 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Plugins.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Plugins.hs @@ -25,21 +25,14 @@ import Development.IDE.GHC.Compat.Parser as Parser -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if !MIN_VERSION_ghc(9,0,0) -import qualified DynamicLoading as Loader -import Plugins -#endif - -#if MIN_VERSION_ghc(9,0,0) import GHC.Driver.Plugins (Plugin (..), PluginWithArgs (..), StaticPlugin (..), defaultPlugin, withPlugins) import qualified GHC.Runtime.Loader as Loader -#endif -#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,3,0) +#if !MIN_VERSION_ghc(9,3,0) import Development.IDE.GHC.Compat.Outputable as Out #endif diff --git a/ghcide/src/Development/IDE/GHC/Compat/Units.hs b/ghcide/src/Development/IDE/GHC/Compat/Units.hs index 4c40f7f0cf..cd890d855e 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Units.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Units.hs @@ -26,7 +26,7 @@ module Development.IDE.GHC.Compat.Units ( unitExposedModules, unitDepends, unitHaddockInterfaces, - unitInfoId, + mkUnit, unitPackageNameString, unitPackageVersion, -- * UnitId helpers @@ -34,9 +34,6 @@ module Development.IDE.GHC.Compat.Units ( Unit, unitString, stringToUnit, -#if !MIN_VERSION_ghc(9,0,0) - pattern RealUnit, -#endif definiteUnitId, defUnitId, installedModule, @@ -54,7 +51,6 @@ module Development.IDE.GHC.Compat.Units ( ) where import Data.Either -import Data.Version import Development.IDE.GHC.Compat.Core import Development.IDE.GHC.Compat.Env import Development.IDE.GHC.Compat.Outputable @@ -62,42 +58,27 @@ import Prelude hiding (mod) -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if !MIN_VERSION_ghc(9,0,0) -import qualified DynFlags -import FastString -import qualified Finder as GHC -import HscTypes -import Module hiding (moduleUnitId) -import qualified Module -import Packages (InstalledPackageInfo (haddockInterfaces, packageName), - LookupResult, - PackageConfig, - PackageConfigMap, - PackageState, - getPackageConfigMap, - lookupPackage') -import qualified Packages -#endif - -#if MIN_VERSION_ghc(9,0,0) import GHC.Types.Unique.Set import qualified GHC.Unit.Info as UnitInfo import GHC.Unit.State (LookupResult, UnitInfo, - UnitState (unitInfoMap)) + UnitState (unitInfoMap), + lookupUnit', mkUnit, + unitDepends, + unitExposedModules, + unitPackageNameString, + unitPackageVersion) import qualified GHC.Unit.State as State -import GHC.Unit.Types hiding (moduleUnit, - toUnitId) +import GHC.Unit.Types import qualified GHC.Unit.Types as Unit -#endif -#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0) +#if !MIN_VERSION_ghc(9,2,0) import Data.Map (Map) import qualified GHC.Driver.Finder as GHC import qualified GHC.Driver.Session as DynFlags import GHC.Driver.Types #endif -#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,3,0) +#if !MIN_VERSION_ghc(9,3,0) import GHC.Data.FastString #endif @@ -125,37 +106,18 @@ import GHC.Unit.Home.ModInfo #endif -#if MIN_VERSION_ghc(9,0,0) type PreloadUnitClosure = UniqSet UnitId #if MIN_VERSION_ghc(9,2,0) type UnitInfoMap = State.UnitInfoMap #else type UnitInfoMap = Map UnitId UnitInfo #endif -#else -type UnitState = PackageState -type UnitInfo = PackageConfig -type UnitInfoMap = PackageConfigMap -type PreloadUnitClosure = () -type Unit = UnitId -#endif - - -#if !MIN_VERSION_ghc(9,0,0) -unitString :: Unit -> String -unitString = Module.unitIdString - -stringToUnit :: String -> Unit -stringToUnit = Module.stringToUnitId -#endif unitState :: HscEnv -> UnitState #if MIN_VERSION_ghc(9,2,0) unitState = ue_units . hsc_unit_env -#elif MIN_VERSION_ghc(9,0,0) -unitState = DynFlags.unitState . hsc_dflags #else -unitState = DynFlags.pkgState . hsc_dflags +unitState = DynFlags.unitState . hsc_dflags #endif #if MIN_VERSION_ghc(9,3,0) @@ -206,13 +168,9 @@ initUnits unitDflags env = do oldInitUnits :: DynFlags -> IO DynFlags #if MIN_VERSION_ghc(9,2,0) oldInitUnits = pure -#elif MIN_VERSION_ghc(9,0,0) -oldInitUnits dflags = do - newFlags <- State.initUnits dflags - pure newFlags #else oldInitUnits dflags = do - newFlags <- fmap fst $ Packages.initPackages dflags + newFlags <- State.initUnits dflags pure newFlags #endif @@ -220,27 +178,17 @@ explicitUnits :: UnitState -> [Unit] explicitUnits ue = #if MIN_VERSION_ghc(9,3,0) map fst $ State.explicitUnits ue -#elif MIN_VERSION_ghc(9,0,0) - State.explicitUnits ue #else - Packages.explicitPackages ue + State.explicitUnits ue #endif listVisibleModuleNames :: HscEnv -> [ModuleName] listVisibleModuleNames env = -#if MIN_VERSION_ghc(9,0,0) State.listVisibleModuleNames $ unitState env -#else - Packages.listVisibleModuleNames $ hsc_dflags env -#endif getUnitName :: HscEnv -> UnitId -> Maybe PackageName getUnitName env i = -#if MIN_VERSION_ghc(9,0,0) State.unitPackageName <$> State.lookupUnitId (unitState env) i -#else - packageName <$> Packages.lookupPackage (hsc_dflags env) (definiteUnitId (defUnitId i)) -#endif lookupModuleWithSuggestions :: HscEnv @@ -252,92 +200,28 @@ lookupModuleWithSuggestions #endif -> LookupResult lookupModuleWithSuggestions env modname mpkg = -#if MIN_VERSION_ghc(9,0,0) State.lookupModuleWithSuggestions (unitState env) modname mpkg -#else - Packages.lookupModuleWithSuggestions (hsc_dflags env) modname mpkg -#endif getUnitInfoMap :: HscEnv -> UnitInfoMap getUnitInfoMap = #if MIN_VERSION_ghc(9,2,0) unitInfoMap . ue_units . hsc_unit_env -#elif MIN_VERSION_ghc(9,0,0) - unitInfoMap . unitState #else - Packages.getPackageConfigMap . hsc_dflags + unitInfoMap . unitState #endif lookupUnit :: HscEnv -> Unit -> Maybe UnitInfo -#if MIN_VERSION_ghc(9,0,0) lookupUnit env pid = State.lookupUnit (unitState env) pid -#else -lookupUnit env pid = Packages.lookupPackage (hsc_dflags env) pid -#endif - -lookupUnit' :: Bool -> UnitInfoMap -> PreloadUnitClosure -> Unit -> Maybe UnitInfo -#if MIN_VERSION_ghc(9,0,0) -lookupUnit' = State.lookupUnit' -#else -lookupUnit' b pcm _ u = Packages.lookupPackage' b pcm u -#endif preloadClosureUs :: HscEnv -> PreloadUnitClosure -#if MIN_VERSION_ghc(9,2,0) -preloadClosureUs = State.preloadClosure . unitState -#elif MIN_VERSION_ghc(9,0,0) preloadClosureUs = State.preloadClosure . unitState -#else -preloadClosureUs = const () -#endif - -unitExposedModules :: UnitInfo -> [(ModuleName, Maybe Module)] -unitExposedModules ue = -#if MIN_VERSION_ghc(9,0,0) - UnitInfo.unitExposedModules ue -#else - Packages.exposedModules ue -#endif - -unitDepends :: UnitInfo -> [UnitId] -#if MIN_VERSION_ghc(9,0,0) -unitDepends = State.unitDepends -#else -unitDepends = fmap (Module.DefiniteUnitId. defUnitId') . Packages.depends -#endif - -unitPackageNameString :: UnitInfo -> String -unitPackageNameString = -#if MIN_VERSION_ghc(9,0,0) - UnitInfo.unitPackageNameString -#else - Packages.packageNameString -#endif - -unitPackageVersion :: UnitInfo -> Version -unitPackageVersion = -#if MIN_VERSION_ghc(9,0,0) - UnitInfo.unitPackageVersion -#else - Packages.packageVersion -#endif - -unitInfoId :: UnitInfo -> Unit -unitInfoId = -#if MIN_VERSION_ghc(9,0,0) - UnitInfo.mkUnit -#else - Packages.packageConfigId -#endif unitHaddockInterfaces :: UnitInfo -> [FilePath] unitHaddockInterfaces = #if MIN_VERSION_ghc(9,2,0) fmap ST.unpack . UnitInfo.unitHaddockInterfaces -#elif MIN_VERSION_ghc(9,0,0) - UnitInfo.unitHaddockInterfaces #else - haddockInterfaces + UnitInfo.unitHaddockInterfaces #endif -- ------------------------------------------------------------------ @@ -356,51 +240,16 @@ defUnitId = Definite installedModule :: unit -> ModuleName -> GenModule unit installedModule = Module -#elif MIN_VERSION_ghc(9,0,0) +#else definiteUnitId = RealUnit defUnitId = Definite installedModule = Module -#else -pattern RealUnit :: Module.DefUnitId -> UnitId -pattern RealUnit x = Module.DefiniteUnitId x - -definiteUnitId :: Module.DefUnitId -> UnitId -definiteUnitId = Module.DefiniteUnitId - -defUnitId :: UnitId -> Module.DefUnitId -defUnitId = Module.DefUnitId . Module.toInstalledUnitId - -defUnitId' :: Module.InstalledUnitId -> Module.DefUnitId -defUnitId' = Module.DefUnitId - -installedModule :: UnitId -> ModuleName -> Module.InstalledModule -installedModule uid modname = Module.InstalledModule (Module.toInstalledUnitId uid) modname -#endif - -toUnitId :: Unit -> UnitId -toUnitId = -#if MIN_VERSION_ghc(9,0,0) - Unit.toUnitId -#else - id #endif moduleUnitId :: Module -> UnitId moduleUnitId = -#if MIN_VERSION_ghc(9,0,0) Unit.toUnitId . Unit.moduleUnit -#else - Module.moduleUnitId -#endif - -moduleUnit :: Module -> Unit -moduleUnit = -#if MIN_VERSION_ghc(9,0,0) - Unit.moduleUnit -#else - Module.moduleUnitId -#endif filterInplaceUnits :: [UnitId] -> [PackageFlag] -> ([UnitId], [PackageFlag]) filterInplaceUnits us packageFlags = @@ -408,15 +257,9 @@ filterInplaceUnits us packageFlags = where isInplace :: PackageFlag -> Either UnitId PackageFlag isInplace p@(ExposePackage _ (UnitIdArg u) _) = -#if MIN_VERSION_ghc(9,0,0) if toUnitId u `elem` us then Left $ toUnitId u else Right p -#else - if u `elem` us - then Left u - else Right p -#endif isInplace p = Right p showSDocForUser' :: HscEnv -> PrintUnqualified -> SDoc -> String diff --git a/ghcide/src/Development/IDE/GHC/Compat/Util.hs b/ghcide/src/Development/IDE/GHC/Compat/Util.hs index 4ad42cee8a..bdfaab9e77 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Util.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Util.hs @@ -71,24 +71,6 @@ module Development.IDE.GHC.Compat.Util ( -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if !MIN_VERSION_ghc(9,0,0) -import Bag -import BooleanFormula -import EnumSet -import qualified Exception -import FastString -import Fingerprint -import Maybes -import Outputable (pprHsString) -import Pair -import Panic hiding (try) -import StringBuffer -import UniqDFM -import Unique -import Util -#endif - -#if MIN_VERSION_ghc(9,0,0) import Control.Exception.Safe (MonadCatch, catch, try) import GHC.Data.Bag import GHC.Data.BooleanFormula @@ -103,9 +85,8 @@ import GHC.Types.Unique.DFM import GHC.Utils.Fingerprint import GHC.Utils.Outputable (pprHsString) import GHC.Utils.Panic hiding (try) -#endif -#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,3,0) +#if !MIN_VERSION_ghc(9,3,0) import GHC.Utils.Misc #endif @@ -113,14 +94,3 @@ import GHC.Utils.Misc import GHC.Data.Bool #endif - -#if !MIN_VERSION_ghc(9,0,0) -type MonadCatch = Exception.ExceptionMonad - --- We are using Safe here, which is not equivalent, but probably what we want. -catch :: (Exception.ExceptionMonad m, Exception e) => m a -> (e -> m a) -> m a -catch = Exception.gcatch - -try :: (Exception.ExceptionMonad m, Exception e) => m a -> m (Either e a) -try = Exception.gtry -#endif diff --git a/ghcide/src/Development/IDE/GHC/CoreFile.hs b/ghcide/src/Development/IDE/GHC/CoreFile.hs index 1702addf52..f877a486f2 100644 --- a/ghcide/src/Development/IDE/GHC/CoreFile.hs +++ b/ghcide/src/Development/IDE/GHC/CoreFile.hs @@ -27,19 +27,6 @@ import Prelude hiding (mod) -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if !MIN_VERSION_ghc(9,0,0) -import Binary -import BinFingerprint (fingerprintBinMem) -import BinIface -import CoreSyn -import HscTypes -import IfaceEnv -import MkId -import TcIface -import ToIface -#endif - -#if MIN_VERSION_ghc(9,0,0) import GHC.Core import GHC.CoreToIface import GHC.Iface.Binary @@ -48,9 +35,8 @@ import GHC.Iface.Recomp.Binary (fingerprintBinMem) import GHC.IfaceToCore import GHC.Types.Id.Make import GHC.Utils.Binary -#endif -#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0) +#if !MIN_VERSION_ghc(9,2,0) import GHC.Driver.Types #endif diff --git a/ghcide/src/Development/IDE/GHC/Orphans.hs b/ghcide/src/Development/IDE/GHC/Orphans.hs index 0440e644f4..57f8b0bd00 100644 --- a/ghcide/src/Development/IDE/GHC/Orphans.hs +++ b/ghcide/src/Development/IDE/GHC/Orphans.hs @@ -20,24 +20,13 @@ import Data.Text (unpack) -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if !MIN_VERSION_ghc(9,0,0) -import Bag -import ByteCodeTypes -import GhcPlugins hiding (UniqFM) -import qualified StringBuffer as SB -import Unique (getKey) -#endif - -#if MIN_VERSION_ghc(9,0,0) import GHC.ByteCode.Types import GHC.Data.Bag import GHC.Data.FastString import qualified GHC.Data.StringBuffer as SB import GHC.Types.SrcLoc -#endif - -#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,3,0) +#if !MIN_VERSION_ghc(9,3,0) import GHC (ModuleGraph) import GHC.Types.Unique (getKey) #endif @@ -78,22 +67,9 @@ instance Show PackageFlag where show = unpack . printOutputable instance Show InteractiveImport where show = unpack . printOutputable instance Show PackageName where show = unpack . printOutputable -#if !MIN_VERSION_ghc(9,0,1) -instance Show ComponentId where show = unpack . printOutputable -instance Show SourcePackageId where show = unpack . printOutputable - -instance Show GhcPlugins.InstalledUnitId where - show = installedUnitIdString - -instance NFData GhcPlugins.InstalledUnitId where rnf = rwhnf . installedUnitIdFS - -instance Hashable GhcPlugins.InstalledUnitId where - hashWithSalt salt = hashWithSalt salt . installedUnitIdString -#else instance Show UnitId where show = unpack . printOutputable deriving instance Ord SrcSpan deriving instance Ord UnhelpfulSpanReason -#endif instance NFData SB.StringBuffer where rnf = rwhnf @@ -213,10 +189,8 @@ instance NFData (ImportDecl GhcPs) where #if MIN_VERSION_ghc(9,5,0) instance (NFData (HsModule a)) where -#elif MIN_VERSION_ghc(9,0,1) -instance (NFData HsModule) where #else -instance (NFData (HsModule a)) where +instance (NFData HsModule) where #endif rnf = rwhnf diff --git a/ghcide/src/Development/IDE/GHC/Util.hs b/ghcide/src/Development/IDE/GHC/Util.hs index c3cbf4c572..82fe9f29e6 100644 --- a/ghcide/src/Development/IDE/GHC/Util.hs +++ b/ghcide/src/Development/IDE/GHC/Util.hs @@ -240,11 +240,7 @@ dupHandleTo filepath h other_side -- | This is copied unmodified from GHC since it is not exposed. -- Note the beautiful inline comment! -#if MIN_VERSION_ghc(9,0,0) dupHandle_ :: (RawIO dev, IODevice dev, BufferedIO dev, Typeable dev) => dev -#else -dupHandle_ :: (IODevice dev, BufferedIO dev, Typeable dev) => dev -#endif -> FilePath -> Maybe (MVar Handle__) -> Handle__ diff --git a/ghcide/src/Development/IDE/Import/FindImports.hs b/ghcide/src/Development/IDE/Import/FindImports.hs index 506487415e..358666a0e9 100644 --- a/ghcide/src/Development/IDE/Import/FindImports.hs +++ b/ghcide/src/Development/IDE/Import/FindImports.hs @@ -183,11 +183,7 @@ locateModule env comp_info exts targetFor modName mbPkgName isSource = do toModLocation uid file = liftIO $ do loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file) -#if MIN_VERSION_ghc(9,0,0) let genMod = mkModule (RealUnit $ Definite uid) (unLoc modName) -- TODO support backpack holes -#else - let genMod = mkModule uid (unLoc modName) -#endif return $ Right $ FileImport $ ArtifactsLocation file (Just loc) (not isSource) (Just genMod) lookupLocal uid dirs = do diff --git a/ghcide/src/Development/IDE/LSP/Outline.hs b/ghcide/src/Development/IDE/LSP/Outline.hs index 7859e0e95e..03260b1b51 100644 --- a/ghcide/src/Development/IDE/LSP/Outline.hs +++ b/ghcide/src/Development/IDE/LSP/Outline.hs @@ -280,11 +280,6 @@ defDocumentSymbol l = DocumentSymbol { .. } where getConNames' :: ConDecl GhcPs -> [Located (IdP GhcPs)] getConNames' ConDeclH98 {con_name = name} = [name] getConNames' ConDeclGADT {con_names = names} = names -#if !MIN_VERSION_ghc(8,10,0) -getConNames' (XConDecl NoExt) = [] -#elif !MIN_VERSION_ghc(9,0,0) -getConNames' (XConDecl x) = noExtCon x -#endif #else hsConDeclsBinders :: LConDecl GhcPs -> ([LIdP GhcPs], [LFieldOcc GhcPs]) diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Types.hs b/ghcide/src/Development/IDE/Plugin/Completions/Types.hs index 8902475330..f2b3be0712 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Types.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Types.hs @@ -27,15 +27,7 @@ import qualified Language.LSP.Protocol.Types as J -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if !MIN_VERSION_ghc(9,0,0) -import qualified OccName as Occ -#endif - -#if MIN_VERSION_ghc(9,0,0) import qualified GHC.Types.Name.Occurrence as Occ -#endif - - -- | Produce completions info for a file type instance RuleResult LocalCompletions = CachedCompletions diff --git a/ghcide/src/Development/IDE/Spans/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs index 70a36693f8..5f1c68b83b 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -167,12 +167,8 @@ documentHighlight -> MaybeT m [DocumentHighlight] documentHighlight hf rf pos = pure highlights where -#if MIN_VERSION_ghc(9,0,1) -- We don't want to show document highlights for evidence variables, which are supposed to be invisible notEvidence = not . any isEvidenceContext . identInfo -#else - notEvidence = const True -#endif ns = concat $ pointCommand hf pos (rights . M.keys . M.filter notEvidence . getNodeIds) highlights = do n <- ns @@ -245,12 +241,8 @@ atPoint IdeOptions{} (HAR _ hf _ _ (kind :: HieKind hietype)) (DKMap dm km) env -- Check for evidence bindings isInternal :: (Identifier, IdentifierDetails a) -> Bool - isInternal (Right _, _dets) = -- dets is only used in GHC >= 9.0.1 -#if MIN_VERSION_ghc(9,0,1) - any isEvidenceContext $ identInfo _dets -#else - False -#endif + isInternal (Right _, dets) = + any isEvidenceContext $ identInfo dets isInternal (Left _, _) = False filteredNames :: [(Identifier, IdentifierDetails hietype)] @@ -338,11 +330,7 @@ typeLocationsAtPoint withHieDb lookupModule _ideOptions pos (HAR _ ast _ _ hieKi HAppTy a (HieArgs xs) -> getTypes' (a : map snd xs) HTyConApp tc (HieArgs xs) -> ifaceTyConName tc : getTypes' (map snd xs) HForAllTy _ a -> getTypes' [a] -#if MIN_VERSION_ghc(9,0,1) HFunTy a b c -> getTypes' [a,b,c] -#else - HFunTy a b -> getTypes' [a,b] -#endif HQualTy a b -> getTypes' [a,b] HCastTy a -> getTypes' [a] _ -> [] diff --git a/ghcide/src/Development/IDE/Spans/Documentation.hs b/ghcide/src/Development/IDE/Spans/Documentation.hs index 72dbd52acb..3a9b70eda2 100644 --- a/ghcide/src/Development/IDE/Spans/Documentation.hs +++ b/ghcide/src/Development/IDE/Spans/Documentation.hs @@ -172,13 +172,7 @@ getDocumentation sources targetName = fromMaybe [] $ do sortedNameSpans :: [Located RdrName] -> [RealSrcSpan] sortedNameSpans ls = nubSort (mapMaybe (realSpan . getLoc) ls) isBetween target before after = before <= target && target <= after -#if MIN_VERSION_ghc(9,0,0) ann = apiAnnComments . pm_annotations -#else - ann = fmap filterReal . snd . pm_annotations - filterReal :: [Located a] -> [RealLocated a] - filterReal = mapMaybe (\(L l v) -> (`L`v) <$> realSpan l) -#endif annotationFileName :: ParsedModule -> Maybe FastString annotationFileName = fmap srcSpanFile . listToMaybe . map getRealSrcSpan . fold . ann diff --git a/ghcide/src/Development/IDE/Spans/Pragmas.hs b/ghcide/src/Development/IDE/Spans/Pragmas.hs index d0ec2c1576..c832b30449 100644 --- a/ghcide/src/Development/IDE/Spans/Pragmas.hs +++ b/ghcide/src/Development/IDE/Spans/Pragmas.hs @@ -303,11 +303,7 @@ updateParserState token range prevParserState lexUntilNextLineIncl :: P (Located Token) lexUntilNextLineIncl = do PState{ last_loc } <- getPState -#if MIN_VERSION_ghc(9,0,0) let PsSpan{ psRealSpan = lastRealSrcSpan } = last_loc -#else - let lastRealSrcSpan = last_loc -#endif let prevEndLine = lastRealSrcSpan & realSrcSpanEnd & srcLocLine locatedToken@(L srcSpan _token) <- lexer False pure if | RealSrcLoc currEndRealSrcLoc _ <- srcSpan & srcSpanEnd diff --git a/ghcide/src/Development/IDE/Types/HscEnvEq.hs b/ghcide/src/Development/IDE/Types/HscEnvEq.hs index bb8653ac77..502c265077 100644 --- a/ghcide/src/Development/IDE/Types/HscEnvEq.hs +++ b/ghcide/src/Development/IDE/Types/HscEnvEq.hs @@ -91,7 +91,7 @@ newHscEnvEqWithImportPaths envImportPaths hscEnv deps = do -- When module is re-exported from another package, -- the origin module is represented by value in Just Just otherPkgMod -> otherPkgMod - Nothing -> mkModule (unitInfoId pkg) modName + Nothing -> mkModule (mkUnit pkg) modName ] doOne m = do diff --git a/ghcide/src/Development/IDE/Types/Location.hs b/ghcide/src/Development/IDE/Types/Location.hs index 6939f2b27d..7623c1cf25 100644 --- a/ghcide/src/Development/IDE/Types/Location.hs +++ b/ghcide/src/Development/IDE/Types/Location.hs @@ -38,15 +38,8 @@ import Text.ParserCombinators.ReadP as ReadP -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if !MIN_VERSION_ghc(9,0,0) -import FastString -import SrcLoc as GHC -#endif - -#if MIN_VERSION_ghc(9,0,0) import GHC.Data.FastString import GHC.Types.SrcLoc as GHC -#endif toNormalizedFilePath' :: FilePath -> LSP.NormalizedFilePath -- We want to keep empty paths instead of normalising them to "." diff --git a/ghcide/test/exe/CompletionTests.hs b/ghcide/test/exe/CompletionTests.hs index 2e2be028ea..00ebc4724e 100644 --- a/ghcide/test/exe/CompletionTests.hs +++ b/ghcide/test/exe/CompletionTests.hs @@ -261,7 +261,7 @@ nonLocalCompletionTests = [] ] where - brokenForWinGhc = knownBrokenFor (BrokenSpecific Windows [GHC810, GHC90, GHC92, GHC94, GHC96]) "Windows has strange things in scope for some reason" + brokenForWinGhc = knownBrokenFor (BrokenSpecific Windows [GHC90, GHC92, GHC94, GHC96]) "Windows has strange things in scope for some reason" otherCompletionTests :: [TestTree] otherCompletionTests = [ diff --git a/ghcide/test/exe/FindDefinitionAndHoverTests.hs b/ghcide/test/exe/FindDefinitionAndHoverTests.hs index b0fe95891b..c44b1d56e0 100644 --- a/ghcide/test/exe/FindDefinitionAndHoverTests.hs +++ b/ghcide/test/exe/FindDefinitionAndHoverTests.hs @@ -205,10 +205,7 @@ tests = let , test yes yes lclL33 lcb "listcomp lookup" , test yes yes mclL36 mcl "top-level fn 1st clause" , test yes yes mclL37 mcl "top-level fn 2nd clause #1030" - , if ghcVersion >= GHC810 then - test yes yes spaceL37 space "top-level fn on space #1002" - else - test yes broken spaceL37 space "top-level fn on space #1002" + , test yes yes spaceL37 space "top-level fn on space #1002" , test no yes docL41 doc "documentation #1129" , test no yes eitL40 kindE "kind of Either #1017" , test no yes intL40 kindI "kind of Int #1017" diff --git a/ghcide/test/exe/HighlightTests.hs b/ghcide/test/exe/HighlightTests.hs index f630d52e39..34b5662810 100644 --- a/ghcide/test/exe/HighlightTests.hs +++ b/ghcide/test/exe/HighlightTests.hs @@ -50,19 +50,13 @@ tests = testGroup "highlight" _ <- waitForDiagnostics highlights <- getHighlights doc (Position 4 15) liftIO $ highlights @?= - -- Span is just the .. on 8.10, but Rec{..} before - [ if ghcVersion >= GHC810 - then DocumentHighlight (R 4 8 4 10) (Just DocumentHighlightKind_Write) - else DocumentHighlight (R 4 4 4 11) (Just DocumentHighlightKind_Write) + [ DocumentHighlight (R 4 8 4 10) (Just DocumentHighlightKind_Write) , DocumentHighlight (R 4 14 4 20) (Just DocumentHighlightKind_Read) ] highlights <- getHighlights doc (Position 3 17) liftIO $ highlights @?= [ DocumentHighlight (R 3 17 3 23) (Just DocumentHighlightKind_Write) - -- Span is just the .. on 8.10, but Rec{..} before - , if ghcVersion >= GHC810 - then DocumentHighlight (R 4 8 4 10) (Just DocumentHighlightKind_Read) - else DocumentHighlight (R 4 4 4 11) (Just DocumentHighlightKind_Read) + , DocumentHighlight (R 4 8 4 10) (Just DocumentHighlightKind_Read) ] ] where diff --git a/ghcide/test/exe/PluginParsedResultTests.hs b/ghcide/test/exe/PluginParsedResultTests.hs index a382f4461d..f33a998df9 100644 --- a/ghcide/test/exe/PluginParsedResultTests.hs +++ b/ghcide/test/exe/PluginParsedResultTests.hs @@ -10,7 +10,6 @@ import TestUtils tests :: TestTree tests = - ignoreInWindowsForGHC810 $ ignoreForGHC92Plus "No need for this plugin anymore!" $ testSessionWithExtraFiles "plugin-recorddot" "parsedResultAction plugin" $ \dir -> do _ <- openDoc (dir "RecordDot.hs") "haskell" diff --git a/ghcide/test/exe/PluginSimpleTests.hs b/ghcide/test/exe/PluginSimpleTests.hs index 0de051083b..aedc111ff4 100644 --- a/ghcide/test/exe/PluginSimpleTests.hs +++ b/ghcide/test/exe/PluginSimpleTests.hs @@ -15,7 +15,6 @@ import TestUtils tests :: TestTree tests = - ignoreInWindowsForGHC810 $ -- Build profile: -w ghc-9.4.2 -O1 -- In order, the following will be built (use -v for more details): -- - ghc-typelits-natnormalise-0.7.7 (lib) (requires build) diff --git a/ghcide/test/exe/TestUtils.hs b/ghcide/test/exe/TestUtils.hs index da94ce8c45..bb90f93505 100644 --- a/ghcide/test/exe/TestUtils.hs +++ b/ghcide/test/exe/TestUtils.hs @@ -166,10 +166,6 @@ xfail = flip expectFailBecause ignoreInWindowsBecause :: String -> TestTree -> TestTree ignoreInWindowsBecause = ignoreFor (BrokenForOS Windows) -ignoreInWindowsForGHC810 :: TestTree -> TestTree -ignoreInWindowsForGHC810 = - ignoreFor (BrokenSpecific Windows [GHC810]) "tests are unreliable in windows for ghc 8.10" - ignoreForGHC92Plus :: String -> TestTree -> TestTree ignoreForGHC92Plus = ignoreFor (BrokenForGHC [GHC92, GHC94, GHC96]) diff --git a/ghcide/test/ghcide-test-utils.cabal b/ghcide/test/ghcide-test-utils.cabal index 4afef2ba73..b55e6e6ca0 100644 --- a/ghcide/test/ghcide-test-utils.cabal +++ b/ghcide/test/ghcide-test-utils.cabal @@ -14,7 +14,7 @@ description: Test utils for ghcide 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 == 8.10.7 || == 9.0.2 || == 9.2.3 || == 9.2.4 +tested-with: GHC == 9.0.2 || == 9.2.3 || == 9.2.4 source-repository head type: git diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 61977c2843..277dac429d 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 == 8.10.7 || == 9.0.2 || ==9.2.5 +tested-with: GHC == 9.0.2 || ==9.2.5 extra-source-files: README.md ChangeLog.md diff --git a/hie-compat/hie-compat.cabal b/hie-compat/hie-compat.cabal index d93ac71c0f..8f3c69216e 100644 --- a/hie-compat/hie-compat.cabal +++ b/hie-compat/hie-compat.cabal @@ -21,23 +21,12 @@ source-repository head type: git location: https://github.com/haskell/haskell-language-server.git -flag ghc-lib - description: build against ghc-lib instead of the ghc package - default: False - manual: True - library default-language: Haskell2010 build-depends: base < 4.19, array, bytestring, containers, directory, filepath, transformers - if flag(ghc-lib) && impl(ghc < 9) - build-depends: ghc-lib < 9.0 - else - build-depends: ghc >= 8.10, ghc-boot - if (impl(ghc >= 9.0) && impl(ghc < 9.1)) - ghc-options: -Wall -Wno-name-shadowing - else - ghc-options: -Wall -Wno-name-shadowing + build-depends: ghc >= 8.10, ghc-boot + ghc-options: -Wall -Wno-name-shadowing exposed-modules: Compat.HieAst @@ -46,9 +35,7 @@ library Compat.HieDebug Compat.HieUtils - if (impl(ghc > 8.9) && impl(ghc < 8.11)) - hs-source-dirs: src-ghc810 src-reexport - if (impl(ghc >= 9.0) && impl(ghc < 9.1) || flag(ghc-lib)) + if (impl(ghc >= 9.0) && impl(ghc < 9.1)) hs-source-dirs: src-ghc90 src-reexport-ghc9 if (impl(ghc >= 9.2) && impl(ghc < 9.3)) hs-source-dirs: src-ghc92 src-reexport-ghc9 diff --git a/hie-compat/src-ghc810/Compat/HieAst.hs b/hie-compat/src-ghc810/Compat/HieAst.hs deleted file mode 100644 index 3d2eba2feb..0000000000 --- a/hie-compat/src-ghc810/Compat/HieAst.hs +++ /dev/null @@ -1,1896 +0,0 @@ -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -{- -Forked from GHC v8.10.1 to work around the readFile side effect in mkHiefile - -Main functions for .hie file generation --} -{- HLINT ignore -} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE DeriveDataTypeable #-} -module Compat.HieAst ( enrichHie ) where - -import GhcPrelude - -import Avail ( Avails ) -import Bag ( Bag, bagToList ) -import BasicTypes -import BooleanFormula -import Class ( FunDep ) -import CoreUtils ( exprType ) -import ConLike ( conLikeName ) -import Desugar ( deSugarExpr ) -import FieldLabel -import GHC.Hs -import HscTypes -import Module ( ModuleName ) -import MonadUtils ( concatMapM, liftIO ) -import Name ( Name, nameSrcSpan ) -import NameEnv ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv ) -import SrcLoc -import TcHsSyn ( hsLitType, hsPatType ) -import Type ( mkVisFunTys, Type ) -import TysWiredIn ( mkListTy, mkSumTy ) -import Var ( Id, Var, setVarName, varName, varType ) -import Panic - -import HieTypes -import HieUtils - -import qualified Data.Map as M -import qualified Data.Set as S -import Data.Data ( Data, Typeable ) -import Data.List ( foldl1' ) -import Data.Maybe ( listToMaybe ) -import Control.Monad.Trans.Reader -import Control.Monad.Trans.Class ( lift ) - -{- Note [Updating HieAst for changes in the GHC AST] - -When updating the code in this file for changes in the GHC AST, you -need to pay attention to the following things: - -1) Symbols (Names/Vars/Modules) in the following categories: - - a) Symbols that appear in the source file that directly correspond to - something the user typed - b) Symbols that don't appear in the source, but should be in some sense - "visible" to a user, particularly via IDE tooling or the like. This - includes things like the names introduced by RecordWildcards (We record - all the names introduced by a (..) in HIE files), and will include implicit - parameters and evidence variables after one of my pending MRs lands. - -2) Subtrees that may contain such symbols, or correspond to a SrcSpan in - the file. This includes all `Located` things - -For 1), you need to call `toHie` for one of the following instances - -instance ToHie (Context (Located Name)) where ... -instance ToHie (Context (Located Var)) where ... -instance ToHie (IEContext (Located ModuleName)) where ... - -`Context` is a data type that looks like: - -data Context a = C ContextInfo a -- Used for names and bindings - -`ContextInfo` is defined in `HieTypes`, and looks like - -data ContextInfo - = Use -- ^ regular variable - | MatchBind - | IEThing IEType -- ^ import/export - | TyDecl - -- | Value binding - | ValBind - BindType -- ^ whether or not the binding is in an instance - Scope -- ^ scope over which the value is bound - (Maybe Span) -- ^ span of entire binding - ... - -It is used to annotate symbols in the .hie files with some extra information on -the context in which they occur and should be fairly self explanatory. You need -to select one that looks appropriate for the symbol usage. In very rare cases, -you might need to extend this sum type if none of the cases seem appropriate. - -So, given a `Located Name` that is just being "used", and not defined at a -particular location, you would do the following: - - toHie $ C Use located_name - -If you select one that corresponds to a binding site, you will need to -provide a `Scope` and a `Span` for your binding. Both of these are basically -`SrcSpans`. - -The `SrcSpan` in the `Scope` is supposed to span over the part of the source -where the symbol can be legally allowed to occur. For more details on how to -calculate this, see Note [Capturing Scopes and other non local information] -in HieAst. - -The binding `Span` is supposed to be the span of the entire binding for -the name. - -For a function definition `foo`: - -foo x = x + y - where y = x^2 - -The binding `Span` is the span of the entire function definition from `foo x` -to `x^2`. For a class definition, this is the span of the entire class, and -so on. If this isn't well defined for your bit of syntax (like a variable -bound by a lambda), then you can just supply a `Nothing` - -There is a test that checks that all symbols in the resulting HIE file -occur inside their stated `Scope`. This can be turned on by passing the --fvalidate-ide-info flag to ghc along with -fwrite-ide-info to generate the -.hie file. - -You may also want to provide a test in testsuite/test/hiefile that includes -a file containing your new construction, and tests that the calculated scope -is valid (by using -fvalidate-ide-info) - -For subtrees in the AST that may contain symbols, the procedure is fairly -straightforward. If you are extending the GHC AST, you will need to provide a -`ToHie` instance for any new types you may have introduced in the AST. - -Here are is an extract from the `ToHie` instance for (LHsExpr (GhcPass p)): - - toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of - HsVar _ (L _ var) -> - [ toHie $ C Use (L mspan var) - -- Patch up var location since typechecker removes it - ] - HsConLikeOut _ con -> - [ toHie $ C Use $ L mspan $ conLikeName con - ] - ... - HsApp _ a b -> - [ toHie a - , toHie b - ] - -If your subtree is `Located` or has a `SrcSpan` available, the output list -should contain a HieAst `Node` corresponding to the subtree. You can use -either `makeNode` or `getTypeNode` for this purpose, depending on whether it -makes sense to assign a `Type` to the subtree. After this, you just need -to concatenate the result of calling `toHie` on all subexpressions and -appropriately annotated symbols contained in the subtree. - -The code above from the ToHie instance of `LhsExpr (GhcPass p)` is supposed -to work for both the renamed and typechecked source. `getTypeNode` is from -the `HasType` class defined in this file, and it has different instances -for `GhcTc` and `GhcRn` that allow it to access the type of the expression -when given a typechecked AST: - -class Data a => HasType a where - getTypeNode :: a -> HieM [HieAST Type] -instance HasType (LHsExpr GhcTc) where - getTypeNode e@(L spn e') = ... -- Actually get the type for this expression -instance HasType (LHsExpr GhcRn) where - getTypeNode (L spn e) = makeNode e spn -- Fallback to a regular `makeNode` without recording the type - -If your subtree doesn't have a span available, you can omit the `makeNode` -call and just recurse directly in to the subexpressions. - --} - --- These synonyms match those defined in main/GHC.hs -type RenamedSource = ( HsGroup GhcRn, [LImportDecl GhcRn] - , Maybe [(LIE GhcRn, Avails)] - , Maybe LHsDocString ) -type TypecheckedSource = LHsBinds GhcTc - - -{- Note [Name Remapping] -The Typechecker introduces new names for mono names in AbsBinds. -We don't care about the distinction between mono and poly bindings, -so we replace all occurrences of the mono name with the poly name. --} -newtype HieState = HieState - { name_remapping :: NameEnv Id - } - -initState :: HieState -initState = HieState emptyNameEnv - -class ModifyState a where -- See Note [Name Remapping] - addSubstitution :: a -> a -> HieState -> HieState - -instance ModifyState Name where - addSubstitution _ _ hs = hs - -instance ModifyState Id where - addSubstitution mono poly hs = - hs{name_remapping = extendNameEnv (name_remapping hs) (varName mono) poly} - -modifyState :: ModifyState (IdP p) => [ABExport p] -> HieState -> HieState -modifyState = foldr go id - where - go ABE{abe_poly=poly,abe_mono=mono} f = addSubstitution mono poly . f - go _ f = f - -type HieM = ReaderT HieState Hsc - -enrichHie :: TypecheckedSource -> RenamedSource -> Hsc (HieASTs Type) -enrichHie ts (hsGrp, imports, exports, _) = flip runReaderT initState $ do - tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts - rasts <- processGrp hsGrp - imps <- toHie $ filter (not . ideclImplicit . unLoc) imports - exps <- toHie $ fmap (map $ IEC Export . fst) exports - let spanFile children = case children of - [] -> mkRealSrcSpan (mkRealSrcLoc "" 1 1) (mkRealSrcLoc "" 1 1) - _ -> mkRealSrcSpan (realSrcSpanStart $ nodeSpan $ head children) - (realSrcSpanEnd $ nodeSpan $ last children) - - modulify xs = - Node (simpleNodeInfo "Module" "Module") (spanFile xs) xs - - asts = HieASTs - $ resolveTyVarScopes - $ M.map (modulify . mergeSortAsts) - $ M.fromListWith (++) - $ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts - - flat_asts = concat - [ tasts - , rasts - , imps - , exps - ] - return asts - where - processGrp grp = concatM - [ toHie $ fmap (RS ModuleScope ) hs_valds grp - , toHie $ hs_splcds grp - , toHie $ hs_tyclds grp - , toHie $ hs_derivds grp - , toHie $ hs_fixds grp - , toHie $ hs_defds grp - , toHie $ hs_fords grp - , toHie $ hs_warnds grp - , toHie $ hs_annds grp - , toHie $ hs_ruleds grp - ] - -getRealSpan :: SrcSpan -> Maybe Span -getRealSpan (RealSrcSpan sp) = Just sp -getRealSpan _ = Nothing - -grhss_span :: GRHSs p body -> SrcSpan -grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (getLoc bs) (map getLoc xs) -grhss_span (XGRHSs _) = panic "XGRHS has no span" - -bindingsOnly :: [Context Name] -> [HieAST a] -bindingsOnly [] = [] -bindingsOnly (C c n : xs) = case nameSrcSpan n of - RealSrcSpan span -> Node nodeinfo span [] : bindingsOnly xs - where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info) - info = mempty{identInfo = S.singleton c} - _ -> bindingsOnly xs - -concatM :: Monad m => [m [a]] -> m [a] -concatM xs = concat <$> sequence xs - -{- Note [Capturing Scopes and other non local information] -toHie is a local tranformation, but scopes of bindings cannot be known locally, -hence we have to push the relevant info down into the binding nodes. -We use the following types (*Context and *Scoped) to wrap things and -carry the required info -(Maybe Span) always carries the span of the entire binding, including rhs --} -data Context a = C ContextInfo a -- Used for names and bindings - -data RContext a = RC RecFieldContext a -data RFContext a = RFC RecFieldContext (Maybe Span) a --- ^ context for record fields - -data IEContext a = IEC IEType a --- ^ context for imports/exports - -data BindContext a = BC BindType Scope a --- ^ context for imports/exports - -data PatSynFieldContext a = PSC (Maybe Span) a --- ^ context for pattern synonym fields. - -data SigContext a = SC SigInfo a --- ^ context for type signatures - -data SigInfo = SI SigType (Maybe Span) - -data SigType = BindSig | ClassSig | InstSig - -data RScoped a = RS Scope a --- ^ Scope spans over everything to the right of a, (mostly) not --- including a itself --- (Includes a in a few special cases like recursive do bindings) or --- let/where bindings - --- | Pattern scope -data PScoped a = PS (Maybe Span) - Scope -- ^ use site of the pattern - Scope -- ^ pattern to the right of a, not including a - a - deriving (Typeable, Data) -- Pattern Scope - -{- Note [TyVar Scopes] -Due to -XScopedTypeVariables, type variables can be in scope quite far from -their original binding. We resolve the scope of these type variables -in a separate pass --} -data TScoped a = TS TyVarScope a -- TyVarScope - -data TVScoped a = TVS TyVarScope Scope a -- TyVarScope --- ^ First scope remains constant --- Second scope is used to build up the scope of a tyvar over --- things to its right, ala RScoped - --- | Each element scopes over the elements to the right -listScopes :: Scope -> [Located a] -> [RScoped (Located a)] -listScopes _ [] = [] -listScopes rhsScope [pat] = [RS rhsScope pat] -listScopes rhsScope (pat : pats) = RS sc pat : pats' - where - pats'@((RS scope p):_) = listScopes rhsScope pats - sc = combineScopes scope $ mkScope $ getLoc p - --- | 'listScopes' specialised to 'PScoped' things -patScopes - :: Maybe Span - -> Scope - -> Scope - -> [LPat (GhcPass p)] - -> [PScoped (LPat (GhcPass p))] -patScopes rsp useScope patScope xs = - map (\(RS sc a) -> PS rsp useScope sc (composeSrcSpan a)) $ - listScopes patScope (map dL xs) - --- | 'listScopes' specialised to 'TVScoped' things -tvScopes - :: TyVarScope - -> Scope - -> [LHsTyVarBndr a] - -> [TVScoped (LHsTyVarBndr a)] -tvScopes tvScope rhsScope xs = - map (\(RS sc a)-> TVS tvScope sc a) $ listScopes rhsScope xs - -{- Note [Scoping Rules for SigPat] -Explicitly quantified variables in pattern type signatures are not -brought into scope in the rhs, but implicitly quantified variables -are (HsWC and HsIB). -This is unlike other signatures, where explicitly quantified variables -are brought into the RHS Scope -For example -foo :: forall a. ...; -foo = ... -- a is in scope here - -bar (x :: forall a. a -> a) = ... -- a is not in scope here --- ^ a is in scope here (pattern body) - -bax (x :: a) = ... -- a is in scope here -Because of HsWC and HsIB pass on their scope to their children -we must wrap the LHsType in pattern signatures in a -Shielded explictly, so that the HsWC/HsIB scope is not passed -on the the LHsType --} - -data Shielded a = SH Scope a -- Ignores its TScope, uses its own scope instead - -type family ProtectedSig a where - ProtectedSig GhcRn = HsWildCardBndrs GhcRn (HsImplicitBndrs - GhcRn - (Shielded (LHsType GhcRn))) - ProtectedSig GhcTc = NoExtField - -class ProtectSig a where - protectSig :: Scope -> LHsSigWcType (NoGhcTc a) -> ProtectedSig a - -instance (HasLoc a) => HasLoc (Shielded a) where - loc (SH _ a) = loc a - -instance (ToHie (TScoped a)) => ToHie (TScoped (Shielded a)) where - toHie (TS _ (SH sc a)) = toHie (TS (ResolvedScopes [sc]) a) - -instance ProtectSig GhcTc where - protectSig _ _ = noExtField - -instance ProtectSig GhcRn where - protectSig sc (HsWC a (HsIB b sig)) = - HsWC a (HsIB b (SH sc sig)) - protectSig _ (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec - protectSig _ (XHsWildCardBndrs nec) = noExtCon nec - -class HasLoc a where - -- ^ defined so that HsImplicitBndrs and HsWildCardBndrs can - -- know what their implicit bindings are scoping over - loc :: a -> SrcSpan - -instance HasLoc thing => HasLoc (TScoped thing) where - loc (TS _ a) = loc a - -instance HasLoc thing => HasLoc (PScoped thing) where - loc (PS _ _ _ a) = loc a - -instance HasLoc (LHsQTyVars GhcRn) where - loc (HsQTvs _ vs) = loc vs - loc _ = noSrcSpan - -instance HasLoc thing => HasLoc (HsImplicitBndrs a thing) where - loc (HsIB _ a) = loc a - loc _ = noSrcSpan - -instance HasLoc thing => HasLoc (HsWildCardBndrs a thing) where - loc (HsWC _ a) = loc a - loc _ = noSrcSpan - -instance HasLoc (Located a) where - loc (L l _) = l - -instance HasLoc a => HasLoc [a] where - loc [] = noSrcSpan - loc xs = foldl1' combineSrcSpans $ map loc xs - -instance HasLoc a => HasLoc (FamEqn s a) where - loc (FamEqn _ a Nothing b _ c) = foldl1' combineSrcSpans [loc a, loc b, loc c] - loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans - [loc a, loc tvs, loc b, loc c] - loc _ = noSrcSpan -instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg tm ty) where - loc (HsValArg tm) = loc tm - loc (HsTypeArg _ ty) = loc ty - loc (HsArgPar sp) = sp - -instance HasLoc (HsDataDefn GhcRn) where - loc def@(HsDataDefn{}) = loc $ dd_cons def - -- Only used for data family instances, so we only need rhs - -- Most probably the rest will be unhelpful anyway - loc _ = noSrcSpan - -{- Note [Real DataCon Name] -The typechecker subtitutes the conLikeWrapId for the name, but we don't want -this showing up in the hieFile, so we replace the name in the Id with the -original datacon name -See also Note [Data Constructor Naming] --} -class HasRealDataConName p where - getRealDataCon :: XRecordCon p -> Located (IdP p) -> Located (IdP p) - -instance HasRealDataConName GhcRn where - getRealDataCon _ n = n -instance HasRealDataConName GhcTc where - getRealDataCon RecordConTc{rcon_con_like = con} (L sp var) = - L sp (setVarName var (conLikeName con)) - --- | The main worker class --- See Note [Updating HieAst for changes in the GHC AST] for more information --- on how to add/modify instances for this. -class ToHie a where - toHie :: a -> HieM [HieAST Type] - --- | Used to collect type info -class Data a => HasType a where - getTypeNode :: a -> HieM [HieAST Type] - -instance (ToHie a) => ToHie [a] where - toHie = concatMapM toHie - -instance (ToHie a) => ToHie (Bag a) where - toHie = toHie . bagToList - -instance (ToHie a) => ToHie (Maybe a) where - toHie = maybe (pure []) toHie - -instance ToHie (Context (Located NoExtField)) where - toHie _ = pure [] - -instance ToHie (TScoped NoExtField) where - toHie _ = pure [] - -instance ToHie (IEContext (Located ModuleName)) where - toHie (IEC c (L (RealSrcSpan span) mname)) = - pure $ [Node (NodeInfo S.empty [] idents) span []] - where details = mempty{identInfo = S.singleton (IEThing c)} - idents = M.singleton (Left mname) details - toHie _ = pure [] - -instance ToHie (Context (Located Var)) where - toHie c = case c of - C context (L (RealSrcSpan span) name') - -> do - m <- asks name_remapping - let name = case lookupNameEnv m (varName name') of - Just var -> var - Nothing-> name' - pure - [Node - (NodeInfo S.empty [] $ - M.singleton (Right $ varName name) - (IdentifierDetails (Just $ varType name') - (S.singleton context))) - span - []] - _ -> pure [] - -instance ToHie (Context (Located Name)) where - toHie c = case c of - C context (L (RealSrcSpan span) name') -> do - m <- asks name_remapping - let name = case lookupNameEnv m name' of - Just var -> varName var - Nothing -> name' - pure - [Node - (NodeInfo S.empty [] $ - M.singleton (Right name) - (IdentifierDetails Nothing - (S.singleton context))) - span - []] - _ -> pure [] - --- | Dummy instances - never called -instance ToHie (TScoped (LHsSigWcType GhcTc)) where - toHie _ = pure [] -instance ToHie (TScoped (LHsWcType GhcTc)) where - toHie _ = pure [] -instance ToHie (SigContext (LSig GhcTc)) where - toHie _ = pure [] -instance ToHie (TScoped Type) where - toHie _ = pure [] - -instance HasType (LHsBind GhcRn) where - getTypeNode (L spn bind) = makeNode bind spn - -instance HasType (LHsBind GhcTc) where - getTypeNode (L spn bind) = case bind of - FunBind{fun_id = name} -> makeTypeNode bind spn (varType $ unLoc name) - _ -> makeNode bind spn - -instance HasType (Located (Pat GhcRn)) where - getTypeNode (dL -> L spn pat) = makeNode pat spn - -instance HasType (Located (Pat GhcTc)) where - getTypeNode (dL -> L spn opat) = makeTypeNode opat spn (hsPatType opat) - -instance HasType (LHsExpr GhcRn) where - getTypeNode (L spn e) = makeNode e spn - --- | This instance tries to construct 'HieAST' nodes which include the type of --- the expression. It is not yet possible to do this efficiently for all --- expression forms, so we skip filling in the type for those inputs. --- --- 'HsApp', for example, doesn't have any type information available directly on --- the node. Our next recourse would be to desugar it into a 'CoreExpr' then --- query the type of that. Yet both the desugaring call and the type query both --- involve recursive calls to the function and argument! This is particularly --- problematic when you realize that the HIE traversal will eventually visit --- those nodes too and ask for their types again. --- --- Since the above is quite costly, we just skip cases where computing the --- expression's type is going to be expensive. --- --- See #16233 -instance HasType (LHsExpr GhcTc) where - getTypeNode e@(L spn e') = lift $ - -- Some expression forms have their type immediately available - let tyOpt = case e' of - HsLit _ l -> Just (hsLitType l) - HsOverLit _ o -> Just (overLitType o) - - HsLam _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy) - HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy) - HsCase _ _ (MG { mg_ext = groupTy }) -> Just (mg_res_ty groupTy) - - ExplicitList ty _ _ -> Just (mkListTy ty) - ExplicitSum ty _ _ _ -> Just (mkSumTy ty) - HsDo ty _ _ -> Just ty - HsMultiIf ty _ -> Just ty - - _ -> Nothing - - in - case tyOpt of - Just t -> makeTypeNode e' spn t - Nothing - | skipDesugaring e' -> fallback - | otherwise -> do - hs_env <- Hsc $ \e w -> return (e,w) - (_,mbe) <- liftIO $ deSugarExpr hs_env e - maybe fallback (makeTypeNode e' spn . exprType) mbe - where - fallback = makeNode e' spn - - matchGroupType :: MatchGroupTc -> Type - matchGroupType (MatchGroupTc args res) = mkVisFunTys args res - - -- | Skip desugaring of these expressions for performance reasons. - -- - -- See impact on Haddock output (esp. missing type annotations or links) - -- before marking more things here as 'False'. See impact on Haddock - -- performance before marking more things as 'True'. - skipDesugaring :: HsExpr a -> Bool - skipDesugaring e = case e of - HsVar{} -> False - HsUnboundVar{} -> False - HsConLikeOut{} -> False - HsRecFld{} -> False - HsOverLabel{} -> False - HsIPVar{} -> False - HsWrap{} -> False - _ -> True - -instance ( ToHie (Context (Located (IdP a))) - , ToHie (MatchGroup a (LHsExpr a)) - , ToHie (PScoped (LPat a)) - , ToHie (GRHSs a (LHsExpr a)) - , ToHie (LHsExpr a) - , ToHie (Located (PatSynBind a a)) - , HasType (LHsBind a) - , ModifyState (IdP a) - , Data (HsBind a) - ) => ToHie (BindContext (LHsBind a)) where - toHie (BC context scope b@(L span bind)) = - concatM $ getTypeNode b : case bind of - FunBind{fun_id = name, fun_matches = matches} -> - [ toHie $ C (ValBind context scope $ getRealSpan span) name - , toHie matches - ] - PatBind{pat_lhs = lhs, pat_rhs = rhs} -> - [ toHie $ PS (getRealSpan span) scope NoScope lhs - , toHie rhs - ] - VarBind{var_rhs = expr} -> - [ toHie expr - ] - AbsBinds{abs_exports = xs, abs_binds = binds} -> - [ local (modifyState xs) $ -- Note [Name Remapping] - toHie $ fmap (BC context scope) binds - ] - PatSynBind _ psb -> - [ toHie $ L span psb -- PatSynBinds only occur at the top level - ] - XHsBindsLR _ -> [] - -instance ( ToHie (LMatch a body) - ) => ToHie (MatchGroup a body) where - toHie mg = concatM $ case mg of - MG{ mg_alts = (L span alts) , mg_origin = FromSource } -> - [ pure $ locOnly span - , toHie alts - ] - MG{} -> [] - XMatchGroup _ -> [] - -instance ( ToHie (Context (Located (IdP a))) - , ToHie (PScoped (LPat a)) - , ToHie (HsPatSynDir a) - ) => ToHie (Located (PatSynBind a a)) where - toHie (L sp psb) = concatM $ case psb of - PSB{psb_id=var, psb_args=dets, psb_def=pat, psb_dir=dir} -> - [ toHie $ C (Decl PatSynDec $ getRealSpan sp) var - , toHie $ toBind dets - , toHie $ PS Nothing lhsScope NoScope pat - , toHie dir - ] - where - lhsScope = combineScopes varScope detScope - varScope = mkLScope var - detScope = case dets of - (PrefixCon args) -> foldr combineScopes NoScope $ map mkLScope args - (InfixCon a b) -> combineScopes (mkLScope a) (mkLScope b) - (RecCon r) -> foldr go NoScope r - go (RecordPatSynField a b) c = combineScopes c - $ combineScopes (mkLScope a) (mkLScope b) - detSpan = case detScope of - LocalScope a -> Just a - _ -> Nothing - toBind (PrefixCon args) = PrefixCon $ map (C Use) args - toBind (InfixCon a b) = InfixCon (C Use a) (C Use b) - toBind (RecCon r) = RecCon $ map (PSC detSpan) r - XPatSynBind _ -> [] - -instance ( ToHie (MatchGroup a (LHsExpr a)) - ) => ToHie (HsPatSynDir a) where - toHie dir = case dir of - ExplicitBidirectional mg -> toHie mg - _ -> pure [] - -instance ( a ~ GhcPass p - , ToHie body - , ToHie (HsMatchContext (NameOrRdrName (IdP a))) - , ToHie (PScoped (LPat a)) - , ToHie (GRHSs a body) - , Data (Match a body) - ) => ToHie (LMatch (GhcPass p) body) where - toHie (L span m ) = concatM $ makeNode m span : case m of - Match{m_ctxt=mctx, m_pats = pats, m_grhss = grhss } -> - [ toHie mctx - , let rhsScope = mkScope $ grhss_span grhss - in toHie $ patScopes Nothing rhsScope NoScope pats - , toHie grhss - ] - XMatch _ -> [] - -instance ( ToHie (Context (Located a)) - ) => ToHie (HsMatchContext a) where - toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name - toHie (StmtCtxt a) = toHie a - toHie _ = pure [] - -instance ( ToHie (HsMatchContext a) - ) => ToHie (HsStmtContext a) where - toHie (PatGuard a) = toHie a - toHie (ParStmtCtxt a) = toHie a - toHie (TransStmtCtxt a) = toHie a - toHie _ = pure [] - -instance ( a ~ GhcPass p - , ToHie (Context (Located (IdP a))) - , ToHie (RContext (HsRecFields a (PScoped (LPat a)))) - , ToHie (LHsExpr a) - , ToHie (TScoped (LHsSigWcType a)) - , ProtectSig a - , ToHie (TScoped (ProtectedSig a)) - , HasType (LPat a) - , Data (HsSplice a) - ) => ToHie (PScoped (Located (Pat (GhcPass p)))) where - toHie (PS rsp scope pscope lpat@(dL -> L ospan opat)) = - concatM $ getTypeNode lpat : case opat of - WildPat _ -> - [] - VarPat _ lname -> - [ toHie $ C (PatternBind scope pscope rsp) lname - ] - LazyPat _ p -> - [ toHie $ PS rsp scope pscope p - ] - AsPat _ lname pat -> - [ toHie $ C (PatternBind scope - (combineScopes (mkLScope (dL pat)) pscope) - rsp) - lname - , toHie $ PS rsp scope pscope pat - ] - ParPat _ pat -> - [ toHie $ PS rsp scope pscope pat - ] - BangPat _ pat -> - [ toHie $ PS rsp scope pscope pat - ] - ListPat _ pats -> - [ toHie $ patScopes rsp scope pscope pats - ] - TuplePat _ pats _ -> - [ toHie $ patScopes rsp scope pscope pats - ] - SumPat _ pat _ _ -> - [ toHie $ PS rsp scope pscope pat - ] - ConPatIn c dets -> - [ toHie $ C Use c - , toHie $ contextify dets - ] - ConPatOut {pat_con = con, pat_args = dets}-> - [ toHie $ C Use $ fmap conLikeName con - , toHie $ contextify dets - ] - ViewPat _ expr pat -> - [ toHie expr - , toHie $ PS rsp scope pscope pat - ] - SplicePat _ sp -> - [ toHie $ L ospan sp - ] - LitPat _ _ -> - [] - NPat _ _ _ _ -> - [] - NPlusKPat _ n _ _ _ _ -> - [ toHie $ C (PatternBind scope pscope rsp) n - ] - SigPat _ pat sig -> - [ toHie $ PS rsp scope pscope pat - , let cscope = mkLScope (dL pat) in - toHie $ TS (ResolvedScopes [cscope, scope, pscope]) - (protectSig @a cscope sig) - -- See Note [Scoping Rules for SigPat] - ] - CoPat _ _ _ _ -> - [] - XPat _ -> [] - where - contextify (PrefixCon args) = PrefixCon $ patScopes rsp scope pscope args - contextify (InfixCon a b) = InfixCon a' b' - where [a', b'] = patScopes rsp scope pscope [a,b] - contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r - contextify_rec (HsRecFields fds a) = HsRecFields (map go scoped_fds) a - where - go (RS fscope (L spn (HsRecField lbl pat pun))) = - L spn $ HsRecField lbl (PS rsp scope fscope pat) pun - scoped_fds = listScopes pscope fds - -instance ( ToHie body - , ToHie (LGRHS a body) - , ToHie (RScoped (LHsLocalBinds a)) - ) => ToHie (GRHSs a body) where - toHie grhs = concatM $ case grhs of - GRHSs _ grhss binds -> - [ toHie grhss - , toHie $ RS (mkScope $ grhss_span grhs) binds - ] - XGRHSs _ -> [] - -instance ( ToHie (Located body) - , ToHie (RScoped (GuardLStmt a)) - , Data (GRHS a (Located body)) - ) => ToHie (LGRHS a (Located body)) where - toHie (L span g) = concatM $ makeNode g span : case g of - GRHS _ guards body -> - [ toHie $ listScopes (mkLScope body) guards - , toHie body - ] - XGRHS _ -> [] - -instance ( a ~ GhcPass p - , ToHie (Context (Located (IdP a))) - , HasType (LHsExpr a) - , ToHie (PScoped (LPat a)) - , ToHie (MatchGroup a (LHsExpr a)) - , ToHie (LGRHS a (LHsExpr a)) - , ToHie (RContext (HsRecordBinds a)) - , ToHie (RFContext (Located (AmbiguousFieldOcc a))) - , ToHie (ArithSeqInfo a) - , ToHie (LHsCmdTop a) - , ToHie (RScoped (GuardLStmt a)) - , ToHie (RScoped (LHsLocalBinds a)) - , ToHie (TScoped (LHsWcType (NoGhcTc a))) - , ToHie (TScoped (LHsSigWcType (NoGhcTc a))) - , Data (HsExpr a) - , Data (HsSplice a) - , Data (HsTupArg a) - , Data (AmbiguousFieldOcc a) - , (HasRealDataConName a) - ) => ToHie (LHsExpr (GhcPass p)) where - toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of - HsVar _ (L _ var) -> - [ toHie $ C Use (L mspan var) - -- Patch up var location since typechecker removes it - ] - HsUnboundVar _ _ -> - [] - HsConLikeOut _ con -> - [ toHie $ C Use $ L mspan $ conLikeName con - ] - HsRecFld _ fld -> - [ toHie $ RFC RecFieldOcc Nothing (L mspan fld) - ] - HsOverLabel _ _ _ -> [] - HsIPVar _ _ -> [] - HsOverLit _ _ -> [] - HsLit _ _ -> [] - HsLam _ mg -> - [ toHie mg - ] - HsLamCase _ mg -> - [ toHie mg - ] - HsApp _ a b -> - [ toHie a - , toHie b - ] - HsAppType _ expr sig -> - [ toHie expr - , toHie $ TS (ResolvedScopes []) sig - ] - OpApp _ a b c -> - [ toHie a - , toHie b - , toHie c - ] - NegApp _ a _ -> - [ toHie a - ] - HsPar _ a -> - [ toHie a - ] - SectionL _ a b -> - [ toHie a - , toHie b - ] - SectionR _ a b -> - [ toHie a - , toHie b - ] - ExplicitTuple _ args _ -> - [ toHie args - ] - ExplicitSum _ _ _ expr -> - [ toHie expr - ] - HsCase _ expr matches -> - [ toHie expr - , toHie matches - ] - HsIf _ _ a b c -> - [ toHie a - , toHie b - , toHie c - ] - HsMultiIf _ grhss -> - [ toHie grhss - ] - HsLet _ binds expr -> - [ toHie $ RS (mkLScope expr) binds - , toHie expr - ] - HsDo _ _ (L ispan stmts) -> - [ pure $ locOnly ispan - , toHie $ listScopes NoScope stmts - ] - ExplicitList _ _ exprs -> - [ toHie exprs - ] - RecordCon {rcon_ext = mrealcon, rcon_con_name = name, rcon_flds = binds} -> - [ toHie $ C Use (getRealDataCon @a mrealcon name) - -- See Note [Real DataCon Name] - , toHie $ RC RecFieldAssign $ binds - ] - RecordUpd {rupd_expr = expr, rupd_flds = upds}-> - [ toHie expr - , toHie $ map (RC RecFieldAssign) upds - ] - ExprWithTySig _ expr sig -> - [ toHie expr - , toHie $ TS (ResolvedScopes [mkLScope expr]) sig - ] - ArithSeq _ _ info -> - [ toHie info - ] - HsSCC _ _ _ expr -> - [ toHie expr - ] - HsCoreAnn _ _ _ expr -> - [ toHie expr - ] - HsProc _ pat cmdtop -> - [ toHie $ PS Nothing (mkLScope cmdtop) NoScope pat - , toHie cmdtop - ] - HsStatic _ expr -> - [ toHie expr - ] - HsTick _ _ expr -> - [ toHie expr - ] - HsBinTick _ _ _ expr -> - [ toHie expr - ] - HsTickPragma _ _ _ _ expr -> - [ toHie expr - ] - HsWrap _ _ a -> - [ toHie $ L mspan a - ] - HsBracket _ b -> - [ toHie b - ] - HsRnBracketOut _ b p -> - [ toHie b - , toHie p - ] - HsTcBracketOut _ b p -> - [ toHie b - , toHie p - ] - HsSpliceE _ x -> - [ toHie $ L mspan x - ] - XExpr _ -> [] - -instance ( a ~ GhcPass p - , ToHie (LHsExpr a) - , Data (HsTupArg a) - ) => ToHie (LHsTupArg (GhcPass p)) where - toHie (L span arg) = concatM $ makeNode arg span : case arg of - Present _ expr -> - [ toHie expr - ] - Missing _ -> [] - XTupArg _ -> [] - -instance ( a ~ GhcPass p - , ToHie (PScoped (LPat a)) - , ToHie (LHsExpr a) - , ToHie (SigContext (LSig a)) - , ToHie (RScoped (LHsLocalBinds a)) - , ToHie (RScoped (ApplicativeArg a)) - , ToHie (Located body) - , Data (StmtLR a a (Located body)) - , Data (StmtLR a a (Located (HsExpr a))) - ) => ToHie (RScoped (LStmt (GhcPass p) (Located body))) where - toHie (RS scope (L span stmt)) = concatM $ makeNode stmt span : case stmt of - LastStmt _ body _ _ -> - [ toHie body - ] - BindStmt _ pat body _ _ -> - [ toHie $ PS (getRealSpan $ getLoc body) scope NoScope pat - , toHie body - ] - ApplicativeStmt _ stmts _ -> - [ concatMapM (toHie . RS scope . snd) stmts - ] - BodyStmt _ body _ _ -> - [ toHie body - ] - LetStmt _ binds -> - [ toHie $ RS scope binds - ] - ParStmt _ parstmts _ _ -> - [ concatMapM (\(ParStmtBlock _ stmts _ _) -> - toHie $ listScopes NoScope stmts) - parstmts - ] - TransStmt {trS_stmts = stmts, trS_using = using, trS_by = by} -> - [ toHie $ listScopes scope stmts - , toHie using - , toHie by - ] - RecStmt {recS_stmts = stmts} -> - [ toHie $ map (RS $ combineScopes scope (mkScope span)) stmts - ] - XStmtLR _ -> [] - -instance ( ToHie (LHsExpr a) - , ToHie (PScoped (LPat a)) - , ToHie (BindContext (LHsBind a)) - , ToHie (SigContext (LSig a)) - , ToHie (RScoped (HsValBindsLR a a)) - , Data (HsLocalBinds a) - ) => ToHie (RScoped (LHsLocalBinds a)) where - toHie (RS scope (L sp binds)) = concatM $ makeNode binds sp : case binds of - EmptyLocalBinds _ -> [] - HsIPBinds _ _ -> [] - HsValBinds _ valBinds -> - [ toHie $ RS (combineScopes scope $ mkScope sp) - valBinds - ] - XHsLocalBindsLR _ -> [] - -instance ( ToHie (BindContext (LHsBind a)) - , ToHie (SigContext (LSig a)) - , ToHie (RScoped (XXValBindsLR a a)) - ) => ToHie (RScoped (HsValBindsLR a a)) where - toHie (RS sc v) = concatM $ case v of - ValBinds _ binds sigs -> - [ toHie $ fmap (BC RegularBind sc) binds - , toHie $ fmap (SC (SI BindSig Nothing)) sigs - ] - XValBindsLR x -> [ toHie $ RS sc x ] - -instance ToHie (RScoped (NHsValBindsLR GhcTc)) where - toHie (RS sc (NValBinds binds sigs)) = concatM $ - [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds) - , toHie $ fmap (SC (SI BindSig Nothing)) sigs - ] -instance ToHie (RScoped (NHsValBindsLR GhcRn)) where - toHie (RS sc (NValBinds binds sigs)) = concatM $ - [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds) - , toHie $ fmap (SC (SI BindSig Nothing)) sigs - ] - -instance ( ToHie (RContext (LHsRecField a arg)) - ) => ToHie (RContext (HsRecFields a arg)) where - toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields - -instance ( ToHie (RFContext (Located label)) - , ToHie arg - , HasLoc arg - , Data label - , Data arg - ) => ToHie (RContext (LHsRecField' label arg)) where - toHie (RC c (L span recfld)) = concatM $ makeNode recfld span : case recfld of - HsRecField label expr _ -> - [ toHie $ RFC c (getRealSpan $ loc expr) label - , toHie expr - ] - -instance ToHie (RFContext (LFieldOcc GhcRn)) where - toHie (RFC c rhs (L nspan f)) = concatM $ case f of - FieldOcc name _ -> - [ toHie $ C (RecField c rhs) (L nspan name) - ] - XFieldOcc _ -> [] - -instance ToHie (RFContext (LFieldOcc GhcTc)) where - toHie (RFC c rhs (L nspan f)) = concatM $ case f of - FieldOcc var _ -> - let var' = setVarName var (varName var) - in [ toHie $ C (RecField c rhs) (L nspan var') - ] - XFieldOcc _ -> [] - -instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where - toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of - Unambiguous name _ -> - [ toHie $ C (RecField c rhs) $ L nspan name - ] - Ambiguous _name _ -> - [ ] - XAmbiguousFieldOcc _ -> [] - -instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where - toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of - Unambiguous var _ -> - let var' = setVarName var (varName var) - in [ toHie $ C (RecField c rhs) (L nspan var') - ] - Ambiguous var _ -> - let var' = setVarName var (varName var) - in [ toHie $ C (RecField c rhs) (L nspan var') - ] - XAmbiguousFieldOcc _ -> [] - -instance ( a ~ GhcPass p - , ToHie (PScoped (LPat a)) - , ToHie (BindContext (LHsBind a)) - , ToHie (LHsExpr a) - , ToHie (SigContext (LSig a)) - , ToHie (RScoped (HsValBindsLR a a)) - , Data (StmtLR a a (Located (HsExpr a))) - , Data (HsLocalBinds a) - ) => ToHie (RScoped (ApplicativeArg (GhcPass p))) where - toHie (RS sc (ApplicativeArgOne _ pat expr _ _)) = concatM - [ toHie $ PS Nothing sc NoScope pat - , toHie expr - ] - toHie (RS sc (ApplicativeArgMany _ stmts _ pat)) = concatM - [ toHie $ listScopes NoScope stmts - , toHie $ PS Nothing sc NoScope pat - ] - toHie (RS _ (XApplicativeArg _)) = pure [] - -instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where - toHie (PrefixCon args) = toHie args - toHie (RecCon rec) = toHie rec - toHie (InfixCon a b) = concatM [ toHie a, toHie b] - -instance ( ToHie (LHsCmd a) - , Data (HsCmdTop a) - ) => ToHie (LHsCmdTop a) where - toHie (L span top) = concatM $ makeNode top span : case top of - HsCmdTop _ cmd -> - [ toHie cmd - ] - XCmdTop _ -> [] - -instance ( a ~ GhcPass p - , ToHie (PScoped (LPat a)) - , ToHie (BindContext (LHsBind a)) - , ToHie (LHsExpr a) - , ToHie (MatchGroup a (LHsCmd a)) - , ToHie (SigContext (LSig a)) - , ToHie (RScoped (HsValBindsLR a a)) - , Data (HsCmd a) - , Data (HsCmdTop a) - , Data (StmtLR a a (Located (HsCmd a))) - , Data (HsLocalBinds a) - , Data (StmtLR a a (Located (HsExpr a))) - ) => ToHie (LHsCmd (GhcPass p)) where - toHie (L span cmd) = concatM $ makeNode cmd span : case cmd of - HsCmdArrApp _ a b _ _ -> - [ toHie a - , toHie b - ] - HsCmdArrForm _ a _ _ cmdtops -> - [ toHie a - , toHie cmdtops - ] - HsCmdApp _ a b -> - [ toHie a - , toHie b - ] - HsCmdLam _ mg -> - [ toHie mg - ] - HsCmdPar _ a -> - [ toHie a - ] - HsCmdCase _ expr alts -> - [ toHie expr - , toHie alts - ] - HsCmdIf _ _ a b c -> - [ toHie a - , toHie b - , toHie c - ] - HsCmdLet _ binds cmd' -> - [ toHie $ RS (mkLScope cmd') binds - , toHie cmd' - ] - HsCmdDo _ (L ispan stmts) -> - [ pure $ locOnly ispan - , toHie $ listScopes NoScope stmts - ] - HsCmdWrap _ _ _ -> [] - XCmd _ -> [] - -instance ToHie (TyClGroup GhcRn) where - toHie TyClGroup{ group_tyclds = classes - , group_roles = roles - , group_kisigs = sigs - , group_instds = instances } = - concatM - [ toHie classes - , toHie sigs - , toHie roles - , toHie instances - ] - toHie (XTyClGroup _) = pure [] - -instance ToHie (LTyClDecl GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - FamDecl {tcdFam = fdecl} -> - [ toHie (L span fdecl) - ] - SynDecl {tcdLName = name, tcdTyVars = vars, tcdRhs = typ} -> - [ toHie $ C (Decl SynDec $ getRealSpan span) name - , toHie $ TS (ResolvedScopes [mkScope $ getLoc typ]) vars - , toHie typ - ] - DataDecl {tcdLName = name, tcdTyVars = vars, tcdDataDefn = defn} -> - [ toHie $ C (Decl DataDec $ getRealSpan span) name - , toHie $ TS (ResolvedScopes [quant_scope, rhs_scope]) vars - , toHie defn - ] - where - quant_scope = mkLScope $ dd_ctxt defn - rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc - sig_sc = maybe NoScope mkLScope $ dd_kindSig defn - con_sc = foldr combineScopes NoScope $ map mkLScope $ dd_cons defn - deriv_sc = mkLScope $ dd_derivs defn - ClassDecl { tcdCtxt = context - , tcdLName = name - , tcdTyVars = vars - , tcdFDs = deps - , tcdSigs = sigs - , tcdMeths = meths - , tcdATs = typs - , tcdATDefs = deftyps - } -> - [ toHie $ C (Decl ClassDec $ getRealSpan span) name - , toHie context - , toHie $ TS (ResolvedScopes [context_scope, rhs_scope]) vars - , toHie deps - , toHie $ map (SC $ SI ClassSig $ getRealSpan span) sigs - , toHie $ fmap (BC InstanceBind ModuleScope) meths - , toHie typs - , concatMapM (pure . locOnly . getLoc) deftyps - , toHie deftyps - ] - where - context_scope = mkLScope context - rhs_scope = foldl1' combineScopes $ map mkScope - [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps] - XTyClDecl _ -> [] - -instance ToHie (LFamilyDecl GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - FamilyDecl _ info name vars _ sig inj -> - [ toHie $ C (Decl FamDec $ getRealSpan span) name - , toHie $ TS (ResolvedScopes [rhsSpan]) vars - , toHie info - , toHie $ RS injSpan sig - , toHie inj - ] - where - rhsSpan = sigSpan `combineScopes` injSpan - sigSpan = mkScope $ getLoc sig - injSpan = maybe NoScope (mkScope . getLoc) inj - XFamilyDecl _ -> [] - -instance ToHie (FamilyInfo GhcRn) where - toHie (ClosedTypeFamily (Just eqns)) = concatM $ - [ concatMapM (pure . locOnly . getLoc) eqns - , toHie $ map go eqns - ] - where - go (L l ib) = TS (ResolvedScopes [mkScope l]) ib - toHie _ = pure [] - -instance ToHie (RScoped (LFamilyResultSig GhcRn)) where - toHie (RS sc (L span sig)) = concatM $ makeNode sig span : case sig of - NoSig _ -> - [] - KindSig _ k -> - [ toHie k - ] - TyVarSig _ bndr -> - [ toHie $ TVS (ResolvedScopes [sc]) NoScope bndr - ] - XFamilyResultSig _ -> [] - -instance ToHie (Located (FunDep (Located Name))) where - toHie (L span fd@(lhs, rhs)) = concatM $ - [ makeNode fd span - , toHie $ map (C Use) lhs - , toHie $ map (C Use) rhs - ] - -instance (ToHie rhs, HasLoc rhs) - => ToHie (TScoped (FamEqn GhcRn rhs)) where - toHie (TS _ f) = toHie f - -instance (ToHie rhs, HasLoc rhs) - => ToHie (FamEqn GhcRn rhs) where - toHie fe@(FamEqn _ var tybndrs pats _ rhs) = concatM $ - [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var - , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs - , toHie pats - , toHie rhs - ] - where scope = combineScopes patsScope rhsScope - patsScope = mkScope (loc pats) - rhsScope = mkScope (loc rhs) - toHie (XFamEqn _) = pure [] - -instance ToHie (LInjectivityAnn GhcRn) where - toHie (L span ann) = concatM $ makeNode ann span : case ann of - InjectivityAnn lhs rhs -> - [ toHie $ C Use lhs - , toHie $ map (C Use) rhs - ] - -instance ToHie (HsDataDefn GhcRn) where - toHie (HsDataDefn _ _ ctx _ mkind cons derivs) = concatM - [ toHie ctx - , toHie mkind - , toHie cons - , toHie derivs - ] - toHie (XHsDataDefn _) = pure [] - -instance ToHie (HsDeriving GhcRn) where - toHie (L span clauses) = concatM - [ pure $ locOnly span - , toHie clauses - ] - -instance ToHie (LHsDerivingClause GhcRn) where - toHie (L span cl) = concatM $ makeNode cl span : case cl of - HsDerivingClause _ strat (L ispan tys) -> - [ toHie strat - , pure $ locOnly ispan - , toHie $ map (TS (ResolvedScopes [])) tys - ] - XHsDerivingClause _ -> [] - -instance ToHie (Located (DerivStrategy GhcRn)) where - toHie (L span strat) = concatM $ makeNode strat span : case strat of - StockStrategy -> [] - AnyclassStrategy -> [] - NewtypeStrategy -> [] - ViaStrategy s -> [ toHie $ TS (ResolvedScopes []) s ] - -instance ToHie (Located OverlapMode) where - toHie (L span _) = pure $ locOnly span - -instance ToHie (LConDecl GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - ConDeclGADT { con_names = names, con_qvars = qvars - , con_mb_cxt = ctx, con_args = args, con_res_ty = typ } -> - [ toHie $ map (C (Decl ConDec $ getRealSpan span)) names - , toHie $ TS (ResolvedScopes [ctxScope, rhsScope]) qvars - , toHie ctx - , toHie args - , toHie typ - ] - where - rhsScope = combineScopes argsScope tyScope - ctxScope = maybe NoScope mkLScope ctx - argsScope = condecl_scope args - tyScope = mkLScope typ - ConDeclH98 { con_name = name, con_ex_tvs = qvars - , con_mb_cxt = ctx, con_args = dets } -> - [ toHie $ C (Decl ConDec $ getRealSpan span) name - , toHie $ tvScopes (ResolvedScopes []) rhsScope qvars - , toHie ctx - , toHie dets - ] - where - rhsScope = combineScopes ctxScope argsScope - ctxScope = maybe NoScope mkLScope ctx - argsScope = condecl_scope dets - XConDecl _ -> [] - where condecl_scope args = case args of - PrefixCon xs -> foldr combineScopes NoScope $ map mkLScope xs - InfixCon a b -> combineScopes (mkLScope a) (mkLScope b) - RecCon x -> mkLScope x - -instance ToHie (Located [LConDeclField GhcRn]) where - toHie (L span decls) = concatM $ - [ pure $ locOnly span - , toHie decls - ] - -instance ( HasLoc thing - , ToHie (TScoped thing) - ) => ToHie (TScoped (HsImplicitBndrs GhcRn thing)) where - toHie (TS sc (HsIB ibrn a)) = concatM $ - [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) ibrn - , toHie $ TS sc a - ] - where span = loc a - toHie (TS _ (XHsImplicitBndrs _)) = pure [] - -instance ( HasLoc thing - , ToHie (TScoped thing) - ) => ToHie (TScoped (HsWildCardBndrs GhcRn thing)) where - toHie (TS sc (HsWC names a)) = concatM $ - [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names - , toHie $ TS sc a - ] - where span = loc a - toHie (TS _ (XHsWildCardBndrs _)) = pure [] - -instance ToHie (LStandaloneKindSig GhcRn) where - toHie (L sp sig) = concatM [makeNode sig sp, toHie sig] - -instance ToHie (StandaloneKindSig GhcRn) where - toHie sig = concatM $ case sig of - StandaloneKindSig _ name typ -> - [ toHie $ C TyDecl name - , toHie $ TS (ResolvedScopes []) typ - ] - XStandaloneKindSig _ -> [] - -instance ToHie (SigContext (LSig GhcRn)) where - toHie (SC (SI styp msp) (L sp sig)) = concatM $ makeNode sig sp : case sig of - TypeSig _ names typ -> - [ toHie $ map (C TyDecl) names - , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ - ] - PatSynSig _ names typ -> - [ toHie $ map (C TyDecl) names - , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ - ] - ClassOpSig _ _ names typ -> - [ case styp of - ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpan sp) names - _ -> toHie $ map (C $ TyDecl) names - , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ - ] - IdSig _ _ -> [] - FixSig _ fsig -> - [ toHie $ L sp fsig - ] - InlineSig _ name _ -> - [ toHie $ (C Use) name - ] - SpecSig _ name typs _ -> - [ toHie $ (C Use) name - , toHie $ map (TS (ResolvedScopes [])) typs - ] - SpecInstSig _ _ typ -> - [ toHie $ TS (ResolvedScopes []) typ - ] - MinimalSig _ _ form -> - [ toHie form - ] - SCCFunSig _ _ name mtxt -> - [ toHie $ (C Use) name - , pure $ maybe [] (locOnly . getLoc) mtxt - ] - CompleteMatchSig _ _ (L ispan names) typ -> - [ pure $ locOnly ispan - , toHie $ map (C Use) names - , toHie $ fmap (C Use) typ - ] - XSig _ -> [] - -instance ToHie (LHsType GhcRn) where - toHie x = toHie $ TS (ResolvedScopes []) x - -instance ToHie (TScoped (LHsType GhcRn)) where - toHie (TS tsc (L span t)) = concatM $ makeNode t span : case t of - HsForAllTy _ _ bndrs body -> - [ toHie $ tvScopes tsc (mkScope $ getLoc body) bndrs - , toHie body - ] - HsQualTy _ ctx body -> - [ toHie ctx - , toHie body - ] - HsTyVar _ _ var -> - [ toHie $ C Use var - ] - HsAppTy _ a b -> - [ toHie a - , toHie b - ] - HsAppKindTy _ ty ki -> - [ toHie ty - , toHie $ TS (ResolvedScopes []) ki - ] - HsFunTy _ a b -> - [ toHie a - , toHie b - ] - HsListTy _ a -> - [ toHie a - ] - HsTupleTy _ _ tys -> - [ toHie tys - ] - HsSumTy _ tys -> - [ toHie tys - ] - HsOpTy _ a op b -> - [ toHie a - , toHie $ C Use op - , toHie b - ] - HsParTy _ a -> - [ toHie a - ] - HsIParamTy _ ip ty -> - [ toHie ip - , toHie ty - ] - HsKindSig _ a b -> - [ toHie a - , toHie b - ] - HsSpliceTy _ a -> - [ toHie $ L span a - ] - HsDocTy _ a _ -> - [ toHie a - ] - HsBangTy _ _ ty -> - [ toHie ty - ] - HsRecTy _ fields -> - [ toHie fields - ] - HsExplicitListTy _ _ tys -> - [ toHie tys - ] - HsExplicitTupleTy _ tys -> - [ toHie tys - ] - HsTyLit _ _ -> [] - HsWildCardTy _ -> [] - HsStarTy _ _ -> [] - XHsType _ -> [] - -instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where - toHie (HsValArg tm) = toHie tm - toHie (HsTypeArg _ ty) = toHie ty - toHie (HsArgPar sp) = pure $ locOnly sp - -instance ToHie (TVScoped (LHsTyVarBndr GhcRn)) where - toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of - UserTyVar _ var -> - [ toHie $ C (TyVarBind sc tsc) var - ] - KindedTyVar _ var kind -> - [ toHie $ C (TyVarBind sc tsc) var - , toHie kind - ] - XTyVarBndr _ -> [] - -instance ToHie (TScoped (LHsQTyVars GhcRn)) where - toHie (TS sc (HsQTvs implicits vars)) = concatM $ - [ pure $ bindingsOnly bindings - , toHie $ tvScopes sc NoScope vars - ] - where - varLoc = loc vars - bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits - toHie (TS _ (XLHsQTyVars _)) = pure [] - -instance ToHie (LHsContext GhcRn) where - toHie (L span tys) = concatM $ - [ pure $ locOnly span - , toHie tys - ] - -instance ToHie (LConDeclField GhcRn) where - toHie (L span field) = concatM $ makeNode field span : case field of - ConDeclField _ fields typ _ -> - [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields - , toHie typ - ] - XConDeclField _ -> [] - -instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where - toHie (From expr) = toHie expr - toHie (FromThen a b) = concatM $ - [ toHie a - , toHie b - ] - toHie (FromTo a b) = concatM $ - [ toHie a - , toHie b - ] - toHie (FromThenTo a b c) = concatM $ - [ toHie a - , toHie b - , toHie c - ] - -instance ToHie (LSpliceDecl GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - SpliceDecl _ splice _ -> - [ toHie splice - ] - XSpliceDecl _ -> [] - -instance ToHie (HsBracket a) where - toHie _ = pure [] - -instance ToHie PendingRnSplice where - toHie _ = pure [] - -instance ToHie PendingTcSplice where - toHie _ = pure [] - -instance ToHie (LBooleanFormula (Located Name)) where - toHie (L span form) = concatM $ makeNode form span : case form of - Var a -> - [ toHie $ C Use a - ] - And forms -> - [ toHie forms - ] - Or forms -> - [ toHie forms - ] - Parens f -> - [ toHie f - ] - -instance ToHie (Located HsIPName) where - toHie (L span e) = makeNode e span - -instance ( ToHie (LHsExpr a) - , Data (HsSplice a) - ) => ToHie (Located (HsSplice a)) where - toHie (L span sp) = concatM $ makeNode sp span : case sp of - HsTypedSplice _ _ _ expr -> - [ toHie expr - ] - HsUntypedSplice _ _ _ expr -> - [ toHie expr - ] - HsQuasiQuote _ _ _ ispan _ -> - [ pure $ locOnly ispan - ] - HsSpliced _ _ _ -> - [] - HsSplicedT _ -> - [] - XSplice _ -> [] - -instance ToHie (LRoleAnnotDecl GhcRn) where - toHie (L span annot) = concatM $ makeNode annot span : case annot of - RoleAnnotDecl _ var roles -> - [ toHie $ C Use var - , concatMapM (pure . locOnly . getLoc) roles - ] - XRoleAnnotDecl _ -> [] - -instance ToHie (LInstDecl GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - ClsInstD _ d -> - [ toHie $ L span d - ] - DataFamInstD _ d -> - [ toHie $ L span d - ] - TyFamInstD _ d -> - [ toHie $ L span d - ] - XInstDecl _ -> [] - -instance ToHie (LClsInstDecl GhcRn) where - toHie (L span decl) = concatM - [ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl - , toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl - , toHie $ map (SC $ SI InstSig $ getRealSpan span) $ cid_sigs decl - , pure $ concatMap (locOnly . getLoc) $ cid_tyfam_insts decl - , toHie $ cid_tyfam_insts decl - , pure $ concatMap (locOnly . getLoc) $ cid_datafam_insts decl - , toHie $ cid_datafam_insts decl - , toHie $ cid_overlap_mode decl - ] - -instance ToHie (LDataFamInstDecl GhcRn) where - toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d - -instance ToHie (LTyFamInstDecl GhcRn) where - toHie (L sp (TyFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d - -instance ToHie (Context a) - => ToHie (PatSynFieldContext (RecordPatSynField a)) where - toHie (PSC sp (RecordPatSynField a b)) = concatM $ - [ toHie $ C (RecField RecFieldDecl sp) a - , toHie $ C Use b - ] - -instance ToHie (LDerivDecl GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - DerivDecl _ typ strat overlap -> - [ toHie $ TS (ResolvedScopes []) typ - , toHie strat - , toHie overlap - ] - XDerivDecl _ -> [] - -instance ToHie (LFixitySig GhcRn) where - toHie (L span sig) = concatM $ makeNode sig span : case sig of - FixitySig _ vars _ -> - [ toHie $ map (C Use) vars - ] - XFixitySig _ -> [] - -instance ToHie (LDefaultDecl GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - DefaultDecl _ typs -> - [ toHie typs - ] - XDefaultDecl _ -> [] - -instance ToHie (LForeignDecl GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - ForeignImport {fd_name = name, fd_sig_ty = sig, fd_fi = fi} -> - [ toHie $ C (ValBind RegularBind ModuleScope $ getRealSpan span) name - , toHie $ TS (ResolvedScopes []) sig - , toHie fi - ] - ForeignExport {fd_name = name, fd_sig_ty = sig, fd_fe = fe} -> - [ toHie $ C Use name - , toHie $ TS (ResolvedScopes []) sig - , toHie fe - ] - XForeignDecl _ -> [] - -instance ToHie ForeignImport where - toHie (CImport (L a _) (L b _) _ _ (L c _)) = pure $ concat $ - [ locOnly a - , locOnly b - , locOnly c - ] - -instance ToHie ForeignExport where - toHie (CExport (L a _) (L b _)) = pure $ concat $ - [ locOnly a - , locOnly b - ] - -instance ToHie (LWarnDecls GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - Warnings _ _ warnings -> - [ toHie warnings - ] - XWarnDecls _ -> [] - -instance ToHie (LWarnDecl GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - Warning _ vars _ -> - [ toHie $ map (C Use) vars - ] - XWarnDecl _ -> [] - -instance ToHie (LAnnDecl GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - HsAnnotation _ _ prov expr -> - [ toHie prov - , toHie expr - ] - XAnnDecl _ -> [] - -instance ToHie (Context (Located a)) => ToHie (AnnProvenance a) where - toHie (ValueAnnProvenance a) = toHie $ C Use a - toHie (TypeAnnProvenance a) = toHie $ C Use a - toHie ModuleAnnProvenance = pure [] - -instance ToHie (LRuleDecls GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - HsRules _ _ rules -> - [ toHie rules - ] - XRuleDecls _ -> [] - -instance ToHie (LRuleDecl GhcRn) where - toHie (L _ (XRuleDecl _)) = pure [] - toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM - [ makeNode r span - , pure $ locOnly $ getLoc rname - , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs - , toHie $ map (RS $ mkScope span) bndrs - , toHie exprA - , toHie exprB - ] - where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc - bndrs_sc = maybe NoScope mkLScope (listToMaybe bndrs) - exprA_sc = mkLScope exprA - exprB_sc = mkLScope exprB - -instance ToHie (RScoped (LRuleBndr GhcRn)) where - toHie (RS sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of - RuleBndr _ var -> - [ toHie $ C (ValBind RegularBind sc Nothing) var - ] - RuleBndrSig _ var typ -> - [ toHie $ C (ValBind RegularBind sc Nothing) var - , toHie $ TS (ResolvedScopes [sc]) typ - ] - XRuleBndr _ -> [] - -instance ToHie (LImportDecl GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - ImportDecl { ideclName = name, ideclAs = as, ideclHiding = hidden } -> - [ toHie $ IEC Import name - , toHie $ fmap (IEC ImportAs) as - , maybe (pure []) goIE hidden - ] - XImportDecl _ -> [] - where - goIE (hiding, (L sp liens)) = concatM $ - [ pure $ locOnly sp - , toHie $ map (IEC c) liens - ] - where - c = if hiding then ImportHiding else Import - -instance ToHie (IEContext (LIE GhcRn)) where - toHie (IEC c (L span ie)) = concatM $ makeNode ie span : case ie of - IEVar _ n -> - [ toHie $ IEC c n - ] - IEThingAbs _ n -> - [ toHie $ IEC c n - ] - IEThingAll _ n -> - [ toHie $ IEC c n - ] - IEThingWith _ n _ ns flds -> - [ toHie $ IEC c n - , toHie $ map (IEC c) ns - , toHie $ map (IEC c) flds - ] - IEModuleContents _ n -> - [ toHie $ IEC c n - ] - IEGroup _ _ _ -> [] - IEDoc _ _ -> [] - IEDocNamed _ _ -> [] - XIE _ -> [] - -instance ToHie (IEContext (LIEWrappedName Name)) where - toHie (IEC c (L span iewn)) = concatM $ makeNode iewn span : case iewn of - IEName n -> - [ toHie $ C (IEThing c) n - ] - IEPattern p -> - [ toHie $ C (IEThing c) p - ] - IEType n -> - [ toHie $ C (IEThing c) n - ] - -instance ToHie (IEContext (Located (FieldLbl Name))) where - toHie (IEC c (L span lbl)) = concatM $ makeNode lbl span : case lbl of - FieldLabel _ _ n -> - [ toHie $ C (IEThing c) $ L span n - ] diff --git a/hie-compat/src-ghc810/Compat/HieBin.hs b/hie-compat/src-ghc810/Compat/HieBin.hs deleted file mode 100644 index 1a6ff2bef1..0000000000 --- a/hie-compat/src-ghc810/Compat/HieBin.hs +++ /dev/null @@ -1,399 +0,0 @@ -{- -Binary serialization for .hie files. --} -{- HLINT ignore -} -{-# LANGUAGE ScopedTypeVariables #-} -module Compat.HieBin ( readHieFile, readHieFileWithVersion, HieHeader, writeHieFile, HieName(..), toHieName, HieFileResult(..), hieMagic, hieNameOcc,NameCacheUpdater(..)) where - -import GHC.Settings ( maybeRead ) - -import Config ( cProjectVersion ) -import Binary -import BinIface ( getDictFastString ) -import FastMutInt -import FastString ( FastString ) -import Module ( Module ) -import Name -import NameCache -import Outputable -import PrelInfo -import SrcLoc -import UniqSupply ( takeUniqFromSupply ) -import Unique -import UniqFM -import IfaceEnv - -import qualified Data.Array as A -import Data.IORef -import Data.ByteString ( ByteString ) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BSC -import Data.List ( mapAccumR ) -import Data.Word ( Word8, Word32 ) -import Control.Monad ( replicateM, when ) -import System.Directory ( createDirectoryIfMissing ) -import System.FilePath ( takeDirectory ) - -import HieTypes - --- | `Name`'s get converted into `HieName`'s before being written into @.hie@ --- files. See 'toHieName' and 'fromHieName' for logic on how to convert between --- these two types. -data HieName - = ExternalName !Module !OccName !SrcSpan - | LocalName !OccName !SrcSpan - | KnownKeyName !Unique - deriving (Eq) - -instance Ord HieName where - compare (ExternalName a b c) (ExternalName d e f) = compare (a,b,c) (d,e,f) - compare (LocalName a b) (LocalName c d) = compare (a,b) (c,d) - compare (KnownKeyName a) (KnownKeyName b) = nonDetCmpUnique a b - -- Not actually non determinstic as it is a KnownKey - compare ExternalName{} _ = LT - compare LocalName{} ExternalName{} = GT - compare LocalName{} _ = LT - compare KnownKeyName{} _ = GT - -instance Outputable HieName where - ppr (ExternalName m n sp) = text "ExternalName" <+> ppr m <+> ppr n <+> ppr sp - ppr (LocalName n sp) = text "LocalName" <+> ppr n <+> ppr sp - ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u - -hieNameOcc :: HieName -> OccName -hieNameOcc (ExternalName _ occ _) = occ -hieNameOcc (LocalName occ _) = occ -hieNameOcc (KnownKeyName u) = - case lookupKnownKeyName u of - Just n -> nameOccName n - Nothing -> pprPanic "hieNameOcc:unknown known-key unique" - (ppr (unpkUnique u)) - - -data HieSymbolTable = HieSymbolTable - { hie_symtab_next :: !FastMutInt - , hie_symtab_map :: !(IORef (UniqFM (Int, HieName))) - } - -data HieDictionary = HieDictionary - { hie_dict_next :: !FastMutInt -- The next index to use - , hie_dict_map :: !(IORef (UniqFM (Int,FastString))) -- indexed by FastString - } - -initBinMemSize :: Int -initBinMemSize = 1024*1024 - --- | The header for HIE files - Capital ASCII letters "HIE". -hieMagic :: [Word8] -hieMagic = [72,73,69] - -hieMagicLen :: Int -hieMagicLen = length hieMagic - -ghcVersion :: ByteString -ghcVersion = BSC.pack cProjectVersion - -putBinLine :: BinHandle -> ByteString -> IO () -putBinLine bh xs = do - mapM_ (putByte bh) $ BS.unpack xs - putByte bh 10 -- newline char - --- | Write a `HieFile` to the given `FilePath`, with a proper header and --- symbol tables for `Name`s and `FastString`s -writeHieFile :: FilePath -> HieFile -> IO () -writeHieFile hie_file_path hiefile = do - bh0 <- openBinMem initBinMemSize - - -- Write the header: hieHeader followed by the - -- hieVersion and the GHC version used to generate this file - mapM_ (putByte bh0) hieMagic - putBinLine bh0 $ BSC.pack $ show hieVersion - putBinLine bh0 $ ghcVersion - - -- remember where the dictionary pointer will go - dict_p_p <- tellBin bh0 - put_ bh0 dict_p_p - - -- remember where the symbol table pointer will go - symtab_p_p <- tellBin bh0 - put_ bh0 symtab_p_p - - -- Make some intial state - symtab_next <- newFastMutInt - writeFastMutInt symtab_next 0 - symtab_map <- newIORef emptyUFM - let hie_symtab = HieSymbolTable { - hie_symtab_next = symtab_next, - hie_symtab_map = symtab_map } - dict_next_ref <- newFastMutInt - writeFastMutInt dict_next_ref 0 - dict_map_ref <- newIORef emptyUFM - let hie_dict = HieDictionary { - hie_dict_next = dict_next_ref, - hie_dict_map = dict_map_ref } - - -- put the main thing - let bh = setUserData bh0 $ newWriteState (putName hie_symtab) - (putName hie_symtab) - (putFastString hie_dict) - put_ bh hiefile - - -- write the symtab pointer at the front of the file - symtab_p <- tellBin bh - putAt bh symtab_p_p symtab_p - seekBin bh symtab_p - - -- write the symbol table itself - symtab_next' <- readFastMutInt symtab_next - symtab_map' <- readIORef symtab_map - putSymbolTable bh symtab_next' symtab_map' - - -- write the dictionary pointer at the front of the file - dict_p <- tellBin bh - putAt bh dict_p_p dict_p - seekBin bh dict_p - - -- write the dictionary itself - dict_next <- readFastMutInt dict_next_ref - dict_map <- readIORef dict_map_ref - putDictionary bh dict_next dict_map - - -- and send the result to the file - createDirectoryIfMissing True (takeDirectory hie_file_path) - writeBinMem bh hie_file_path - return () - -data HieFileResult - = HieFileResult - { hie_file_result_version :: Integer - , hie_file_result_ghc_version :: ByteString - , hie_file_result :: HieFile - } - -type HieHeader = (Integer, ByteString) - --- | Read a `HieFile` from a `FilePath`. Can use --- an existing `NameCache`. Allows you to specify --- which versions of hieFile to attempt to read. --- `Left` case returns the failing header versions. -readHieFileWithVersion :: (HieHeader -> Bool) -> NameCacheUpdater -> FilePath -> IO (Either HieHeader HieFileResult) -readHieFileWithVersion readVersion ncu file = do - bh0 <- readBinMem file - - (hieVersion, ghcVersion) <- readHieFileHeader file bh0 - - if readVersion (hieVersion, ghcVersion) - then do - hieFile <- readHieFileContents bh0 ncu - return $ Right (HieFileResult hieVersion ghcVersion hieFile) - else return $ Left (hieVersion, ghcVersion) - - --- | Read a `HieFile` from a `FilePath`. Can use --- an existing `NameCache`. -readHieFile :: NameCacheUpdater -> FilePath -> IO HieFileResult -readHieFile ncu file = do - - bh0 <- readBinMem file - - (readHieVersion, ghcVersion) <- readHieFileHeader file bh0 - - -- Check if the versions match - when (readHieVersion /= hieVersion) $ - panic $ unwords ["readHieFile: hie file versions don't match for file:" - , file - , "Expected" - , show hieVersion - , "but got", show readHieVersion - ] - hieFile <- readHieFileContents bh0 ncu - return $ HieFileResult hieVersion ghcVersion hieFile - -readBinLine :: BinHandle -> IO ByteString -readBinLine bh = BS.pack . reverse <$> loop [] - where - loop acc = do - char <- get bh :: IO Word8 - if char == 10 -- ASCII newline '\n' - then return acc - else loop (char : acc) - -readHieFileHeader :: FilePath -> BinHandle -> IO HieHeader -readHieFileHeader file bh0 = do - -- Read the header - magic <- replicateM hieMagicLen (get bh0) - version <- BSC.unpack <$> readBinLine bh0 - case maybeRead version of - Nothing -> - panic $ unwords ["readHieFileHeader: hieVersion isn't an Integer:" - , show version - ] - Just readHieVersion -> do - ghcVersion <- readBinLine bh0 - - -- Check if the header is valid - when (magic /= hieMagic) $ - panic $ unwords ["readHieFileHeader: headers don't match for file:" - , file - , "Expected" - , show hieMagic - , "but got", show magic - ] - return (readHieVersion, ghcVersion) - -readHieFileContents :: BinHandle -> NameCacheUpdater -> IO HieFile -readHieFileContents bh0 ncu = do - - dict <- get_dictionary bh0 - - -- read the symbol table so we are capable of reading the actual data - bh1 <- do - let bh1 = setUserData bh0 $ newReadState (error "getSymtabName") - (getDictFastString dict) - symtab <- get_symbol_table bh1 - let bh1' = setUserData bh1 - $ newReadState (getSymTabName symtab) - (getDictFastString dict) - return bh1' - - -- load the actual data - hiefile <- get bh1 - return hiefile - where - get_dictionary bin_handle = do - dict_p <- get bin_handle - data_p <- tellBin bin_handle - seekBin bin_handle dict_p - dict <- getDictionary bin_handle - seekBin bin_handle data_p - return dict - - get_symbol_table bh1 = do - symtab_p <- get bh1 - data_p' <- tellBin bh1 - seekBin bh1 symtab_p - symtab <- getSymbolTable bh1 ncu - seekBin bh1 data_p' - return symtab - -putFastString :: HieDictionary -> BinHandle -> FastString -> IO () -putFastString HieDictionary { hie_dict_next = j_r, - hie_dict_map = out_r} bh f - = do - out <- readIORef out_r - let unique = getUnique f - case lookupUFM out unique of - Just (j, _) -> put_ bh (fromIntegral j :: Word32) - Nothing -> do - j <- readFastMutInt j_r - put_ bh (fromIntegral j :: Word32) - writeFastMutInt j_r (j + 1) - writeIORef out_r $! addToUFM out unique (j, f) - -putSymbolTable :: BinHandle -> Int -> UniqFM (Int,HieName) -> IO () -putSymbolTable bh next_off symtab = do - put_ bh next_off - let names = A.elems (A.array (0,next_off-1) (nonDetEltsUFM symtab)) - mapM_ (putHieName bh) names - -getSymbolTable :: BinHandle -> NameCacheUpdater -> IO SymbolTable -getSymbolTable bh ncu = do - sz <- get bh - od_names <- replicateM sz (getHieName bh) - updateNameCache ncu $ \nc -> - let arr = A.listArray (0,sz-1) names - (nc', names) = mapAccumR fromHieName nc od_names - in (nc',arr) - -getSymTabName :: SymbolTable -> BinHandle -> IO Name -getSymTabName st bh = do - i :: Word32 <- get bh - return $ st A.! (fromIntegral i) - -putName :: HieSymbolTable -> BinHandle -> Name -> IO () -putName (HieSymbolTable next ref) bh name = do - symmap <- readIORef ref - case lookupUFM symmap name of - Just (off, ExternalName mod occ (UnhelpfulSpan _)) - | isGoodSrcSpan (nameSrcSpan name) -> do - let hieName = ExternalName mod occ (nameSrcSpan name) - writeIORef ref $! addToUFM symmap name (off, hieName) - put_ bh (fromIntegral off :: Word32) - Just (off, LocalName _occ span) - | notLocal (toHieName name) || nameSrcSpan name /= span -> do - writeIORef ref $! addToUFM symmap name (off, toHieName name) - put_ bh (fromIntegral off :: Word32) - Just (off, _) -> put_ bh (fromIntegral off :: Word32) - Nothing -> do - off <- readFastMutInt next - writeFastMutInt next (off+1) - writeIORef ref $! addToUFM symmap name (off, toHieName name) - put_ bh (fromIntegral off :: Word32) - - where - notLocal :: HieName -> Bool - notLocal LocalName{} = False - notLocal _ = True - - --- ** Converting to and from `HieName`'s - -toHieName :: Name -> HieName -toHieName name - | isKnownKeyName name = KnownKeyName (nameUnique name) - | isExternalName name = ExternalName (nameModule name) - (nameOccName name) - (nameSrcSpan name) - | otherwise = LocalName (nameOccName name) (nameSrcSpan name) - -fromHieName :: NameCache -> HieName -> (NameCache, Name) -fromHieName nc (ExternalName mod occ span) = - let cache = nsNames nc - in case lookupOrigNameCache cache mod occ of - Just name - | nameSrcSpan name == span -> (nc, name) - | otherwise -> - let name' = setNameLoc name span - new_cache = extendNameCache cache mod occ name' - in ( nc{ nsNames = new_cache }, name' ) - Nothing -> - let (uniq, us) = takeUniqFromSupply (nsUniqs nc) - name = mkExternalName uniq mod occ span - new_cache = extendNameCache cache mod occ name - in ( nc{ nsUniqs = us, nsNames = new_cache }, name ) -fromHieName nc (LocalName occ span) = - let (uniq, us) = takeUniqFromSupply (nsUniqs nc) - name = mkInternalName uniq occ span - in ( nc{ nsUniqs = us }, name ) -fromHieName nc (KnownKeyName u) = case lookupKnownKeyName u of - Nothing -> pprPanic "fromHieName:unknown known-key unique" - (ppr (unpkUnique u)) - Just n -> (nc, n) - --- ** Reading and writing `HieName`'s - -putHieName :: BinHandle -> HieName -> IO () -putHieName bh (ExternalName mod occ span) = do - putByte bh 0 - put_ bh (mod, occ, span) -putHieName bh (LocalName occName span) = do - putByte bh 1 - put_ bh (occName, span) -putHieName bh (KnownKeyName uniq) = do - putByte bh 2 - put_ bh $ unpkUnique uniq - -getHieName :: BinHandle -> IO HieName -getHieName bh = do - t <- getByte bh - case t of - 0 -> do - (modu, occ, span) <- get bh - return $ ExternalName modu occ span - 1 -> do - (occ, span) <- get bh - return $ LocalName occ span - 2 -> do - (c,i) <- get bh - return $ KnownKeyName $ mkUnique c i - _ -> panic "HieBin.getHieName: invalid tag" diff --git a/hls-graph/hls-graph.cabal b/hls-graph/hls-graph.cabal index 7593238b58..9f77ee2705 100644 --- a/hls-graph/hls-graph.cabal +++ b/hls-graph/hls-graph.cabal @@ -93,12 +93,11 @@ library template-haskell if flag(stm-stats) cpp-options: -DSTM_STATS - if impl(ghc >= 9) - ghc-options: -Wunused-packages ghc-options: -Wall -Wredundant-constraints -Wno-name-shadowing -Wno-unticked-promoted-constructors + -Wunused-packages if flag(pedantic) ghc-options: -Werror @@ -121,7 +120,7 @@ test-suite tests RulesSpec Spec - ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-ignore-asserts + ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-ignore-asserts -Wunused-packages build-depends: , base , containers @@ -139,5 +138,3 @@ test-suite tests , text , unordered-containers build-tool-depends: hspec-discover:hspec-discover -any - if impl(ghc >= 9) - ghc-options: -Wunused-packages diff --git a/hls-plugin-api/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index 379a8750a9..c1d9df63c8 100644 --- a/hls-plugin-api/hls-plugin-api.cabal +++ b/hls-plugin-api/hls-plugin-api.cabal @@ -86,11 +86,10 @@ library ghc-options: -Wall -Wredundant-constraints -Wno-name-shadowing -Wno-unticked-promoted-constructors + -Wunused-packages if flag(pedantic) ghc-options: -Werror - if impl(ghc >= 9) - ghc-options: -Wunused-packages if flag(use-fingertree) cpp-options: -DUSE_FINGERTREE diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index d057a317e5..7eca4f0321 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -25,7 +25,7 @@ module Ide.Plugin.Eval.CodeLens ( import Control.Applicative (Alternative ((<|>))) import Control.Arrow (second, (>>>)) -import Control.Exception (try, bracket_) +import Control.Exception (bracket_, try) import qualified Control.Exception as E import Control.Lens (_1, _3, ix, (%~), (<&>), (^.)) @@ -53,7 +53,8 @@ import Development.IDE.Core.RuleTypes (LinkableResult (l NeedsCompilation (NeedsCompilation), TypeCheck (..), tmrTypechecked) -import Development.IDE.Core.Shake (useWithStale_, useNoFile_, +import Development.IDE.Core.Shake (useNoFile_, + useWithStale_, use_, uses_) import Development.IDE.GHC.Compat hiding (typeKind, unitState) @@ -62,7 +63,8 @@ import Development.IDE.GHC.Compat.Util (GhcException, import Development.IDE.GHC.Util (evalGhcEnv, modifyDynFlags, printOutputable) -import Development.IDE.Import.DependencyInformation (transitiveDeps, transitiveModuleDeps) +import Development.IDE.Import.DependencyInformation (transitiveDeps, + transitiveModuleDeps) import Development.IDE.Types.Location (toNormalizedFilePath', uriToFilePath') import GHC (ClsInst, @@ -82,9 +84,9 @@ import GHC (ClsInst, typeKind) -import Development.IDE.Core.RuleTypes (GetModuleGraph (GetModuleGraph), - GetLinkable (GetLinkable), +import Development.IDE.Core.RuleTypes (GetLinkable (GetLinkable), GetModSummary (GetModSummary), + GetModuleGraph (GetModuleGraph), GhcSessionDeps (GhcSessionDeps), ModSummaryResult (msrModSummary)) import Development.IDE.Core.Shake (VFSModified (VFSUnmodified)) @@ -99,9 +101,7 @@ import qualified GHC.LanguageExtensions.Type as LangExt (Extens import Development.IDE.Core.FileStore (setSomethingModified) import Development.IDE.Core.PluginUtils import Development.IDE.Types.Shake (toKey) -#if MIN_VERSION_ghc(9,0,0) import GHC.Types.SrcLoc (UnhelpfulSpanReason (UnhelpfulInteractive)) -#endif import Ide.Plugin.Error (PluginError (PluginInternalError), handleMaybe, handleMaybeM) @@ -120,7 +120,8 @@ import Ide.Plugin.Eval.GHC (addImport, showDynFlags) import Ide.Plugin.Eval.Parse.Comments (commentsToSections) import Ide.Plugin.Eval.Parse.Option (parseSetFlags) -import Ide.Plugin.Eval.Rules (queueForEvaluation, unqueueForEvaluation) +import Ide.Plugin.Eval.Rules (queueForEvaluation, + unqueueForEvaluation) import Ide.Plugin.Eval.Types import Ide.Plugin.Eval.Util (gStrictTry, isLiterate, @@ -491,11 +492,7 @@ evals mark_exception (st, fp) df stmts = do void $ runDecls stmt return Nothing pf = initParserOpts df -#if !MIN_VERSION_ghc(9,0,0) - unhelpfulReason = "" -#else unhelpfulReason = UnhelpfulInteractive -#endif exec stmt l = let opts = execOptions{execSourceFile = fp, execLineNumber = l} in myExecStmt stmt opts diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs index e2d38775be..c198962b17 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs @@ -102,18 +102,12 @@ apiAnnComments' pm = do pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcLoc.RealSrcSpan pattern RealSrcSpanAlready x = x -#elif MIN_VERSION_ghc(9,0,0) +#else apiAnnComments' :: ParsedModule -> [SrcLoc.RealLocated AnnotationComment] apiAnnComments' = apiAnnRogueComments . pm_annotations pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcLoc.RealSrcSpan pattern RealSrcSpanAlready x = x -#else -apiAnnComments' :: ParsedModule -> [SrcLoc.Located AnnotationComment] -apiAnnComments' = concat . Map.elems . snd . pm_annotations - -pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcSpan -pattern RealSrcSpanAlready x = SrcLoc.RealSrcSpan x Nothing #endif evalParsedModuleRule :: Recorder (WithPriority Log) -> Rules () 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 13864da29a..7b944a722d 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -398,9 +398,6 @@ extractMinimalImports hsc TcModuleResult {..} = runMaybeT $ do notExported [] _ = True notExported exports (L _ ImportDecl{ideclName = L _ name}) = not $ any (\e -> ("module " ++ moduleNameString name) == e) exports -#if !MIN_VERSION_ghc (9,0,0) - notExported _ _ = True -#endif isExplicitImport :: ImportDecl GhcRn -> Bool #if MIN_VERSION_ghc (9,5,0) 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 a093349383..eb0ee1c5e3 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 @@ -85,10 +85,8 @@ import Language.LSP.Protocol.Types (CodeAction (..), WorkspaceEdit (WorkspaceEdit), type (|?) (InL, InR)) -#if MIN_VERSION_ghc(9,0,0) import Development.IDE.GHC.Compat (HsExpansion (HsExpanded), HsExpr (XExpr)) -#endif data Log = LogShake Shake.Log @@ -364,10 +362,7 @@ getRecCons :: LHsExpr (GhcPass 'Renamed) -> ([RecordInfo], Bool) -- because there is a possibility that there were be more than one result per -- branch -#if MIN_VERSION_ghc(9,0,0) 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/GADT.hs b/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs index 761eab7a5c..6146ae2ee7 100644 --- a/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs +++ b/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs @@ -15,8 +15,7 @@ import Control.Monad.Error.Class (MonadError (throwError), liftEither) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Class (MonadTrans (lift)) -import Control.Monad.Trans.Except (ExceptT, runExceptT, - withExceptT) +import Control.Monad.Trans.Except (ExceptT, withExceptT) import Data.Aeson (FromJSON, ToJSON, toJSON) import Data.Either.Extra (maybeToEither) import qualified Data.Map as Map diff --git a/plugins/hls-gadt-plugin/src/Ide/Plugin/GHC.hs b/plugins/hls-gadt-plugin/src/Ide/Plugin/GHC.hs index fecb8def47..a2d3e4364c 100644 --- a/plugins/hls-gadt-plugin/src/Ide/Plugin/GHC.hs +++ b/plugins/hls-gadt-plugin/src/Ide/Plugin/GHC.hs @@ -30,11 +30,10 @@ import GHC.Parser.Annotation (AddEpAnn (..), EpAnnComments (EpaComments), EpaLocation (EpaDelta), SrcSpanAnn' (SrcSpanAnn), - spanAsAnchor, + spanAsAnchor) #if MIN_VERSION_ghc(9,5,0) - TokenLocation(..) +import GHC.Parser.Annotation (TokenLocation (..)) #endif - ) import Language.Haskell.GHC.ExactPrint (showAst) #else import qualified Data.Map.Lazy as Map @@ -311,18 +310,11 @@ mapX = fmap noUsed = noExtField #endif -#if MIN_VERSION_ghc(9,0,1) pattern UserTyVar' :: LIdP pass -> HsTyVarBndr flag pass pattern UserTyVar' s <- UserTyVar _ _ s -#else -pattern UserTyVar' :: LIdP pass -> HsTyVarBndr pass -pattern UserTyVar' s <- UserTyVar _ s -#endif #if MIN_VERSION_ghc(9,2,1) implicitTyVars = (wrapXRec @GP mkHsOuterImplicit) -#elif MIN_VERSION_ghc(9,0,1) -implicitTyVars = [] #else -implicitTyVars = HsQTvs noExtField [] +implicitTyVars = [] #endif 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 944f170468..ca3d6a843d 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs @@ -11,11 +11,7 @@ import Development.IDE.GHC.Compat.Util import Generics.SYB (ext1Q, ext2Q, extQ) import GHC.Hs hiding (AnnLet) #endif -#if MIN_VERSION_ghc(9,0,1) import GHC.Plugins hiding (AnnLet) -#else -import GhcPlugins -#endif import Prelude hiding ((<>)) -- | Show a GHC syntax tree in HTML. 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 c6615aa334..3698300138 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -1102,14 +1102,10 @@ suggestImportDisambiguation df (Just txt) ps fileContents diag@Diagnostic {..} , mode <- [ ToQualified parensed qual | ExistingImp imps <- [modTarget] -#if MIN_VERSION_ghc(9,0,0) {- HLINT ignore suggestImportDisambiguation "Use nubOrd" -} -- TODO: The use of nub here is slow and maybe wrong for UnhelpfulLocation -- nubOrd can't be used since SrcSpan is intentionally no Ord , L _ qual <- nub $ mapMaybe (ideclAs . unLoc) -#else - , L _ qual <- nubOrd $ mapMaybe (ideclAs . unLoc) -#endif $ NE.toList imps ] ++ [ToQualified parensed modName diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs index ac7fe1a7cd..31d3de21cc 100644 --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -1731,7 +1731,7 @@ suggestImportTests = testGroup "suggest import actions" suggestAddRecordFieldImportTests :: TestTree suggestAddRecordFieldImportTests = testGroup "suggest imports of record fields when using OverloadedRecordDot" [ testGroup "The field is suggested when an instance resolution failure occurs" - [ ignoreFor (BrokenForGHC [GHC810, GHC90, GHC94, GHC96]) "Extension not present <9.2, and the assist is derived from the help message in >=9.4" theTest + [ ignoreFor (BrokenForGHC [GHC90, GHC94, GHC96]) "Extension not present <9.2, and the assist is derived from the help message in >=9.4" theTest ] ] where diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index 0b71671b01..69f479f41d 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -539,11 +539,7 @@ codeAction state plId (CodeActionParams _ _ docId ran _) = do _ -> Stop ) `extQ` \case -#if __GLASGOW_HASKELL__ == 808 - (dL @(Pat GhcPs) -> L l@(RealSrcSpan spLoc _) pat :: Located (Pat GhcPs)) -#else (L (AsSrcSpan l@(RealSrcSpan spLoc _)) pat :: LPat GhcPs) -#endif | spanIsRelevant l -> case pat of SplicePat{} -> Here (spLoc, Pat) diff --git a/test/functional/Completion.hs b/test/functional/Completion.hs index 548d00260c..111328207e 100644 --- a/test/functional/Completion.hs +++ b/test/functional/Completion.hs @@ -377,4 +377,4 @@ compls `shouldNotContainCompl` lbl = @? "Should not contain completion: " ++ show lbl expectFailIfBeforeGhc92 :: String -> TestTree -> TestTree -expectFailIfBeforeGhc92 = knownBrokenForGhcVersions [GHC810, GHC90] +expectFailIfBeforeGhc92 = knownBrokenForGhcVersions [GHC90] diff --git a/test/wrapper/Main.hs b/test/wrapper/Main.hs index ca652bbf0f..4879d23603 100644 --- a/test/wrapper/Main.hs +++ b/test/wrapper/Main.hs @@ -9,7 +9,7 @@ main = defaultTestRunner $ testGroup "haskell-language-server-wrapper" [projectG projectGhcVersionTests :: TestTree projectGhcVersionTests = testGroup "--project-ghc-version" - [ stackTest "8.10.7" + [ stackTest "9.2.8" , testCase "cabal with global ghc" $ do ghcVer <- trimEnd <$> readProcess "ghc" ["--numeric-version"] "" testDir "test/wrapper/testdata/cabal-cur-ver" ghcVer diff --git a/test/wrapper/testdata/stack-8.10.7/stack.yaml b/test/wrapper/testdata/stack-8.10.7/stack.yaml deleted file mode 100644 index c2e49d8e85..0000000000 --- a/test/wrapper/testdata/stack-8.10.7/stack.yaml +++ /dev/null @@ -1 +0,0 @@ -resolver: ghc-8.10.7 diff --git a/test/wrapper/testdata/stack-8.10.7/Lib.hs b/test/wrapper/testdata/stack-9.2.8/Lib.hs similarity index 100% rename from test/wrapper/testdata/stack-8.10.7/Lib.hs rename to test/wrapper/testdata/stack-9.2.8/Lib.hs diff --git a/test/wrapper/testdata/stack-8.10.7/foo.cabal b/test/wrapper/testdata/stack-9.2.8/foo.cabal similarity index 100% rename from test/wrapper/testdata/stack-8.10.7/foo.cabal rename to test/wrapper/testdata/stack-9.2.8/foo.cabal diff --git a/test/wrapper/testdata/stack-9.2.8/stack.yaml b/test/wrapper/testdata/stack-9.2.8/stack.yaml new file mode 100644 index 0000000000..4324da7693 --- /dev/null +++ b/test/wrapper/testdata/stack-9.2.8/stack.yaml @@ -0,0 +1 @@ +resolver: ghc-9.2.8 diff --git a/test/wrapper/testdata/stack-with-dist-newstyle/stack.yaml b/test/wrapper/testdata/stack-with-dist-newstyle/stack.yaml index 500890e54c..e467bdb282 100644 --- a/test/wrapper/testdata/stack-with-dist-newstyle/stack.yaml +++ b/test/wrapper/testdata/stack-with-dist-newstyle/stack.yaml @@ -1,2 +1,2 @@ # specific version does not matter -resolver: ghc-8.10.7 +resolver: ghc-9.2.5