diff --git a/ghcide.cabal b/ghcide.cabal --- a/ghcide.cabal +++ b/ghcide.cabal @@ -2,7 +2,7 @@ build-type: Simple category: Development name: ghcide -version: 1.4.2.0 +version: 1.4.2.1 license: Apache-2.0 license-file: LICENSE author: Digital Asset and Ghcide contributors @@ -13,7 +13,7 @@ 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.6.4 || == 8.6.5 || == 8.8.3 || == 8.8.4 || == 8.10.2 || == 8.10.3 || == 8.10.4 || == 8.10.5 || == 8.10.6 || == 8.10.7 || == 9.0.1 +tested-with: GHC == 8.6.5 || == 8.8.3 || == 8.8.4 || == 8.10.5 || == 8.10.6 || == 8.10.7 || == 9.0.1 extra-source-files: README.md CHANGELOG.md test/data/**/*.project test/data/**/*.cabal @@ -61,9 +61,10 @@ hie-compat ^>= 0.2.0.0, hls-plugin-api ^>= 1.2.0.0, lens, - hiedb == 0.4.0.*, + hiedb == 0.4.1.*, lsp-types >= 1.3.0.1 && < 1.4, lsp == 1.2.*, + monoid-subclasses, mtl, network-uri, optparse-applicative, @@ -86,6 +87,7 @@ unordered-containers >= 0.2.10.0, utf8-string, vector, + vector-algorithms, hslogger, Diff ^>=0.4.0, vector, @@ -110,22 +112,6 @@ build-depends: unix - if impl(ghc < 8.10.5) - build-depends: - ghc-api-compat ==8.6 - elif impl(ghc == 8.10.5) - build-depends: - ghc-api-compat ==8.10.5 - elif impl(ghc == 8.10.6) - build-depends: - ghc-api-compat ==8.10.6 - elif impl(ghc == 8.10.7) - build-depends: - ghc-api-compat ==8.10.7 - elif impl(ghc == 9.0.1) - build-depends: - ghc-api-compat ==9.0.1 - default-extensions: ApplicativeDo BangPatterns @@ -171,6 +157,15 @@ Development.IDE.Core.Tracing Development.IDE.Core.UseStale Development.IDE.GHC.Compat + Development.IDE.GHC.Compat.Core + Development.IDE.GHC.Compat.Env + Development.IDE.GHC.Compat.Iface + Development.IDE.GHC.Compat.Logger + Development.IDE.GHC.Compat.Outputable + Development.IDE.GHC.Compat.Parser + Development.IDE.GHC.Compat.Plugins + Development.IDE.GHC.Compat.Units + Development.IDE.GHC.Compat.Util Development.IDE.Core.Compile Development.IDE.GHC.Error Development.IDE.GHC.ExactPrint @@ -215,11 +210,21 @@ Development.IDE.Plugin.Completions.Logic Development.IDE.Session.VersionCheck Development.IDE.Types.Action + Text.Fuzzy.Parallel + ghc-options: -Wall -Wno-name-shadowing -Wincomplete-uni-patterns -Wno-unticked-promoted-constructors if flag(ghc-patched-unboxed-bytecode) cpp-options: -DGHC_PATCHED_UNBOXED_BYTECODE + if impl(ghc < 8.10) + exposed-modules: + Development.IDE.GHC.Compat.CPP + +flag test-exe + description: Build the ghcide-test-preprocessor executable + default: True + executable ghcide-test-preprocessor default-language: Haskell2010 hs-source-dirs: test/preprocessor @@ -228,6 +233,9 @@ build-depends: base == 4.* + if !flag(test-exe) + buildable: False + benchmark benchHist type: exitcode-stdio-1.0 default-language: Haskell2010 @@ -266,6 +274,10 @@ text, yaml +flag executable + description: Build the ghcide executable + default: True + executable ghcide default-language: Haskell2010 hs-source-dirs: exe @@ -325,6 +337,9 @@ TypeApplications ViewPatterns + if !flag(executable) + buildable: False + test-suite ghcide-tests type: exitcode-stdio-1.0 default-language: Haskell2010 @@ -407,6 +422,10 @@ TypeApplications ViewPatterns +flag bench-exe + description: Build the ghcide-bench executable + default: True + executable ghcide-bench default-language: Haskell2010 build-tool-depends: @@ -451,3 +470,6 @@ TupleSections TypeApplications ViewPatterns + + if !flag(bench-exe) + buildable: False diff --git a/session-loader/Development/IDE/Session.hs b/session-loader/Development/IDE/Session.hs --- a/session-loader/Development/IDE/Session.hs +++ b/session-loader/Development/IDE/Session.hs @@ -19,7 +19,7 @@ import Control.Concurrent.Async import Control.Concurrent.Strict -import Control.Exception.Safe +import Control.Exception.Safe as Safe import Control.Monad import Control.Monad.Extra import Control.Monad.IO.Class @@ -42,9 +42,13 @@ import Data.Version import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake -import Development.IDE.GHC.Compat hiding (Target, - TargetFile, TargetModule) -import qualified Development.IDE.GHC.Compat as GHC +import qualified Development.IDE.GHC.Compat as Compat +import Development.IDE.GHC.Compat.Core hiding (Target, + TargetFile, TargetModule, + Var) +import qualified Development.IDE.GHC.Compat.Core as GHC +import Development.IDE.GHC.Compat.Env hiding (Logger) +import Development.IDE.GHC.Compat.Units (UnitId) import Development.IDE.GHC.Util import Development.IDE.Graph (Action) import Development.IDE.Session.VersionCheck @@ -71,12 +75,6 @@ import Control.Applicative (Alternative ((<|>))) import Control.Exception (evaluate) import Data.Void -import GHCi -import HscTypes (hsc_IC, hsc_NC, - hsc_dflags, ic_dflags) -import Linker -import Module -import NameCache import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TQueue @@ -105,7 +103,7 @@ , getCacheDirs :: String -> [String] -> IO CacheDirs -- | Return the GHC lib dir to use for the 'unsafeGlobalDynFlags' , getInitialGhcLibDir :: FilePath -> IO (Maybe LibDir) - , fakeUid :: GHC.InstalledUnitId + , fakeUid :: UnitId -- ^ unit id used to tag the internal component built by ghcide -- To reuse external interface files the unit ids must match, -- thus make sure to build them with `--this-unit-id` set to the @@ -118,7 +116,7 @@ ,loadCradle = loadWithImplicitCradle ,getCacheDirs = getCacheDirsDefault ,getInitialGhcLibDir = getInitialGhcLibDirDefault - ,fakeUid = GHC.toInstalledUnitId (GHC.stringToUnit "main") + ,fakeUid = Compat.toUnitId (Compat.stringToUnit "main") } -- | Find the cradle for a given 'hie.yaml' configuration. @@ -173,7 +171,7 @@ runWithDb fp k = do -- Delete the database if it has an incompatible schema version withHieDb fp (const $ pure ()) - `catch` \IncompatibleSchemaVersion{} -> removeFile fp + `Safe.catch` \IncompatibleSchemaVersion{} -> removeFile fp withHieDb fp $ \writedb -> do initConn writedb chan <- newTQueueIO @@ -187,15 +185,15 @@ forever $ do k <- atomically $ readTQueue chan k db - `catch` \e@SQLError{} -> do + `Safe.catch` \e@SQLError{} -> do hPutStrLn stderr $ "SQLite error in worker, ignoring: " ++ show e - `catchAny` \e -> do + `Safe.catchAny` \e -> do hPutStrLn stderr $ "Uncaught error in database worker, ignoring: " ++ show e getHieDbLoc :: FilePath -> IO FilePath getHieDbLoc dir = do - let db = intercalate "-" [dirHash, takeBaseName dir, ghcVersionStr, hiedbDataVersion] <.> "hiedb" + let db = intercalate "-" [dirHash, takeBaseName dir, Compat.ghcVersionStr, hiedbDataVersion] <.> "hiedb" dirHash = B.unpack $ B16.encode $ H.hash $ B.pack dir cDir <- IO.getXdgDirectory IO.XdgCache cacheDir createDirectoryIfMissing True cDir @@ -297,7 +295,7 @@ -- We will modify the unitId and DynFlags used for -- compilation but these are the true source of -- information. - new_deps = RawComponentInfo (thisInstalledUnitId df) df targets cfp opts dep_info + new_deps = RawComponentInfo (homeUnitId_ df) df targets cfp opts dep_info : maybe [] snd oldDeps -- Get all the unit-ids for things in this component inplace = map rawComponentUnitId new_deps @@ -482,7 +480,7 @@ ncfp <- toNormalizedFilePath' <$> canonicalizePath file cachedHieYamlLocation <- HM.lookup ncfp <$> readVar filesMap hieYaml <- cradleLoc file - sessionOpts (join cachedHieYamlLocation <|> hieYaml, file) `catch` \e -> + sessionOpts (join cachedHieYamlLocation <|> hieYaml, file) `Safe.catch` \e -> return (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml) returnWithVersion $ \file -> do @@ -522,11 +520,11 @@ emptyHscEnv :: IORef NameCache -> FilePath -> IO HscEnv emptyHscEnv nc libDir = do env <- runGhc (Just libDir) getSession - when (ghcVersion < GHC90) $ + when (Compat.ghcVersion < Compat.GHC90) $ -- This causes ghc9 to crash with the error: -- Couldn't find a target code interpreter. Try with -fexternal-interpreter initDynLinker env - pure $ setNameCache nc env{ hsc_dflags = (hsc_dflags env){useUnicode = True } } + pure $ setNameCache nc (hscSetFlags ((hsc_dflags env){useUnicode = True }) env) data TargetDetails = TargetDetails { @@ -571,13 +569,13 @@ -> Maybe FilePath -- Path to cradle -> NormalizedFilePath -- Path to file that caused the creation of this component -> HscEnv - -> [(InstalledUnitId, DynFlags)] + -> [(UnitId, DynFlags)] -> ComponentInfo -> IO ( [TargetDetails], (IdeResult HscEnvEq, DependencyInfo)) newComponentCache logger exts cradlePath cfp hsc_env uids ci = do let df = componentDynFlags ci - let hscEnv' = hsc_env { hsc_dflags = df - , hsc_IC = (hsc_IC hsc_env) { ic_dflags = df } } + let hscEnv' = hscSetFlags df hsc_env + { hsc_IC = (hsc_IC hsc_env) { ic_dflags = df } } let newFunc = maybe newHscEnvEqPreserveImportPaths newHscEnvEq cradlePath henv <- newFunc hscEnv' uids @@ -676,7 +674,7 @@ -- This is pristine information about a component data RawComponentInfo = RawComponentInfo - { rawComponentUnitId :: InstalledUnitId + { rawComponentUnitId :: UnitId -- | Unprocessed DynFlags. Contains inplace packages such as libraries. -- We do not want to use them unprocessed. , rawComponentDynFlags :: DynFlags @@ -693,14 +691,14 @@ -- This is processed information about the component, in particular the dynflags will be modified. data ComponentInfo = ComponentInfo - { componentUnitId :: InstalledUnitId + { componentUnitId :: UnitId -- | Processed DynFlags. Does not contain inplace packages such as local -- libraries. Can be used to actually load this Component. , componentDynFlags :: DynFlags -- | Internal units, such as local libraries, that this component -- is loaded with. These have been extracted from the original -- ComponentOptions. - , _componentInternalUnits :: [InstalledUnitId] + , _componentInternalUnits :: [UnitId] -- | All targets of this components. , componentTargets :: [GHC.Target] -- | Filepath which caused the creation of this component @@ -733,7 +731,7 @@ where tryIO :: IO a -> IO (Either IOException a) - tryIO = try + tryIO = Safe.try do_one :: FilePath -> IO (FilePath, Maybe UTCTime) do_one fp = (fp,) . eitherToMaybe <$> tryIO (getModificationTime fp) @@ -747,18 +745,14 @@ -- tcRnImports) which assume that all modules in the HPT have the same unit -- ID. Therefore we create a fake one and give them all the same unit id. removeInplacePackages - :: InstalledUnitId -- ^ fake uid to use for our internal component - -> [InstalledUnitId] + :: UnitId -- ^ fake uid to use for our internal component + -> [UnitId] -> DynFlags - -> (DynFlags, [InstalledUnitId]) -removeInplacePackages fake_uid us df = (setThisInstalledUnitId fake_uid $ + -> (DynFlags, [UnitId]) +removeInplacePackages fake_uid us df = (setHomeUnitId_ fake_uid $ df { packageFlags = ps }, uids) where - (uids, ps) = partitionEithers (map go (packageFlags df)) - go p@(ExposePackage _ (UnitIdArg u) _) = if GHC.toInstalledUnitId u `elem` us - then Left (GHC.toInstalledUnitId u) - else Right p - go p = Right p + (uids, ps) = Compat.filterInplaceUnits us (packageFlags df) -- | Memoize an IO function, with the characteristics: -- @@ -790,25 +784,16 @@ -- also, it can confuse the interface stale check dontWriteHieFiles $ setIgnoreInterfacePragmas $ - setLinkerOptions $ + setBytecodeLinkerOptions $ disableOptimisation $ - setUpTypedHoles $ + Compat.setUpTypedHoles $ makeDynFlagsAbsolute compRoot dflags' -- initPackages parses the -package flags and -- sets up the visibility for each component. -- Throws if a -package flag cannot be satisfied. - final_df <- liftIO $ wrapPackageSetupException $ initUnits dflags'' - return (final_df, targets) - --- we don't want to generate object code so we compile to bytecode --- (HscInterpreted) which implies LinkInMemory --- HscInterpreted -setLinkerOptions :: DynFlags -> DynFlags -setLinkerOptions df = df { - ghcLink = LinkInMemory - , hscTarget = HscNothing - , ghcMode = CompManager - } + env <- hscSetFlags dflags'' <$> getSession + final_env' <- liftIO $ wrapPackageSetupException $ Compat.initUnits env + return (hsc_dflags final_env', targets) setIgnoreInterfacePragmas :: DynFlags -> DynFlags setIgnoreInterfacePragmas df = diff --git a/src/Development/IDE/Core/Actions.hs b/src/Development/IDE/Core/Actions.hs --- a/src/Development/IDE/Core/Actions.hs +++ b/src/Development/IDE/Core/Actions.hs @@ -23,17 +23,12 @@ import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service import Development.IDE.Core.Shake -import Development.IDE.GHC.Compat hiding (TargetFile, - TargetModule, - parseModule, - typecheckModule, - writeHieFile) +import Development.IDE.GHC.Compat hiding (writeHieFile) import Development.IDE.Graph import qualified Development.IDE.Spans.AtPoint as AtPoint import Development.IDE.Types.HscEnvEq (hscEnv) import Development.IDE.Types.Location import qualified HieDb -import HscTypes (hsc_dflags) import Language.LSP.Types (DocumentHighlight (..), SymbolInformation (..)) @@ -44,7 +39,7 @@ :: HieDbWriter -- ^ access the database -> FilePath -- ^ The `.hie` file we got from the database -> ModuleName - -> UnitId + -> Unit -> Bool -- ^ Is this file a boot file? -> MaybeT IdeAction Uri lookupMod _dbchan _hie_f _mod _uid _boot = MaybeT $ pure Nothing @@ -64,11 +59,11 @@ opts <- liftIO $ getIdeOptionsIO ide (hf, mapping) <- useE GetHieAst file - df <- hsc_dflags . hscEnv . fst <$> useE GhcSession file + env <- hscEnv . fst <$> useE GhcSession file dkMap <- lift $ maybe (DKMap mempty mempty) fst <$> runMaybeT (useE GetDocMap file) !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) - MaybeT $ pure $ first (toCurrentRange mapping =<<) <$> AtPoint.atPoint opts hf dkMap df pos' + MaybeT $ pure $ first (toCurrentRange mapping =<<) <$> AtPoint.atPoint opts hf dkMap env pos' toCurrentLocations :: PositionMapping -> [Location] -> [Location] toCurrentLocations mapping = mapMaybe go diff --git a/src/Development/IDE/Core/Compile.hs b/src/Development/IDE/Core/Compile.hs --- a/src/Development/IDE/Core/Compile.hs +++ b/src/Development/IDE/Core/Compile.hs @@ -43,19 +43,18 @@ import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import Development.IDE.Types.Options -import Outputable hiding ((<>)) +import Development.IDE.GHC.Compat hiding (loadInterface, + parseHeader, parseModule, + tcRnModule, writeHieFile) +import qualified Development.IDE.GHC.Compat as Compat +import qualified Development.IDE.GHC.Compat as GHC +import qualified Development.IDE.GHC.Compat.Util as Util + import HieDb import Language.LSP.Types (DiagnosticTag (..)) -import DriverPhases -import DriverPipeline hiding (unP) -import HscTypes -import LoadIface (loadModuleInterface) - -import Lexer -import qualified Parser #if MIN_VERSION_ghc(8,10,0) import Control.DeepSeq (force, rnf) #else @@ -63,35 +62,13 @@ import ErrUtils #endif -import Development.IDE.GHC.Compat hiding (parseModule, - typecheckModule, - writeHieFile) -import qualified Development.IDE.GHC.Compat as Compat -import qualified Development.IDE.GHC.Compat as GHC -import Finder -import GhcMonad -import GhcPlugins as GHC hiding (fst3, (<>)) -import Hooks -import HscMain (hscDesugar, hscGenHardCode, - hscInteractive, hscSimplify, - hscTypecheckRename, - makeSimpleDetails) -import MkIface -import StringBuffer as SB -import TcIface (typecheckIface) -import TcRnMonad hiding (newUnique) + #if MIN_VERSION_ghc(9,0,1) -import GHC.Builtin.Names -import GHC.Iface.Recomp import GHC.Tc.Gen.Splice -import GHC.Tc.Types.Evidence (EvBind) #else -import PrelNames import TcSplice #endif -import TidyPgm -import Bag import Control.Exception (evaluate) import Control.Exception.Safe import Control.Lens hiding (List) @@ -108,14 +85,14 @@ import qualified Data.Text as T import Data.Time (UTCTime, getCurrentTime) import qualified GHC.LanguageExtensions as LangExt -import HeaderInfo -import Linker (unload) -import Maybes (orElse) import System.Directory import System.FilePath import System.IO.Extra (fixIO, newTempFileWithin) -import TcEnv (tcLookup) +-- GHC API imports +import GHC (GetDocsFailure (..), + parsedSource) + import Control.Concurrent.Extra import Control.Concurrent.STM hiding (orElse) import Data.Aeson (toJSON) @@ -124,8 +101,7 @@ import Data.Functor import qualified Data.HashMap.Strict as HashMap import Data.Tuple.Extra (dupe) -import Data.Unique -import GHC.Fingerprint +import Data.Unique as Unique import qualified Language.LSP.Server as LSP import qualified Language.LSP.Types as LSP @@ -146,11 +122,10 @@ -- | Given a package identifier, what packages does it depend on computePackageDeps :: HscEnv - -> InstalledUnitId - -> IO (Either [FileDiagnostic] [InstalledUnitId]) + -> Unit + -> IO (Either [FileDiagnostic] [UnitId]) computePackageDeps env pkg = do - let dflags = hsc_dflags env - case oldLookupInstalledPackage dflags pkg of + case lookupUnit env pkg of Nothing -> return $ Left [ideErrorText (toNormalizedFilePath' noFilePath) $ T.pack $ "unknown package: " ++ show pkg] Just pkgInfo -> return $ Right $ unitDepends pkgInfo @@ -169,7 +144,12 @@ modSummary' <- initPlugins hsc modSummary (warnings, tcm) <- withWarnings "typecheck" $ \tweak -> - tcRnModule hsc keep_lbls $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'} + let + session = tweak (hscSetFlags dflags hsc) + -- TODO: maybe settings ms_hspp_opts is unnecessary? + mod_summary'' = modSummary' { ms_hspp_opts = hsc_dflags session} + in + tcRnModule hsc keep_lbls $ demoteIfDefer pm{pm_mod_summary = mod_summary''} let errorPipeline = unDefer . hideDiag dflags . tagDiag diags = map errorPipeline warnings deferedError = any fst diags @@ -180,10 +160,10 @@ -- | Add a Hook to the DynFlags which captures and returns the -- typechecked splices before they are run. This information -- is used for hover. -captureSplices :: DynFlags -> (DynFlags -> IO a) -> IO (a, Splices) -captureSplices dflags k = do +captureSplices :: HscEnv -> (HscEnv -> IO a) -> IO (a, Splices) +captureSplices env k = do splice_ref <- newIORef mempty - res <- k (dflags { hooks = addSpliceHook splice_ref (hooks dflags)}) + res <- k (hscSetHooks (addSpliceHook splice_ref (hsc_hooks env)) env) splices <- readIORef splice_ref return (res, splices) where @@ -217,14 +197,13 @@ tcRnModule :: HscEnv -> [Linkable] -> ParsedModule -> IO TcModuleResult tcRnModule hsc_env keep_lbls pmod = do let ms = pm_mod_summary pmod - hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } + hsc_env_tmp = hscSetFlags (ms_hspp_opts ms) hsc_env unload hsc_env_tmp keep_lbls ((tc_gbl_env, mrn_info), splices) - <- liftIO $ captureSplices (ms_hspp_opts ms) $ \dflags -> - do let hsc_env_tmp = hsc_env { hsc_dflags = dflags } - hscTypecheckRename hsc_env_tmp ms $ + <- liftIO $ captureSplices (hscSetFlags (ms_hspp_opts ms) hsc_env) $ \hsc_env_tmp -> + do hscTypecheckRename hsc_env_tmp ms $ HsParsedModule { hpm_module = parsedSource pmod, hpm_src_files = pm_extra_src_files pmod, hpm_annotations = pm_annotations pmod } @@ -235,7 +214,7 @@ mkHiFileResultNoCompile :: HscEnv -> TcModuleResult -> IO HiFileResult mkHiFileResultNoCompile session tcm = do - let hsc_env_tmp = session { hsc_dflags = ms_hspp_opts ms } + let hsc_env_tmp = hscSetFlags (ms_hspp_opts ms) session ms = pm_mod_summary $ tmrParsed tcm tcGblEnv = tmrTypechecked tcm details <- makeSimpleDetails hsc_env_tmp tcGblEnv @@ -255,7 +234,7 @@ -> LinkableType -- ^ use object code or byte code? -> IO (IdeResult HiFileResult) mkHiFileResultCompile session' tcm simplified_guts ltype = catchErrs $ do - let session = session' { hsc_dflags = ms_hspp_opts ms } + let session = hscSetFlags (ms_hspp_opts ms) session' ms = pm_mod_summary $ tmrParsed tcm tcGblEnv = tmrTypechecked tcm @@ -297,8 +276,8 @@ initPlugins :: HscEnv -> ModSummary -> IO ModSummary initPlugins session modSummary = do - dflags <- liftIO $ initializePlugins session $ ms_hspp_opts modSummary - return modSummary{ms_hspp_opts = dflags} + session1 <- liftIO $ initializePlugins (hscSetFlags (ms_hspp_opts modSummary) session) + return modSummary{ms_hspp_opts = hsc_dflags session1} -- | Whether we should run the -O0 simplifier when generating core. -- @@ -318,9 +297,9 @@ fmap (either (, Nothing) (second Just)) $ catchSrcErrors (hsc_dflags session) "compile" $ do (warnings,desugared_guts) <- withWarnings "compile" $ \tweak -> do - let ms' = tweak ms - session' = session{ hsc_dflags = ms_hspp_opts ms'} - desugar <- hscDesugar session' ms' tcg + let session' = tweak (hscSetFlags (ms_hspp_opts ms) session) + -- TODO: maybe settings ms_hspp_opts is unnecessary? + desugar <- hscDesugar session' (ms { ms_hspp_opts = hsc_dflags session' }) tcg if simplify then do plugins <- readIORef (tcg_th_coreplugins tcg) @@ -337,23 +316,20 @@ fp = replaceExtension dot_o "s" createDirectoryIfMissing True (takeDirectory fp) (warnings, dot_o_fp) <- - withWarnings "object" $ \_tweak -> do - let summary' = _tweak summary -#if MIN_VERSION_ghc(8,10,0) - target = defaultObjectTarget $ hsc_dflags session -#else - target = defaultObjectTarget $ targetPlatform $ hsc_dflags session -#endif - session' = session { hsc_dflags = updOptLevel 0 $ (ms_hspp_opts summary') { outputFile = Just dot_o , hscTarget = target}} + withWarnings "object" $ \tweak -> do + let env' = tweak (hscSetFlags (ms_hspp_opts summary) session) + target = platformDefaultBackend (hsc_dflags env') + newFlags = setBackend target $ updOptLevel 0 $ (hsc_dflags env') { outputFile = Just dot_o } + session' = hscSetFlags newFlags session #if MIN_VERSION_ghc(9,0,1) (outputFilename, _mStub, _foreign_files, _cinfos) <- hscGenHardCode session' guts #else (outputFilename, _mStub, _foreign_files) <- hscGenHardCode session' guts #endif #if MIN_VERSION_ghc(8,10,0) - (ms_location summary') + (ms_location summary) #else - summary' + summary #endif fp compileFile session' StopLn (outputFilename, Just (As False)) @@ -370,8 +346,9 @@ catchSrcErrors (hsc_dflags hscEnv) "bytecode" $ do (warnings, (_, bytecode, sptEntries)) <- withWarnings "bytecode" $ \_tweak -> do - let summary' = _tweak summary - session = hscEnv { hsc_dflags = ms_hspp_opts summary' } + let session = _tweak (hscSetFlags (ms_hspp_opts summary) hscEnv) + -- TODO: maybe settings ms_hspp_opts is unnecessary? + summary' = summary { ms_hspp_opts = hsc_dflags session } hscInteractive session guts #if MIN_VERSION_ghc(8,10,0) (ms_location summary') @@ -475,16 +452,16 @@ -- These varBinds use unitDataConId but it could be anything as the id name is not used -- during the hie file generation process. It's a workaround for the fact that the hie modules -- don't export an interface which allows for additional information to be added to hie files. - let fake_splice_binds = listToBag (map (mkVarBind unitDataConId) (spliceExpresions $ tmrTopLevelSplices tcm)) + let fake_splice_binds = Util.listToBag (map (mkVarBind unitDataConId) (spliceExpresions $ 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 :: Bag EvBind + top_ev_binds = tcg_ev_binds ts :: Util.Bag EvBind insts = tcg_insts ts :: [ClsInst] tcs = tcg_tcs ts :: [TyCon] - Just <$> GHC.enrichHie (fake_splice_binds `unionBags` real_binds) (tmrRenamed tcm) top_ev_binds insts tcs + Just <$> GHC.enrichHie (fake_splice_binds `Util.unionBags` real_binds) (tmrRenamed tcm) top_ev_binds insts tcs #else - Just <$> GHC.enrichHie (fake_splice_binds `unionBags` real_binds) (tmrRenamed tcm) + Just <$> GHC.enrichHie (fake_splice_binds `Util.unionBags` real_binds) (tmrRenamed tcm) #endif where dflags = hsc_dflags hscEnv @@ -527,7 +504,7 @@ -- TVar to 0 in order to set it up for a fresh indexing session. Otherwise, we -- can just increment the 'indexCompleted' TVar and exit. -- -indexHieFile :: ShakeExtras -> ModSummary -> NormalizedFilePath -> Fingerprint -> Compat.HieFile -> IO () +indexHieFile :: ShakeExtras -> ModSummary -> NormalizedFilePath -> Util.Fingerprint -> Compat.HieFile -> IO () indexHieFile se mod_summary srcPath !hash hf = do IdeOptions{optProgressStyle} <- getIdeOptionsIO se atomically $ do @@ -565,7 +542,7 @@ case lspEnv se of Nothing -> pure Nothing Just env -> LSP.runLspT env $ do - u <- LSP.ProgressTextToken . T.pack . show . hashUnique <$> liftIO newUnique + u <- LSP.ProgressTextToken . T.pack . show . hashUnique <$> liftIO Unique.newUnique -- TODO: Wait for the progress create response to use the token _ <- LSP.sendRequest LSP.SWindowWorkDoneProgressCreate (LSP.WorkDoneProgressCreateParams u) (const $ pure ()) LSP.sendNotification LSP.SProgress $ LSP.ProgressParams u $ @@ -634,7 +611,7 @@ hf <- runHsc hscEnv $ GHC.mkHieFile' mod_summary exports ast source atomicFileWrite targetPath $ flip GHC.writeHieFile hf - hash <- getFileHash targetPath + hash <- Util.getFileHash targetPath indexHieFile se mod_summary srcPath hash hf where dflags = hsc_dflags hscEnv @@ -645,7 +622,7 @@ writeHiFile hscEnv tc = handleGenerationErrors dflags "interface write" $ do atomicFileWrite targetPath $ \fp -> - writeIfaceFile dflags fp modIface + writeIfaceFile hscEnv fp modIface where modIface = hm_iface $ hirHomeMod tc targetPath = ml_hi_file $ ms_location $ hirModSummary tc @@ -674,7 +651,7 @@ -- Make modules available for others that import them, -- by putting them in the finder cache. - let ims = map (installedModule (thisInstalledUnitId $ hsc_dflags session) . moduleName . ms_mod) mss + let ims = map (installedModule (homeUnitId_ $ hsc_dflags session) . moduleName . ms_mod) mss ifrs = zipWith (\ms -> InstalledFound (ms_location ms)) mss ims -- set the target and module graph in the session graph = mkModuleGraph mss @@ -718,7 +695,7 @@ :: HscEnv -> FilePath -> UTCTime - -> Maybe SB.StringBuffer + -> Maybe Util.StringBuffer -> ExceptT [FileDiagnostic] IO ModSummaryResult getModSummaryFromImports env fp modTime contents = do (contents, opts, dflags) <- preprocessor env fp contents @@ -730,7 +707,7 @@ let mb_mod = hsmodName hsmod imps = hsmodImports hsmod - mod = fmap unLoc mb_mod `orElse` mAIN_NAME + mod = fmap unLoc mb_mod `Util.orElse` mAIN_NAME (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource.unLoc) imps @@ -756,7 +733,7 @@ modLoc <- liftIO $ mkHomeModLocation dflags mod fp - let modl = mkModule (thisPackage dflags) mod + let modl = mkHomeModule (hscHomeUnit (hscSetFlags dflags env)) mod sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile msrModSummary = ModSummary @@ -785,14 +762,14 @@ -- eliding the timestamps, the preprocessed source and other non relevant fields computeFingerprint opts ModSummary{..} = do fingerPrintImports <- fingerprintFromPut $ do - put $ uniq $ moduleNameFS $ moduleName ms_mod + put $ Util.uniq $ moduleNameFS $ moduleName ms_mod forM_ (ms_srcimps ++ ms_textual_imps) $ \(mb_p, m) -> do - put $ uniq $ moduleNameFS $ unLoc m - whenJust mb_p $ put . uniq - return $! fingerprintFingerprints $ - [ fingerprintString fp + put $ Util.uniq $ moduleNameFS $ unLoc m + whenJust mb_p $ put . Util.uniq + return $! Util.fingerprintFingerprints $ + [ Util.fingerprintString fp , fingerPrintImports - ] ++ map fingerprintString opts + ] ++ map Util.fingerprintString opts -- | Parse only the module header @@ -800,15 +777,15 @@ :: Monad m => DynFlags -- ^ flags to use -> FilePath -- ^ the filename (for source locations) - -> SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported) + -> Util.StringBuffer -- ^ Haskell module source text (full Unicode is supported) #if MIN_VERSION_ghc(9,0,1) -> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located(HsModule)) #else -> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located(HsModule GhcPs)) #endif parseHeader dflags filename contents = do - let loc = mkRealSrcLoc (mkFastString filename) 1 1 - case unP Parser.parseHeader (mkPState dflags contents loc) of + let loc = mkRealSrcLoc (Util.mkFastString filename) 1 1 + case unP Compat.parseHeader (initParserState (initParserOpts dflags) contents loc) of #if MIN_VERSION_ghc(8,10,0) PFailed pst -> throwE $ diagFromErrMsgs "parser" dflags $ getErrorMessages pst dflags @@ -828,9 +805,9 @@ -- errors are those from which a parse tree just can't -- be produced. unless (null errs) $ - throwE $ diagFromErrMsgs "parser" dflags errs + throwE $ diagFromErrMsgs "parser" dflags (fmap pprError errs) - let warnings = diagFromErrMsgs "parser" dflags warns + let warnings = diagFromErrMsgs "parser" dflags (fmap pprWarning warns) return (warnings, rdr_module) -- | Given a buffer, flags, and file path, produce a @@ -843,10 +820,10 @@ -> ModSummary -> ExceptT [FileDiagnostic] IO ([FileDiagnostic], ParsedModule) parseFileContents env customPreprocessor filename ms = do - let loc = mkRealSrcLoc (mkFastString filename) 1 1 + let loc = mkRealSrcLoc (Util.mkFastString filename) 1 1 dflags = ms_hspp_opts ms contents = fromJust $ ms_hspp_buf ms - case unP Parser.parseModule (mkPState dflags contents loc) of + case unP Compat.parseModule (initParserState (initParserOpts dflags) contents loc) of #if MIN_VERSION_ghc(8,10,0) PFailed pst -> throwE $ diagFromErrMsgs "parser" dflags $ getErrorMessages pst dflags #else @@ -854,21 +831,8 @@ throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr #endif POk pst rdr_module -> - let hpm_annotations :: ApiAnns - hpm_annotations = -#if MIN_VERSION_ghc(9,0,1) - -- Copied from GHC.Driver.Main - ApiAnns { - apiAnnItems = Map.fromListWith (++) $ annotations pst, - apiAnnEofPos = eof_pos pst, - apiAnnComments = Map.fromList (annotations_comments pst), - apiAnnRogueComments = comment_q pst - } -#else - (Map.fromListWith (++) $ annotations pst, - Map.fromList ((noSrcSpan,comment_q pst) - :annotations_comments pst)) -#endif + let + hpm_annotations = mkApiAnns pst (warns, errs) = getMessages pst dflags in do @@ -908,7 +872,7 @@ $ filter (/= n_hspp) $ map normalise $ filter (not . isPrefixOf "<") - $ map unpackFS + $ map Util.unpackFS $ srcfiles pst srcs1 = case ml_hs_file (ms_location ms) of Just f -> filter (/= normalise f) srcs0 @@ -919,13 +883,7 @@ -- filter them out: srcs2 <- liftIO $ filterM doesFileExist srcs1 - let pm = - ParsedModule { - pm_mod_summary = ms - , pm_parsed_source = parsed' - , pm_extra_src_files = srcs2 - , pm_annotations = hpm_annotations - } + let pm = mkParsedModule ms parsed' srcs2 hpm_annotations warnings = diagFromErrMsgs "parser" dflags warns pure (warnings ++ preproc_warnings, pm) @@ -944,7 +902,7 @@ -> (Maybe LinkableType -> m ([FileDiagnostic], Maybe HiFileResult)) -- ^ Action to regenerate an interface -> m ([FileDiagnostic], Maybe HiFileResult) loadInterface session ms sourceMod linkableNeeded regen = do - let sessionWithMsDynFlags = session{hsc_dflags = ms_hspp_opts ms} + let sessionWithMsDynFlags = hscSetFlags (ms_hspp_opts ms) session res <- liftIO $ checkOldIface sessionWithMsDynFlags ms sourceMod Nothing case res of (UpToDate, Just iface) @@ -1019,7 +977,7 @@ UnhelpfulLoc {} -> True fakeSpan :: RealSrcSpan -fakeSpan = realSrcLocSpan $ mkRealSrcLoc (fsLit "") 1 1 +fakeSpan = realSrcLocSpan $ mkRealSrcLoc (Util.fsLit "") 1 1 -- | Non-interactive, batch version of 'InteractiveEval.lookupNames'. -- The interactive paths create problems in ghc-lib builds diff --git a/src/Development/IDE/Core/Preprocessor.hs b/src/Development/IDE/Core/Preprocessor.hs --- a/src/Development/IDE/Core/Preprocessor.hs +++ b/src/Development/IDE/Core/Preprocessor.hs @@ -7,13 +7,13 @@ import Development.IDE.GHC.CPP import Development.IDE.GHC.Compat +import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.GHC.Orphans () -import GhcMonad -import StringBuffer as SB import Control.DeepSeq (NFData (rnf)) import Control.Exception (evaluate) import Control.Exception.Safe (catch, throw) +import Control.Monad.IO.Class import Control.Monad.Trans.Except import Data.Char import Data.IORef (IORef, modifyIORef, @@ -26,56 +26,52 @@ import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import qualified GHC.LanguageExtensions as LangExt -import qualified HeaderInfo as Hdr -import HscTypes (HscEnv (hsc_dflags)) -import Outputable (showSDoc) -import SysTools (Option (..), runPp, - runUnlit) import System.FilePath import System.IO.Extra - -- | Given a file and some contents, apply any necessary preprocessors, -- e.g. unlit/cpp. Return the resulting buffer and the DynFlags it implies. -preprocessor :: HscEnv -> FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] IO (StringBuffer, [String], DynFlags) -preprocessor env filename mbContents = do +preprocessor :: HscEnv -> FilePath -> Maybe Util.StringBuffer -> ExceptT [FileDiagnostic] IO (Util.StringBuffer, [String], DynFlags) +preprocessor env0 filename mbContents = do -- Perform unlit (isOnDisk, contents) <- if isLiterate filename then do - let dflags = hsc_dflags env - newcontent <- liftIO $ runLhs dflags filename mbContents + newcontent <- liftIO $ runLhs env0 filename mbContents return (False, newcontent) else do - contents <- liftIO $ maybe (hGetStringBuffer filename) return mbContents + contents <- liftIO $ maybe (Util.hGetStringBuffer filename) return mbContents let isOnDisk = isNothing mbContents return (isOnDisk, contents) -- Perform cpp - (opts, dflags) <- ExceptT $ parsePragmasIntoDynFlags env filename contents + (opts, dflags) <- ExceptT $ parsePragmasIntoDynFlags env0 filename contents + let env1 = hscSetFlags dflags env0 + let logger = hsc_logger env1 (isOnDisk, contents, opts, dflags) <- if not $ xopt LangExt.Cpp dflags then return (isOnDisk, contents, opts, dflags) else do cppLogs <- liftIO $ newIORef [] + let newLogger = pushLogHook (const (logActionCompat $ logAction cppLogs)) logger contents <- ExceptT - $ (Right <$> (runCpp dflags {log_action = logActionCompat $ logAction cppLogs} filename + $ (Right <$> (runCpp (putLogHook newLogger env1) filename $ if isOnDisk then Nothing else Just contents)) `catch` - ( \(e :: GhcException) -> do + ( \(e :: Util.GhcException) -> do logs <- readIORef cppLogs case diagsFromCPPLogs filename (reverse logs) of [] -> throw e diags -> return $ Left diags ) - (opts, dflags) <- ExceptT $ parsePragmasIntoDynFlags env filename contents + (opts, dflags) <- ExceptT $ parsePragmasIntoDynFlags env1 filename contents return (False, contents, opts, dflags) -- Perform preprocessor if not $ gopt Opt_Pp dflags then return (contents, opts, dflags) else do - contents <- liftIO $ runPreprocessor dflags filename $ if isOnDisk then Nothing else Just contents - (opts, dflags) <- ExceptT $ parsePragmasIntoDynFlags env filename contents + contents <- liftIO $ runPreprocessor env1 filename $ if isOnDisk then Nothing else Just contents + (opts, dflags) <- ExceptT $ parsePragmasIntoDynFlags env1 filename contents return (contents, opts, dflags) where logAction :: IORef [CPPLog] -> LogActionCompat @@ -107,7 +103,7 @@ -- informational log messages and attaches them to the initial log message. go :: [CPPDiag] -> [CPPLog] -> [CPPDiag] go acc [] = reverse $ map (\d -> d {cdMessage = reverse $ cdMessage d}) acc - go acc (CPPLog sev (OldRealSrcSpan span) msg : logs) = + go acc (CPPLog sev (RealSrcSpan span _) msg : logs) = let diag = CPPDiag (realSrcSpanToRange span) (toDSeverity sev) [msg] in go (diag : acc) logs go (diag : diags) (CPPLog _sev (UnhelpfulSpan _) msg : logs) = @@ -134,22 +130,22 @@ parsePragmasIntoDynFlags :: HscEnv -> FilePath - -> SB.StringBuffer + -> Util.StringBuffer -> IO (Either [FileDiagnostic] ([String], DynFlags)) parsePragmasIntoDynFlags env fp contents = catchSrcErrors dflags0 "pragmas" $ do - let opts = Hdr.getOptions dflags0 contents fp + let opts = getOptions dflags0 contents fp -- Force bits that might keep the dflags and stringBuffer alive unnecessarily evaluate $ rnf opts (dflags, _, _) <- parseDynamicFilePragma dflags0 opts - dflags' <- initializePlugins env dflags - return (map unLoc opts, disableWarningsAsErrors dflags') + hsc_env' <- initializePlugins (hscSetFlags dflags env) + return (map unLoc opts, disableWarningsAsErrors (hsc_dflags hsc_env')) where dflags0 = hsc_dflags env -- | Run (unlit) literate haskell preprocessor on a file, or buffer if set -runLhs :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer -runLhs dflags filename contents = withTempDir $ \dir -> do +runLhs :: HscEnv -> FilePath -> Maybe Util.StringBuffer -> IO Util.StringBuffer +runLhs env filename contents = withTempDir $ \dir -> do let fout = dir takeFileName filename <.> "unlit" filesrc <- case contents of Nothing -> return filename @@ -159,14 +155,17 @@ hPutStringBuffer h cnts return fsrc unlit filesrc fout - SB.hGetStringBuffer fout + Util.hGetStringBuffer fout where - unlit filein fileout = SysTools.runUnlit dflags (args filein fileout) + logger = hsc_logger env + dflags = hsc_dflags env + + unlit filein fileout = runUnlit logger dflags (args filein fileout) args filein fileout = [ - SysTools.Option "-h" - , SysTools.Option (escape filename) -- name this file - , SysTools.FileOption "" filein -- input file - , SysTools.FileOption "" fileout ] -- output file + Option "-h" + , Option (escape filename) -- name this file + , FileOption "" filein -- input file + , FileOption "" fileout ] -- output file -- taken from ghc's DriverPipeline.hs escape ('\\':cs) = '\\':'\\': escape cs escape ('\"':cs) = '\\':'\"': escape cs @@ -175,31 +174,32 @@ escape [] = [] -- | Run CPP on a file -runCpp :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer -runCpp dflags filename contents = withTempDir $ \dir -> do +runCpp :: HscEnv -> FilePath -> Maybe Util.StringBuffer -> IO Util.StringBuffer +runCpp env0 filename contents = withTempDir $ \dir -> do let out = dir takeFileName filename <.> "out" - dflags <- pure $ addOptP "-D__GHCIDE__" dflags + let dflags1 = addOptP "-D__GHCIDE__" (hsc_dflags env0) + let env1 = hscSetFlags dflags1 env0 case contents of Nothing -> do -- Happy case, file is not modified, so run CPP on it in-place -- which also makes things like relative #include files work -- and means location information is correct - doCpp dflags True filename out - liftIO $ SB.hGetStringBuffer out + doCpp env1 True filename out + liftIO $ Util.hGetStringBuffer out Just contents -> do -- Sad path, we have to create a version of the path in a temp dir -- __FILE__ macro is wrong, ignoring that for now (likely not a real issue) -- Relative includes aren't going to work, so we fix that by adding to the include path. - dflags <- return $ addIncludePathsQuote (takeDirectory filename) dflags - + let dflags2 = addIncludePathsQuote (takeDirectory filename) dflags1 + let env2 = hscSetFlags dflags2 env0 -- Location information is wrong, so we fix that by patching it afterwards. let inp = dir "___GHCIDE_MAGIC___" withBinaryFile inp WriteMode $ \h -> hPutStringBuffer h contents - doCpp dflags True inp out + doCpp env2 True inp out -- Fix up the filename in lines like: -- # 1 "C:/Temp/extra-dir-914611385186/___GHCIDE_MAGIC___" @@ -211,12 +211,12 @@ -- and GHC gets all confused = "# " <> num <> " \"" <> map (\x -> if isPathSeparator x then '/' else x) filename <> "\"" | otherwise = x - stringToStringBuffer . unlines . map tweak . lines <$> readFileUTF8' out + Util.stringToStringBuffer . unlines . map tweak . lines <$> readFileUTF8' out -- | Run a preprocessor on a file -runPreprocessor :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer -runPreprocessor dflags filename contents = withTempDir $ \dir -> do +runPreprocessor :: HscEnv -> FilePath -> Maybe Util.StringBuffer -> IO Util.StringBuffer +runPreprocessor env filename contents = withTempDir $ \dir -> do let out = dir takeFileName filename <.> "out" inp <- case contents of Nothing -> return filename @@ -225,5 +225,8 @@ withBinaryFile inp WriteMode $ \h -> hPutStringBuffer h contents return inp - runPp dflags [SysTools.Option filename, SysTools.Option inp, SysTools.FileOption "" out] - SB.hGetStringBuffer out + runPp logger dflags [Option filename, Option inp, FileOption "" out] + Util.hGetStringBuffer out + where + logger = hsc_logger env + dflags = hsc_dflags env diff --git a/src/Development/IDE/Core/RuleTypes.hs b/src/Development/IDE/Core/RuleTypes.hs --- a/src/Development/IDE/Core/RuleTypes.hs +++ b/src/Development/IDE/Core/RuleTypes.hs @@ -25,6 +25,7 @@ import Data.Typeable import Development.IDE.GHC.Compat hiding (HieFileResult) +import Development.IDE.GHC.Compat.Util import Development.IDE.GHC.Util import Development.IDE.Graph import Development.IDE.Import.DependencyInformation @@ -32,11 +33,6 @@ import Development.IDE.Types.KnownTargets import GHC.Generics (Generic) -import HscTypes (HomeModInfo, - ModGuts, - hm_iface, - hm_linkable) - import qualified Data.Binary as B import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as LBS @@ -46,10 +42,8 @@ import Development.IDE.Spans.Common import Development.IDE.Spans.LocalBindings import Development.IDE.Types.Diagnostics -import Fingerprint import GHC.Serialized (Serialized) import Language.LSP.Types (NormalizedFilePath) -import TcRnMonad (TcGblEnv) data LinkableType = ObjectLinkable | BCOLinkable deriving (Eq,Ord,Show, Generic) diff --git a/src/Development/IDE/Core/Rules.hs b/src/Development/IDE/Core/Rules.hs --- a/src/Development/IDE/Core/Rules.hs +++ b/src/Development/IDE/Core/Rules.hs @@ -58,6 +58,9 @@ typeCheckRuleDefinition, ) where +#if !MIN_VERSION_ghc(8,8,0) +import Control.Applicative (liftA2) +#endif import Control.Concurrent.Async (concurrently) import Control.Concurrent.Strict import Control.Exception.Safe @@ -103,12 +106,14 @@ import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service import Development.IDE.Core.Shake -import Development.IDE.GHC.Compat hiding - (TargetFile, - TargetModule, - parseModule, - typecheckModule, - writeHieFile) +import Development.IDE.GHC.Compat.Env +import Development.IDE.GHC.Compat.Core hiding + (parseModule, + TargetId(..), + loadInterface, + Var) +import qualified Development.IDE.GHC.Compat as Compat +import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.GHC.Error import Development.IDE.GHC.ExactPrint import Development.IDE.GHC.Util hiding @@ -125,23 +130,16 @@ import Development.IDE.Types.Location import qualified Development.IDE.Types.Logger as L import Development.IDE.Types.Options -import Fingerprint import GHC.Generics (Generic) import GHC.IO.Encoding import qualified GHC.LanguageExtensions as LangExt import qualified HieDb -import HscTypes hiding - (TargetFile, - TargetModule) import Ide.Plugin.Config import qualified Language.LSP.Server as LSP import Language.LSP.Types (SMethod (SCustomMethod)) import Language.LSP.VFS -import Module import System.Directory (canonicalizePath, makeAbsolute) -import TcRnMonad (tcg_dependent_files) -import Control.Applicative import Data.Default (def) import Ide.Plugin.Properties (HasProperty, KeyNameProxy, @@ -343,7 +341,7 @@ | otherwise = return Nothing (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do - diagOrImp <- locateModule dflags import_dirs (optExtensions opt) getTargetFor modName mbPkgName isSource + diagOrImp <- locateModule (hscSetFlags dflags env) import_dirs (optExtensions opt) getTargetFor modName mbPkgName isSource case diagOrImp of Left diags -> pure (diags, Just (modName, Nothing)) Right (FileImport path) -> pure ([], Just (modName, Just path)) @@ -503,8 +501,8 @@ let allFiles = reachableModules depInfo _ <- uses_ ReportImportCycles allFiles opts <- getIdeOptions - let mbFingerprints = map (fingerprintString . fromNormalizedFilePath) allFiles <$ optShakeFiles opts - return (fingerprintToBS . fingerprintFingerprints <$> mbFingerprints, transitiveDeps depInfo file) + let mbFingerprints = map (Util.fingerprintString . fromNormalizedFilePath) allFiles <$ optShakeFiles opts + return (fingerprintToBS . Util.fingerprintFingerprints <$> mbFingerprints, transitiveDeps depInfo file) getHieAstsRule :: Rules () getHieAstsRule = @@ -523,9 +521,9 @@ case mvf of Nothing -> (,Nothing) . T.decode encoding <$> BS.readFile (fromNormalizedFilePath file) Just vf -> pure (Rope.toText $ _text vf, Just $ _lsp_version vf) - let refmap = generateReferencesMap . getAsts . hie_asts $ res - del = deltaFromDiff (T.decode encoding $ hie_hs_src res) currentSource - pure (HAR (hie_module res) (hie_asts res) refmap mempty (HieFromDisk res),del,ver) + let refmap = Compat.generateReferencesMap . Compat.getAsts . Compat.hie_asts $ res + del = deltaFromDiff (T.decode encoding $ Compat.hie_hs_src res) currentSource + pure (HAR (Compat.hie_module res) (Compat.hie_asts res) refmap mempty (HieFromDisk res),del,ver) getHieAstRuleDefinition :: NormalizedFilePath -> HscEnv -> TcModuleResult -> Action (IdeResult HieAstResult) getHieAstRuleDefinition f hsc tmr = do @@ -546,8 +544,8 @@ liftIO $ writeAndIndexHieFile hsc se msum f exports asts source _ -> pure [] - let refmap = generateReferencesMap . getAsts <$> masts - typemap = AtPoint.computeTypeReferences . getAsts <$> masts + let refmap = Compat.generateReferencesMap . Compat.getAsts <$> masts + typemap = AtPoint.computeTypeReferences . Compat.getAsts <$> masts pure (diags <> diagsWrite, HAR (ms_mod $ tmrModSummary tmr) <$> masts <*> refmap <*> typemap <*> pure HieFresh) getImportMapRule :: Rules () @@ -584,7 +582,7 @@ persistentDocMapRule :: Rules () persistentDocMapRule = addPersistentRule GetDocMap $ \_ -> pure $ Just (DKMap mempty mempty, idDelta, Nothing) -readHieFileForSrcFromDisk :: NormalizedFilePath -> MaybeT IdeAction HieFile +readHieFileForSrcFromDisk :: NormalizedFilePath -> MaybeT IdeAction Compat.HieFile readHieFileForSrcFromDisk file = do db <- asks hiedb log <- asks $ L.logDebug . logger @@ -593,7 +591,7 @@ liftIO $ log $ "LOADING HIE FILE :" <> T.pack (show file) exceptToMaybeT $ readHieFileFromDisk hie_loc -readHieFileFromDisk :: FilePath -> ExceptT SomeException IdeAction HieFile +readHieFileFromDisk :: FilePath -> ExceptT SomeException IdeAction Compat.HieFile readHieFileFromDisk hie_loc = do nc <- asks ideNc log <- asks $ L.logDebug . logger @@ -754,8 +752,8 @@ -- GetModIfaceFromDisk should have written a `.hie` file, must check if it matches version in db let ms = hirModSummary x - hie_loc = ml_hie_file $ ms_location ms - hash <- liftIO $ getFileHash hie_loc + hie_loc = Compat.ml_hie_file $ ms_location ms + hash <- liftIO $ Util.getFileHash hie_loc mrow <- liftIO $ HieDb.lookupHieFileFromSource hiedb (fromNormalizedFilePath f) hie_loc' <- liftIO $ traverse (canonicalizePath . HieDb.hieModuleHieFile) mrow case mrow of @@ -785,7 +783,7 @@ isHiFileStableRule = defineEarlyCutoff $ RuleNoDiagnostics $ \IsHiFileStable f -> do ms <- msrModSummary <$> use_ GetModSummaryWithoutTimestamps f let hiFile = toNormalizedFilePath' - $ ml_hi_file $ ms_location ms + $ Compat.ml_hi_file $ ms_location ms mbHiVersion <- use GetModificationTime_{missingFileDiagnostics=False} hiFile modVersion <- use_ GetModificationTime f sourceModified <- case mbHiVersion of @@ -811,7 +809,7 @@ defineEarlyCutoff $ Rule $ \GetModSummary f -> do session' <- hscEnv <$> use_ GhcSession f modify_dflags <- getModifyDynFlags dynFlagsModifyGlobal - let session = session' { hsc_dflags = modify_dflags $ hsc_dflags session' } + let session = hscSetFlags (modify_dflags $ hsc_dflags session') session' (modTime, mFileContent) <- getFileContents f let fp = fromNormalizedFilePath f modS <- liftIO $ runExceptT $ @@ -820,7 +818,7 @@ Right res -> do bufFingerPrint <- liftIO $ fingerprintFromStringBuffer $ fromJust $ ms_hspp_buf $ msrModSummary res - let fingerPrint = fingerprintFingerprints + let fingerPrint = Util.fingerprintFingerprints [ msrFingerprint res, bufFingerPrint ] return ( Just (fingerprintToBS fingerPrint) , ([], Just res)) Left diags -> return (Nothing, (diags, Nothing)) @@ -1047,7 +1045,7 @@ writeHiFileAction :: HscEnv -> HiFileResult -> Action [FileDiagnostic] writeHiFileAction hsc hiFile = do extras <- getShakeExtras - let targetPath = ml_hi_file $ ms_location $ hirModSummary hiFile + let targetPath = Compat.ml_hi_file $ ms_location $ hirModSummary hiFile liftIO $ do resetInterfaceStore extras $ toNormalizedFilePath' targetPath writeHiFile hsc hiFile diff --git a/src/Development/IDE/Core/Shake.hs b/src/Development/IDE/Core/Shake.hs --- a/src/Development/IDE/Core/Shake.hs +++ b/src/Development/IDE/Core/Shake.hs @@ -109,7 +109,11 @@ import Development.IDE.Core.ProgressReporting import Development.IDE.Core.RuleTypes import Development.IDE.Core.Tracing -import Development.IDE.GHC.Compat (NameCacheUpdater (..), upNameCache) +import Development.IDE.GHC.Compat (NameCacheUpdater (..), + upNameCache, NameCache, + initNameCache, + mkSplitUniqSupply, + knownKeyNames) import Development.IDE.GHC.Orphans () import Development.IDE.Graph hiding (ShakeValue) import qualified Development.IDE.Graph as Shake @@ -137,10 +141,7 @@ import Data.IORef import GHC.Fingerprint import Language.LSP.Types.Capabilities -import NameCache import OpenTelemetry.Eventlog -import PrelInfo -import UniqSupply import Control.Exception.Extra hiding (bracket_) import qualified Data.ByteString.Char8 as BS8 diff --git a/src/Development/IDE/Core/Tracing.hs b/src/Development/IDE/Core/Tracing.hs --- a/src/Development/IDE/Core/Tracing.hs +++ b/src/Development/IDE/Core/Tracing.hs @@ -21,7 +21,9 @@ import Control.Monad.Extra (whenJust) import Control.Monad.IO.Unlift import Control.Seq (r0, seqList, seqTuple2, using) +#if MIN_VERSION_ghc(8,8,0) import Data.ByteString (ByteString) +#endif import Data.Dynamic (Dynamic) import qualified Data.HashMap.Strict as HMap import Data.IORef (modifyIORef', newIORef, diff --git a/src/Development/IDE/Core/UseStale.hs b/src/Development/IDE/Core/UseStale.hs --- a/src/Development/IDE/Core/UseStale.hs +++ b/src/Development/IDE/Core/UseStale.hs @@ -29,6 +29,9 @@ import Data.Functor.Identity (Identity (Identity)) import Data.Kind (Type) import Data.String (fromString) +import Development.IDE.GHC.Compat (RealSrcSpan, + srcSpanFile) +import Development.IDE.GHC.Compat.Util (unpackFS) import Development.IDE (Action, IdeRule, NormalizedFilePath, Range, @@ -36,8 +39,6 @@ realSrcSpanToRange) import qualified Development.IDE.Core.PositionMapping as P import qualified Development.IDE.Core.Shake as IDE -import qualified FastString as FS -import SrcLoc ------------------------------------------------------------------------------ @@ -113,7 +114,7 @@ instance MapAge RealSrcSpan where mapAgeFrom = - invMapAge (\fs -> rangeToRealSrcSpan (fromString $ FS.unpackFS fs)) + invMapAge (\fs -> rangeToRealSrcSpan (fromString $ unpackFS fs)) (srcSpanFile &&& realSrcSpanToRange) . mapAgeFrom diff --git a/src/Development/IDE/GHC/CPP.hs b/src/Development/IDE/GHC/CPP.hs --- a/src/Development/IDE/GHC/CPP.hs +++ b/src/Development/IDE/GHC/CPP.hs @@ -1,17 +1,8 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 --- Copied from https://github.com/ghc/ghc/blob/master/compiler/main/DriverPipeline.hs on 14 May 2019 --- Requested to be exposed at https://gitlab.haskell.org/ghc/ghc/merge_requests/944. --- Update the above MR got merged to master on 31 May 2019. When it becomes avialable to ghc-lib, this file can be removed. - -{- HLINT ignore -} -- since copied from upstream - {-# LANGUAGE CPP #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NondecreasingIndentation #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} ----------------------------------------------------------------------------- -- @@ -24,149 +15,26 @@ module Development.IDE.GHC.CPP(doCpp, addOptP) where +import GHC import Development.IDE.GHC.Compat as Compat -import FileCleanup -import Packages -import Panic -import SysTools -#if MIN_VERSION_ghc(8,8,2) -import LlvmCodeGen (llvmVersionList) -#elif MIN_VERSION_ghc(8,8,0) -import LlvmCodeGen (LlvmVersion (..)) +#if !MIN_VERSION_ghc(8,10,0) +import qualified Development.IDE.GHC.Compat.CPP as CPP +#else +import Development.IDE.GHC.Compat.Util #endif + +#if MIN_VERSION_ghc(9,0,0) +import qualified GHC.Driver.Pipeline as Pipeline +import GHC.Settings +#else #if MIN_VERSION_ghc (8,10,0) -import Fingerprint +import qualified DriverPipeline as Pipeline import ToolSettings -#endif - -import Control.Monad -import Data.List (intercalate) -import Data.Maybe -import Data.Version -import System.Directory -import System.FilePath -import System.Info - - - -doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO () -doCpp dflags raw input_fn output_fn = do - let hscpp_opts = picPOpts dflags - let cmdline_include_paths = includePaths dflags - - pkg_include_dirs <- getPackageIncludePath dflags [] - let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) [] - (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs) - let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) [] - (includePathsQuote cmdline_include_paths) - let include_paths = include_paths_quote ++ include_paths_global - - let verbFlags = getVerbFlags dflags - - let cpp_prog args | raw = SysTools.runCpp dflags args -#if MIN_VERSION_ghc(8,10,0) - | otherwise = SysTools.runCc Nothing #else - | otherwise = SysTools.runCc +import DynFlags #endif - dflags (SysTools.Option "-E" : args) - - let target_defs = - -- NEIL: Patched to use System.Info instead of constants from CPP - [ "-D" ++ os ++ "_BUILD_OS", - "-D" ++ arch ++ "_BUILD_ARCH", - "-D" ++ os ++ "_HOST_OS", - "-D" ++ arch ++ "_HOST_ARCH" ] - -- remember, in code we *compile*, the HOST is the same our TARGET, - -- and BUILD is the same as our HOST. - - let sse_defs = - [ "-D__SSE__" | isSseEnabled dflags ] ++ - [ "-D__SSE2__" | isSse2Enabled dflags ] ++ - [ "-D__SSE4_2__" | isSse4_2Enabled dflags ] - - let avx_defs = - [ "-D__AVX__" | isAvxEnabled dflags ] ++ - [ "-D__AVX2__" | isAvx2Enabled dflags ] ++ - [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++ - [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++ - [ "-D__AVX512F__" | isAvx512fEnabled dflags ] ++ - [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ] - - backend_defs <- getBackendDefs dflags - - let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ] - -- Default CPP defines in Haskell source - ghcVersionH <- getGhcVersionPathName dflags - let hsSourceCppOpts = [ "-include", ghcVersionH ] - - -- MIN_VERSION macros - let uids = explicitPackages (pkgState dflags) - pkgs = catMaybes (map (lookupPackage dflags) uids) - mb_macro_include <- - if not (null pkgs) && gopt Opt_VersionMacros dflags - then do macro_stub <- newTempName dflags TFL_CurrentModule "h" - writeFile macro_stub (generatePackageVersionMacros pkgs) - -- Include version macros for every *exposed* package. - -- Without -hide-all-packages and with a package database - -- size of 1000 packages, it takes cpp an estimated 2 - -- milliseconds to process this file. See #10970 - -- comment 8. - return [SysTools.FileOption "-include" macro_stub] - else return [] - - cpp_prog ( map SysTools.Option verbFlags - ++ map SysTools.Option include_paths - ++ map SysTools.Option hsSourceCppOpts - ++ map SysTools.Option target_defs - ++ map SysTools.Option backend_defs - ++ map SysTools.Option th_defs - ++ map SysTools.Option hscpp_opts - ++ map SysTools.Option sse_defs - ++ map SysTools.Option avx_defs - ++ mb_macro_include - -- Set the language mode to assembler-with-cpp when preprocessing. This - -- alleviates some of the C99 macro rules relating to whitespace and the hash - -- operator, which we tend to abuse. Clang in particular is not very happy - -- about this. - ++ [ SysTools.Option "-x" - , SysTools.Option "assembler-with-cpp" - , SysTools.Option input_fn - -- We hackily use Option instead of FileOption here, so that the file - -- name is not back-slashed on Windows. cpp is capable of - -- dealing with / in filenames, so it works fine. Furthermore - -- if we put in backslashes, cpp outputs #line directives - -- with *double* backslashes. And that in turn means that - -- our error messages get double backslashes in them. - -- In due course we should arrange that the lexer deals - -- with these \\ escapes properly. - , SysTools.Option "-o" - , SysTools.FileOption "" output_fn - ]) - -getBackendDefs :: DynFlags -> IO [String] -getBackendDefs dflags | hscTarget dflags == HscLlvm = do - llvmVer <- figureLlvmVersion dflags - return $ case llvmVer of -#if MIN_VERSION_ghc(8,8,2) - Just v - | [m] <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, 0) ] - | m:n:_ <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, n) ] -#elif MIN_VERSION_ghc(8,8,0) - Just (LlvmVersion n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (n,0) ] - Just (LlvmVersionOld m n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ] -#else - Just n -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format n ] #endif - _ -> [] - where - format (major, minor) - | minor >= 100 = error "getBackendDefs: Unsupported minor version" - | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int -getBackendDefs _ = - return [] - addOptP :: String -> DynFlags -> DynFlags #if MIN_VERSION_ghc (8,10,0) addOptP f = alterToolSettings $ \s -> s @@ -183,47 +51,13 @@ onOptP f x = x{sOpt_P = f $ sOpt_P x} #endif --- --------------------------------------------------------------------------- --- Macros (cribbed from Cabal) - -generatePackageVersionMacros :: [Compat.PackageConfig] -> String -generatePackageVersionMacros pkgs = concat - -- Do not add any C-style comments. See #3389. - [ generateMacros "" pkgname version - | pkg <- pkgs - , let version = packageVersion pkg - pkgname = map fixchar (packageNameString pkg) - ] - -fixchar :: Char -> Char -fixchar '-' = '_' -fixchar c = c - -generateMacros :: String -> String -> Version -> String -generateMacros prefix name version = - concat - ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n" - ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n" - ," (major1) < ",major1," || \\\n" - ," (major1) == ",major1," && (major2) < ",major2," || \\\n" - ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")" - ,"\n\n" - ] - where - (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0) - - --- | Find out path to @ghcversion.h@ file -getGhcVersionPathName :: DynFlags -> IO FilePath -getGhcVersionPathName dflags = do - candidates <- case ghcVersionFile dflags of - Just path -> return [path] - Nothing -> (map ( "ghcversion.h")) <$> - (getPackageIncludePath dflags [Compat.toInstalledUnitId Compat.rtsUnit]) +doCpp :: HscEnv -> Bool -> FilePath -> FilePath -> IO () +doCpp env raw input_fn output_fn = +#if MIN_VERSION_ghc (9,2,0) + Pipeline.doCpp (hsc_logger env) (hsc_tmpfs env) (hsc_dflags env) (hsc_unit_env env) raw input_fn output_fn +#elif MIN_VERSION_ghc (8,10,0) + Pipeline.doCpp (hsc_dflags env) raw input_fn output_fn +#else + CPP.doCpp (hsc_dflags env) raw input_fn output_fn +#endif - found <- filterM doesFileExist candidates - case found of - [] -> throwGhcExceptionIO (InstallationError - ("ghcversion.h missing; tried: " - ++ intercalate ", " candidates)) - (x:_) -> return x diff --git a/src/Development/IDE/GHC/Compat.hs b/src/Development/IDE/GHC/Compat.hs --- a/src/Development/IDE/GHC/Compat.hs +++ b/src/Development/IDE/GHC/Compat.hs @@ -4,248 +4,144 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PatternSynonyms #-} -{-# OPTIONS -Wno-dodgy-imports -Wno-incomplete-uni-patterns #-} -{-# OPTIONS -Wno-missing-signatures #-} -- TODO: Remove! +{-# OPTIONS -Wno-incomplete-uni-patterns -Wno-dodgy-imports #-} -- | Attempt at hiding the GHC version differences we can. module Development.IDE.GHC.Compat( - HieFileResult(..), - HieFile(..), NameCacheUpdater(..), - hieExportNames, - mkHieFile', - enrichHie, - writeHieFile, - readHieFile, - supportsHieFiles, - setHieDir, - dontWriteHieFiles, -#if !MIN_VERSION_ghc(8,8,0) - ml_hie_file, - addBootSuffixLocnOut, - getRealSrcSpan, -#endif hPutStringBuffer, addIncludePathsQuote, getModuleHash, - getPackageName, setUpTypedHoles, - GHC.ModLocation, - Module.addBootSuffix, - pattern ModLocation, - pattern ExposePackage, - HasSrcSpan, - getLoc, upNameCache, disableWarningsAsErrors, - AvailInfo, - tcg_exports, - pattern FunTy, -#if MIN_VERSION_ghc(8,10,0) - module GHC.Hs.Extension, - module LinkerTypes, -#else - module HsExtension, - noExtField, - linkableTime, -#endif - -#if MIN_VERSION_ghc(9,0,1) - -- Reexports from GHC - UnitId, - moduleUnitId, - pkgState, - thisInstalledUnitId, - -- Reexports from DynFlags - thisPackage, - writeIfaceFile, - - gcatch, -#else +#if !MIN_VERSION_ghc(9,0,1) RefMap, - Unit, #endif - -- Linear - Scaled, - scaledThing, - lookupUnit', - preloadClosureUs, - -- Reexports from Package - InstalledUnitId, - PackageConfig, - getPackageConfigMap, - getPackageIncludePath, - installedModule, - - pattern DefiniteUnitId, - packageName, - packageNameString, - packageVersion, - toInstalledUnitId, - lookupPackage, - -- lookupPackage', - explicitPackages, - exposedModules, - packageConfigId, - setThisInstalledUnitId, - initUnits, - lookupInstalledPackage, - oldLookupInstalledPackage, - unitDepends, - - haddockInterfaces, - - oldUnhelpfulSpan , - pattern IsBoot, - pattern NotBoot, - pattern OldRealSrcSpan, - - oldRenderWithStyle, - oldMkUserStyle, - oldMkErrStyle, - oldFormatErrDoc, - oldListVisibleModuleNames, - oldLookupModuleWithSuggestions, - nodeInfo', getNodeIds, - stringToUnit, - rtsUnit, - unitString, - LogActionCompat, - logActionCompat, - - pprSigmaType, - - module GHC, - module DynFlags, - initializePlugins, - applyPluginsParsedResultAction, - module Compat.HieTypes, - module Compat.HieUtils, - dropForAll, isQualifiedImport, GhcVersion(..), ghcVersion, - ghcVersionStr + ghcVersionStr, + -- * HIE Compat + HieFileResult(..), + HieFile(..), + hieExportNames, + mkHieFile', + enrichHie, + writeHieFile, + readHieFile, + supportsHieFiles, + setHieDir, + dontWriteHieFiles, + module Compat.HieTypes, + module Compat.HieUtils, + -- * Compat modules + module Development.IDE.GHC.Compat.Core, + module Development.IDE.GHC.Compat.Env, + module Development.IDE.GHC.Compat.Iface, + module Development.IDE.GHC.Compat.Logger, + module Development.IDE.GHC.Compat.Outputable, + module Development.IDE.GHC.Compat.Parser, + module Development.IDE.GHC.Compat.Plugins, + module Development.IDE.GHC.Compat.Units, + -- * Extras that rely on compat modules + -- * SysTools + Option (..), + runUnlit, + runPp, ) where -#if MIN_VERSION_ghc(8,10,0) -import LinkerTypes -#endif +import GHC hiding (HasSrcSpan, ModLocation, getLoc, + lookupName, RealSrcSpan) +import Development.IDE.GHC.Compat.Core +import Development.IDE.GHC.Compat.Env +import Development.IDE.GHC.Compat.Iface +import Development.IDE.GHC.Compat.Logger +import Development.IDE.GHC.Compat.Outputable +import Development.IDE.GHC.Compat.Parser +import Development.IDE.GHC.Compat.Plugins +import Development.IDE.GHC.Compat.Units +import Development.IDE.GHC.Compat.Util -import DynFlags hiding (ExposePackage) -import qualified DynFlags -import qualified ErrUtils as Err -import Fingerprint (Fingerprint) -import qualified Module -import qualified Outputable as Out -import StringBuffer -#if MIN_VERSION_ghc(9,0,1) -import Control.Exception.Safe as Safe (Exception, MonadCatch, catch) -import qualified Data.Set as S -import GHC.Core.TyCo.Ppr (pprSigmaType) -import GHC.Core.TyCo.Rep (Scaled, scaledThing) -import GHC.Iface.Load -import GHC.Types.Unique.Set (emptyUniqSet) -import Module (unitString) -import qualified SrcLoc +#if MIN_VERSION_ghc(9,0,0) +import GHC.Data.StringBuffer +import GHC.Driver.Session hiding (ExposePackage) +#if MIN_VERSION_ghc(9,2,0) +import GHC.Driver.Env as Env +import GHC.Unit.Module.ModIface #else -import Module (InstalledUnitId, - UnitId (DefiniteUnitId), - toInstalledUnitId) -import TcType (pprSigmaType) +import GHC.Driver.Types #endif -import Compat.HieAst (enrichHie) -import Compat.HieBin -import Compat.HieTypes -import Compat.HieUtils -import qualified Data.ByteString as BS -import Data.IORef -import HscTypes -import MkIface -import NameCache -import Packages -import TcRnTypes - -#if MIN_VERSION_ghc(8,10,0) -import GHC.Hs.Extension +import GHC.Iface.Env +import GHC.Iface.Make (mkIfaceExports) +import qualified GHC.SysTools.Tasks as SysTools +import qualified GHC.Types.Avail as Avail #else -import HsExtension -#endif +import DynFlags hiding (ExposePackage) +import HscTypes +import MkIface hiding (writeIfaceFile) +import qualified Avail -import Avail -import GHC hiding (HasSrcSpan, ModLocation, getLoc, - lookupName) -import qualified GHC -import qualified TyCoRep #if MIN_VERSION_ghc(8,8,0) -import Data.List (foldl') -#else -import Data.List (foldl', isSuffixOf) +import StringBuffer (hPutStringBuffer) #endif - -import qualified Data.Map as M -import DynamicLoading -import Plugins (Plugin (parsedResultAction), - withPlugins) +import qualified SysTools #if !MIN_VERSION_ghc(8,8,0) import SrcLoc (RealLocated) -import System.FilePath ((-<.>)) -#endif - -#if !MIN_VERSION_ghc(8,8,0) import qualified EnumSet import Foreign.ForeignPtr import System.IO +#endif +#endif +import Compat.HieAst (enrichHie) +import Compat.HieBin +import Compat.HieTypes +import Compat.HieUtils +import qualified Data.ByteString as BS +import Data.IORef +import qualified Data.Map as Map +import Data.List (foldl') + +#if MIN_VERSION_ghc(9,0,0) +import qualified Data.Set as S +#endif + +#if !MIN_VERSION_ghc(8,8,0) hPutStringBuffer :: Handle -> StringBuffer -> IO () hPutStringBuffer hdl (StringBuffer buf len cur) = withForeignPtr (plusForeignPtr buf cur) $ \ptr -> hPutBuf hdl ptr len - #endif -#if !MIN_VERSION_ghc(8,10,0) -noExtField :: NoExt -noExtField = noExt -#endif - supportsHieFiles :: Bool supportsHieFiles = True hieExportNames :: HieFile -> [(SrcSpan, Name)] hieExportNames = nameListFromAvails . hie_exports -#if !MIN_VERSION_ghc(8,8,0) -ml_hie_file :: GHC.ModLocation -> FilePath -ml_hie_file ml - | "boot" `isSuffixOf ` ml_hi_file ml = ml_hi_file ml -<.> ".hie-boot" - | otherwise = ml_hi_file ml -<.> ".hie" -#endif - upNameCache :: IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c -#if !MIN_VERSION_ghc(8,8,0) +#if MIN_VERSION_ghc(8,8,0) +upNameCache = updNameCache +#else upNameCache ref upd_fn = atomicModifyIORef' ref upd_fn -#else -upNameCache = updNameCache #endif - #if !MIN_VERSION_ghc(9,0,1) -type RefMap a = M.Map Identifier [(Span, IdentifierDetails a)] +type RefMap a = Map.Map Identifier [(Span, IdentifierDetails a)] #endif mkHieFile' :: ModSummary - -> [AvailInfo] + -> [Avail.AvailInfo] -> HieASTs Type -> BS.ByteString -> Hsc HieFile @@ -266,15 +162,6 @@ addIncludePathsQuote path x = x{includePaths = f $ includePaths x} where f i = i{includePathsQuote = path : includePathsQuote i} -pattern ModLocation :: Maybe FilePath -> FilePath -> FilePath -> GHC.ModLocation -#if MIN_VERSION_ghc(8,8,0) -pattern ModLocation a b c <- - GHC.ModLocation a b c _ where ModLocation a b c = GHC.ModLocation a b c "" -#else -pattern ModLocation a b c <- - GHC.ModLocation a b c where ModLocation a b c = GHC.ModLocation a b c -#endif - setHieDir :: FilePath -> DynFlags -> DynFlags setHieDir _f d = #if MIN_VERSION_ghc(8,8,0) @@ -312,46 +199,11 @@ } -nameListFromAvails :: [AvailInfo] -> [(SrcSpan, Name)] +nameListFromAvails :: [Avail.AvailInfo] -> [(SrcSpan, Name)] nameListFromAvails as = - map (\n -> (nameSrcSpan n, n)) (concatMap availNames as) + map (\n -> (nameSrcSpan n, n)) (concatMap Avail.availNames as) -#if MIN_VERSION_ghc(9,0,0) --- type HasSrcSpan x a = (GenLocated SrcSpan a ~ x) --- type HasSrcSpan x = () :: Constraint -class HasSrcSpan a where - getLoc :: a -> SrcSpan - -instance HasSrcSpan (GenLocated SrcSpan a) where - getLoc = GHC.getLoc - --- getLoc :: GenLocated l a -> l --- getLoc = GHC.getLoc - -#elif MIN_VERSION_ghc(8,8,0) -type HasSrcSpan = GHC.HasSrcSpan -getLoc :: HasSrcSpan a => a -> SrcSpan -getLoc = GHC.getLoc - -#else - -class HasSrcSpan a where - getLoc :: a -> SrcSpan -instance HasSrcSpan Name where - getLoc = nameSrcSpan -instance HasSrcSpan (GenLocated SrcSpan a) where - getLoc = GHC.getLoc - --- | 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 locn - = locn { ml_hi_file = Module.addBootSuffix (ml_hi_file locn) - , ml_obj_file = Module.addBootSuffix (ml_obj_file locn) - } -#endif - getModuleHash :: ModIface -> Fingerprint #if MIN_VERSION_ghc(8,10,0) getModuleHash = mi_mod_hash . mi_final_exts @@ -359,138 +211,7 @@ getModuleHash = mi_mod_hash #endif --- type PackageName = Packages.PackageName -#if MIN_VERSION_ghc(9,0,0) --- NOTE: Since both the new and old version uses UnitId with different meaning, --- we try to avoid it and instead use InstalledUnitId and Unit, since it is unambiguous. -type UnitId = Module.Unit -type InstalledUnitId = Module.UnitId -type PackageConfig = Packages.UnitInfo -pattern DefiniteUnitId x = Module.RealUnit x -definiteUnitId = Module.RealUnit -defUnitId = Module.Definite -installedModule = Module.Module --- pattern InstalledModule a b = Module.Module a b -packageName = Packages.unitPackageName -lookupPackage = Packages.lookupUnit . unitState --- lookupPackage' = undefined --- lookupPackage' b pm u = Packages.lookupUnit' b pm undefined u --- lookupPackage' b pm u = Packages.lookupUnit' b pm emptyUniqSet u -- TODO: Is this correct? --- lookupPackage' = fmap Packages.lookupUnit' . unitState -getPackageConfigMap = Packages.unitInfoMap . unitState -preloadClosureUs = Packages.preloadClosure . unitState --- getPackageConfigMap = unitState --- getPackageIncludePath = undefined -getPackageIncludePath = Packages.getUnitIncludePath -explicitPackages = Packages.explicitUnits -pkgState = GHC.unitState -packageNameString = Packages.unitPackageNameString -packageVersion = Packages.unitPackageVersion --- toInstalledUnitId = id -- Module.toUnitId -- TODO: This is probably wrong -toInstalledUnitId = Module.toUnitId -exposedModules = Packages.unitExposedModules -packageConfigId = Packages.mkUnit -moduleUnitId = Module.moduleUnit -lookupInstalledPackage = Packages.lookupUnitId -oldLookupInstalledPackage = Packages.lookupUnitId . unitState --- initUnits = Packages.initUnits --- initPackages = initPackagesx -haddockInterfaces = unitHaddockInterfaces -thisInstalledUnitId = GHC.homeUnitId -thisPackage = DynFlags.homeUnit -setThisInstalledUnitId uid df = df { homeUnitId = uid} - -oldUnhelpfulSpan = UnhelpfulSpan . SrcLoc.UnhelpfulOther --- unhelpfulOther = unhelpfulOther . _ -pattern OldRealSrcSpan :: RealSrcSpan -> SrcSpan -pattern OldRealSrcSpan x <- RealSrcSpan x _ where - OldRealSrcSpan x = RealSrcSpan x Nothing -{-# COMPLETE OldRealSrcSpan, UnhelpfulSpan #-} - -oldListVisibleModuleNames = Packages.listVisibleModuleNames . unitState -oldLookupModuleWithSuggestions = Packages.lookupModuleWithSuggestions . unitState --- oldLookupInPackageDB = Packages.lookupInPackageDB . unitState - -oldRenderWithStyle dflags sdoc sty = Out.renderWithStyle (initSDocContext dflags sty) sdoc -oldMkUserStyle _ = Out.mkUserStyle -oldMkErrStyle _ = Out.mkErrStyle - --- TODO: This is still a mess! -oldFormatErrDoc :: DynFlags -> Err.ErrDoc -> Out.SDoc -oldFormatErrDoc dflags = Err.formatErrDoc dummySDocContext - where dummySDocContext = initSDocContext dflags Out.defaultUserStyle --- oldFormatErrDoc = Err.formatErrDoc . undefined -writeIfaceFile = writeIface - -type LogActionCompat = DynFlags -> WarnReason -> Severity -> SrcSpan -> PrintUnqualified -> Out.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 - --- We are using Safe here, which is not equivalent, but probably what we want. -gcatch :: (Exception e, MonadCatch m) => m a -> (e -> m a) -> m a -gcatch = Safe.catch - -#else - -type LogActionCompat = DynFlags -> WarnReason -> Severity -> SrcSpan -> PrintUnqualified -> Out.SDoc -> IO () - -logActionCompat :: LogActionCompat -> LogAction -logActionCompat logAction dynFlags wr severity loc style = logAction dynFlags wr severity loc (Out.queryQual style) - -type Unit = Module.UnitId --- type PackageConfig = Packages.PackageConfig -definiteUnitId :: Module.DefUnitId -> UnitId -definiteUnitId = Module.DefiniteUnitId -defUnitId :: InstalledUnitId -> Module.DefUnitId -defUnitId = Module.DefUnitId -installedModule :: InstalledUnitId -> ModuleName -> Module.InstalledModule -installedModule = Module.InstalledModule -oldLookupInstalledPackage :: DynFlags -> InstalledUnitId -> Maybe PackageConfig -oldLookupInstalledPackage = Packages.lookupInstalledPackage --- packageName = Packages.packageName --- lookupPackage = Packages.lookupPackage --- getPackageConfigMap = Packages.getPackageConfigMap -setThisInstalledUnitId :: InstalledUnitId -> DynFlags -> DynFlags -setThisInstalledUnitId uid df = df { thisInstalledUnitId = uid} - -lookupUnit' :: Bool -> PackageConfigMap -> p -> UnitId -> Maybe PackageConfig -lookupUnit' b pcm _ = Packages.lookupPackage' b pcm -preloadClosureUs = const () - -oldUnhelpfulSpan = UnhelpfulSpan -pattern OldRealSrcSpan :: RealSrcSpan -> SrcSpan -pattern OldRealSrcSpan x = RealSrcSpan x -{-# COMPLETE OldRealSrcSpan, UnhelpfulSpan #-} - -pattern NotBoot, IsBoot :: IsBootInterface -pattern NotBoot = False -pattern IsBoot = True - -initUnits = fmap fst . Packages.initPackages - -unitDepends = depends - -oldListVisibleModuleNames = Packages.listVisibleModuleNames -oldLookupModuleWithSuggestions = Packages.lookupModuleWithSuggestions --- oldLookupInPackageDB = Packages.lookupInPackageDB - -oldRenderWithStyle = Out.renderWithStyle -oldMkUserStyle = Out.mkUserStyle -oldMkErrStyle = Out.mkErrStyle -oldFormatErrDoc = Err.formatErrDoc - --- Linear Haskell -type Scaled a = a -scaledThing :: Scaled a -> a -scaledThing = id -#endif - -getPackageName :: DynFlags -> InstalledUnitId -> Maybe PackageName -getPackageName dfs i = packageName <$> lookupPackage dfs (definiteUnitId (defUnitId i)) - disableWarningsAsErrors :: DynFlags -> DynFlags disableWarningsAsErrors df = flip gopt_unset Opt_WarnIsError $ foldl' wopt_unset_fatal df [toEnum 0 ..] @@ -499,42 +220,8 @@ wopt_unset_fatal :: DynFlags -> WarningFlag -> DynFlags wopt_unset_fatal dfs f = dfs { fatalWarningFlags = EnumSet.delete f (fatalWarningFlags dfs) } - -getRealSrcSpan :: RealLocated a -> RealSrcSpan -getRealSrcSpan = GHC.getLoc #endif -applyPluginsParsedResultAction :: HscEnv -> DynFlags -> ModSummary -> ApiAnns -> ParsedSource -> IO ParsedSource -applyPluginsParsedResultAction env dflags ms hpm_annotations parsed = do - -- Apply parsedResultAction of plugins - let applyPluginAction p opts = parsedResultAction p opts ms - fmap hpm_module $ - runHsc env $ withPlugins dflags applyPluginAction - (HsParsedModule parsed [] hpm_annotations) - -pattern ExposePackage :: String -> PackageArg -> ModRenaming -> PackageFlag --- https://github.com/facebook/fbghc -#ifdef __FACEBOOK_HASKELL__ -pattern ExposePackage s a mr <- DynFlags.ExposePackage s a _ mr -#else -pattern ExposePackage s a mr = DynFlags.ExposePackage s a mr -#endif - --- | Take AST representation of type signature and drop `forall` part from it (if any), returning just type's body -dropForAll :: LHsType pass -> LHsType pass -#if MIN_VERSION_ghc(8,10,0) -dropForAll = snd . GHC.splitLHsForAllTyInvis -#else -dropForAll = snd . GHC.splitLHsForAllTy -#endif - -pattern FunTy :: Type -> Type -> Type -#if MIN_VERSION_ghc(8,10,0) -pattern FunTy arg res <- TyCoRep.FunTy {ft_arg = arg, ft_res = res} -#else -pattern FunTy arg res <- TyCoRep.FunTy arg res -#endif - isQualifiedImport :: ImportDecl a -> Bool #if MIN_VERSION_ghc(8,10,0) isQualifiedImport ImportDecl{ideclQualified = NotQualified} = False @@ -547,19 +234,21 @@ #if MIN_VERSION_ghc(9,0,0) -getNodeIds :: HieAST a -> M.Map Identifier (IdentifierDetails a) -getNodeIds = M.foldl' combineNodeIds M.empty . getSourcedNodeInfo . sourcedNodeInfo +getNodeIds :: HieAST a -> Map.Map Identifier (IdentifierDetails a) +getNodeIds = Map.foldl' combineNodeIds Map.empty . getSourcedNodeInfo . sourcedNodeInfo -ad `combineNodeIds` (NodeInfo _ _ bd) = M.unionWith (<>) ad bd +combineNodeIds :: Map.Map Identifier (IdentifierDetails a) + -> NodeInfo a -> Map.Map Identifier (IdentifierDetails a) +ad `combineNodeIds` (NodeInfo _ _ bd) = Map.unionWith (<>) ad bd -- Copied from GHC and adjusted to accept TypeIndex instead of Type -- nodeInfo' :: Ord a => HieAST a -> NodeInfo a nodeInfo' :: HieAST TypeIndex -> NodeInfo TypeIndex -nodeInfo' = M.foldl' combineNodeInfo' emptyNodeInfo . getSourcedNodeInfo . sourcedNodeInfo +nodeInfo' = Map.foldl' combineNodeInfo' emptyNodeInfo . getSourcedNodeInfo . sourcedNodeInfo combineNodeInfo' :: Ord a => NodeInfo a -> NodeInfo a -> NodeInfo a (NodeInfo as ai ad) `combineNodeInfo'` (NodeInfo bs bi bd) = - NodeInfo (S.union as bs) (mergeSorted ai bi) (M.unionWith (<>) ad bd) + NodeInfo (S.union as bs) (mergeSorted ai bi) (Map.unionWith (<>) ad bd) where mergeSorted :: Ord a => [a] -> [a] -> [a] mergeSorted la@(a:as) lb@(b:bs) = case compare a b of @@ -569,10 +258,9 @@ mergeSorted as [] = as mergeSorted [] bs = bs -stringToUnit = Module.stringToUnit -rtsUnit = Module.rtsUnit #else +getNodeIds :: HieAST a -> NodeIdentifiers a getNodeIds = nodeIdentifiers . nodeInfo -- import qualified FastString as FS @@ -580,15 +268,10 @@ nodeInfo' :: Ord a => HieAST a -> NodeInfo a nodeInfo' = nodeInfo -- type Unit = UnitId -unitString :: Unit -> String -unitString = Module.unitIdString -stringToUnit :: String -> Unit -stringToUnit = Module.stringToUnitId -- moduleUnit :: Module -> Unit -- moduleUnit = moduleUnitId -- unhelpfulSpanFS :: FS.FastString -> FS.FastString -- unhelpfulSpanFS = id -rtsUnit = Module.rtsUnitId #endif data GhcVersion @@ -596,13 +279,16 @@ | GHC88 | GHC810 | GHC90 + | GHC92 deriving (Eq, Ord, Show) ghcVersionStr :: String ghcVersionStr = VERSION_ghc ghcVersion :: GhcVersion -#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0) +#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) +ghcVersion = GHC92 +#elif MIN_VERSION_GLASGOW_HASKELL(9,0,0,0) ghcVersion = GHC90 #elif MIN_VERSION_GLASGOW_HASKELL(8,10,0,0) ghcVersion = GHC810 @@ -610,4 +296,20 @@ ghcVersion = GHC88 #elif MIN_VERSION_GLASGOW_HASKELL(8,6,0,0) ghcVersion = GHC86 +#endif + +runUnlit :: Logger -> DynFlags -> [Option] -> IO () +runUnlit = +#if MIN_VERSION_ghc(9,2,0) + SysTools.runUnlit +#else + const SysTools.runUnlit +#endif + +runPp :: Logger -> DynFlags -> [Option] -> IO () +runPp = +#if MIN_VERSION_ghc(9,2,0) + SysTools.runPp +#else + const SysTools.runPp #endif diff --git a/src/Development/IDE/GHC/Compat/CPP.hs b/src/Development/IDE/GHC/Compat/CPP.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/GHC/Compat/CPP.hs @@ -0,0 +1,204 @@ +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +-- Copied from https://github.com/ghc/ghc/blob/master/compiler/main/DriverPipeline.hs on 14 May 2019 +-- Requested to be exposed at https://gitlab.haskell.org/ghc/ghc/merge_requests/944. +-- Update the above MR got merged to master on 31 May 2019. When it becomes avialable to ghc-lib, this file can be removed. + +{- HLINT ignore -} -- since copied from upstream + +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +-- | Re-export 'doCpp' for GHC < 8.10. +-- +-- Later versions export what we need. +module Development.IDE.GHC.Compat.CPP ( + doCpp + ) where + +import FileCleanup +import Packages +import Panic +import SysTools +#if MIN_VERSION_ghc(8,8,2) +import LlvmCodeGen (llvmVersionList) +#elif MIN_VERSION_ghc(8,8,0) +import LlvmCodeGen (LlvmVersion (..)) +#endif +import DynFlags +import Module (toInstalledUnitId, rtsUnitId) +import Control.Monad +import Data.List (intercalate) +import Data.Maybe +import Data.Version +import System.Directory +import System.FilePath +import System.Info + +import Development.IDE.GHC.Compat as Compat + +doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO () +doCpp dflags raw input_fn output_fn = do + let hscpp_opts = picPOpts dflags + let cmdline_include_paths = includePaths dflags + + pkg_include_dirs <- getPackageIncludePath dflags [] + let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) [] + (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs) + let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) [] + (includePathsQuote cmdline_include_paths) + let include_paths = include_paths_quote ++ include_paths_global + + let verbFlags = getVerbFlags dflags + + let cpp_prog args | raw = SysTools.runCpp dflags args +#if MIN_VERSION_ghc(8,10,0) + | otherwise = SysTools.runCc Nothing +#else + | otherwise = SysTools.runCc +#endif + dflags (SysTools.Option "-E" : args) + + let target_defs = + -- NEIL: Patched to use System.Info instead of constants from CPP + [ "-D" ++ os ++ "_BUILD_OS", + "-D" ++ arch ++ "_BUILD_ARCH", + "-D" ++ os ++ "_HOST_OS", + "-D" ++ arch ++ "_HOST_ARCH" ] + -- remember, in code we *compile*, the HOST is the same our TARGET, + -- and BUILD is the same as our HOST. + + let sse_defs = + [ "-D__SSE__" | isSseEnabled dflags ] ++ + [ "-D__SSE2__" | isSse2Enabled dflags ] ++ + [ "-D__SSE4_2__" | isSse4_2Enabled dflags ] + + let avx_defs = + [ "-D__AVX__" | isAvxEnabled dflags ] ++ + [ "-D__AVX2__" | isAvx2Enabled dflags ] ++ + [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++ + [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++ + [ "-D__AVX512F__" | isAvx512fEnabled dflags ] ++ + [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ] + + backend_defs <- getBackendDefs dflags + + let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ] + -- Default CPP defines in Haskell source + ghcVersionH <- getGhcVersionPathName dflags + let hsSourceCppOpts = [ "-include", ghcVersionH ] + + -- MIN_VERSION macros + let uids = explicitPackages (pkgState dflags) + pkgs = catMaybes (map (lookupPackage dflags) uids) + mb_macro_include <- + if not (null pkgs) && gopt Opt_VersionMacros dflags + then do macro_stub <- newTempName dflags TFL_CurrentModule "h" + writeFile macro_stub (generatePackageVersionMacros pkgs) + -- Include version macros for every *exposed* package. + -- Without -hide-all-packages and with a package database + -- size of 1000 packages, it takes cpp an estimated 2 + -- milliseconds to process this file. See #10970 + -- comment 8. + return [SysTools.FileOption "-include" macro_stub] + else return [] + + cpp_prog ( map SysTools.Option verbFlags + ++ map SysTools.Option include_paths + ++ map SysTools.Option hsSourceCppOpts + ++ map SysTools.Option target_defs + ++ map SysTools.Option backend_defs + ++ map SysTools.Option th_defs + ++ map SysTools.Option hscpp_opts + ++ map SysTools.Option sse_defs + ++ map SysTools.Option avx_defs + ++ mb_macro_include + -- Set the language mode to assembler-with-cpp when preprocessing. This + -- alleviates some of the C99 macro rules relating to whitespace and the hash + -- operator, which we tend to abuse. Clang in particular is not very happy + -- about this. + ++ [ SysTools.Option "-x" + , SysTools.Option "assembler-with-cpp" + , SysTools.Option input_fn + -- We hackily use Option instead of FileOption here, so that the file + -- name is not back-slashed on Windows. cpp is capable of + -- dealing with / in filenames, so it works fine. Furthermore + -- if we put in backslashes, cpp outputs #line directives + -- with *double* backslashes. And that in turn means that + -- our error messages get double backslashes in them. + -- In due course we should arrange that the lexer deals + -- with these \\ escapes properly. + , SysTools.Option "-o" + , SysTools.FileOption "" output_fn + ]) + +getBackendDefs :: DynFlags -> IO [String] +getBackendDefs dflags | hscTarget dflags == HscLlvm = do + llvmVer <- figureLlvmVersion dflags + return $ case llvmVer of +#if MIN_VERSION_ghc(8,8,2) + Just v + | [m] <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, 0) ] + | m:n:_ <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, n) ] +#elif MIN_VERSION_ghc(8,8,0) + Just (LlvmVersion n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (n,0) ] + Just (LlvmVersionOld m n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ] +#else + Just n -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format n ] +#endif + _ -> [] + where + format (major, minor) + | minor >= 100 = error "getBackendDefs: Unsupported minor version" + | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int + +getBackendDefs _ = + return [] + +-- --------------------------------------------------------------------------- +-- Macros (cribbed from Cabal) + +generatePackageVersionMacros :: [Compat.UnitInfo] -> String +generatePackageVersionMacros pkgs = concat + -- Do not add any C-style comments. See #3389. + [ generateMacros "" pkgname version + | pkg <- pkgs + , let version = packageVersion pkg + pkgname = map fixchar (packageNameString pkg) + ] + +fixchar :: Char -> Char +fixchar '-' = '_' +fixchar c = c + +generateMacros :: String -> String -> Version -> String +generateMacros prefix name version = + concat + ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n" + ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n" + ," (major1) < ",major1," || \\\n" + ," (major1) == ",major1," && (major2) < ",major2," || \\\n" + ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")" + ,"\n\n" + ] + where + (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0) + + +-- | Find out path to @ghcversion.h@ file +getGhcVersionPathName :: DynFlags -> IO FilePath +getGhcVersionPathName dflags = do + candidates <- case ghcVersionFile dflags of + Just path -> return [path] + Nothing -> (map ( "ghcversion.h")) <$> + (getPackageIncludePath dflags [toInstalledUnitId rtsUnit]) + + found <- filterM doesFileExist candidates + case found of + [] -> throwGhcExceptionIO (InstallationError + ("ghcversion.h missing; tried: " + ++ intercalate ", " candidates)) + (x:_) -> return x + +rtsUnit :: UnitId +rtsUnit = Module.rtsUnitId diff --git a/src/Development/IDE/GHC/Compat/Core.hs b/src/Development/IDE/GHC/Compat/Core.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/GHC/Compat/Core.hs @@ -0,0 +1,848 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternSynonyms #-} +-- TODO: remove +{-# OPTIONS -Wno-dodgy-imports -Wno-unused-imports #-} + +-- | Compat Core module that handles the GHC module hierarchy re-organisation +-- by re-exporting everything we care about. +-- +-- This module provides no other compat mechanisms, except for simple +-- backward-compatible pattern synonyms. +module Development.IDE.GHC.Compat.Core ( + -- * Session + DynFlags, + extensions, + extensionFlags, + targetPlatform, + packageFlags, + generalFlags, + warningFlags, + topDir, + hiDir, + tmpDir, + importPaths, + useColor, + canUseColor, + useUnicode, + objectDir, + flagsForCompletion, + setImportPaths, + outputFile, + pluginModNames, + refLevelHoleFits, + maxRefHoleFits, + maxValidHoleFits, +#if MIN_VERSION_ghc(8,8,0) + CommandLineOption, +#if !MIN_VERSION_ghc(9,2,0) + staticPlugins, +#endif +#endif + sPgm_F, + settings, + gopt, + gopt_set, + gopt_unset, + wopt, + wopt_set, + xFlags, + xopt, + xopt_unset, + xopt_set, + FlagSpec(..), + WarningFlag(..), + GeneralFlag(..), + PackageFlag, + PackageArg(..), + ModRenaming(..), + pattern ExposePackage, + parseDynamicFlagsCmdLine, + parseDynamicFilePragma, + WarnReason(..), + wWarningFlags, + updOptLevel, + -- slightly unsafe + setUnsafeGlobalDynFlags, + -- * Linear Haskell + Scaled, + scaledThing, + -- * Interface Files + IfaceExport, + IfaceTyCon(..), +#if MIN_VERSION_ghc(8,10,0) + ModIface, + ModIface_(..), +#else + ModIface(..), +#endif + HscSource(..), + WhereFrom(..), + loadInterface, + SourceModified(..), + loadModuleInterface, + RecompileRequired(..), +#if MIN_VERSION_ghc(8,10,0) + mkPartialIface, + mkFullIface, +#else + mkIface, +#endif + checkOldIface, +#if MIN_VERSION_ghc(9,0,0) + IsBootInterface(..), +#else + pattern IsBoot, + pattern NotBoot, +#endif + -- * Fixity + LexicalFixity(..), + -- * ModSummary + ModSummary(..), + -- * HomeModInfo + HomeModInfo(..), + -- * ModGuts + ModGuts(..), + CgGuts(..), + -- * ModDetails + ModDetails(..), + -- * Var + Type ( + TyCoRep.TyVarTy, + TyCoRep.AppTy, + TyCoRep.TyConApp, + TyCoRep.ForAllTy, + -- Omitted on purpose + -- pattern Synonym right below it + -- TyCoRep.FunTy, + TyCoRep.LitTy, + TyCoRep.CastTy, + TyCoRep.CoercionTy + ), + pattern FunTy, + Development.IDE.GHC.Compat.Core.splitForAllTyCoVars, + Development.IDE.GHC.Compat.Core.mkVisFunTys, + Development.IDE.GHC.Compat.Core.mkInfForAllTys, + -- * Specs + ImpDeclSpec(..), + ImportSpec(..), + -- * SourceText + SourceText(..), + -- * Name + tyThingParent_maybe, + -- * Ways + Way, + wayGeneralFlags, + wayUnsetGeneralFlags, + -- * AvailInfo + Avail.AvailInfo, + pattern AvailName, + pattern AvailFL, + pattern AvailTC, + Avail.availName, + Avail.availNames, + Avail.availNamesWithSelectors, + Avail.availsToNameSet, + -- * TcGblEnv + TcGblEnv(..), + -- * Parsing and LExer types + HsParsedModule(..), + GHC.ParsedModule(..), + GHC.ParsedSource, + GHC.RenamedSource, + -- * Compilation Main + HscEnv, + GHC.runGhc, + unGhc, + Session(..), + modifySession, + getSession, + GHC.setSessionDynFlags, + getSessionDynFlags, + GhcMonad, + Ghc, + runHsc, + compileFile, + Phase(..), + hscDesugar, + hscGenHardCode, + hscInteractive, + hscSimplify, + hscTypecheckRename, + makeSimpleDetails, + -- * Typecheck utils + Development.IDE.GHC.Compat.Core.tcSplitForAllTyVars, + Development.IDE.GHC.Compat.Core.tcSplitForAllTyVarBinder_maybe, + typecheckIface, + mkIfaceTc, + ImportedModsVal(..), + importedByUser, + GHC.TypecheckedSource, + -- * Source Locations + HasSrcSpan, + SrcLoc.Located, + SrcLoc.unLoc, + getLoc, + SrcLoc.RealLocated, + SrcLoc.GenLocated(..), + SrcLoc.SrcSpan(SrcLoc.UnhelpfulSpan), + SrcLoc.RealSrcSpan, + pattern RealSrcSpan, + SrcLoc.RealSrcLoc, + SrcLoc.SrcLoc(..), + BufSpan, + SrcLoc.leftmost_smallest, + SrcLoc.containsSpan, + SrcLoc.mkGeneralSrcSpan, + SrcLoc.mkRealSrcSpan, + SrcLoc.mkRealSrcLoc, + getRealSrcSpan, + SrcLoc.realSrcLocSpan, + SrcLoc.realSrcSpanStart, + SrcLoc.realSrcSpanEnd, + SrcLoc.isSubspanOf, + SrcLoc.wiredInSrcSpan, + SrcLoc.mkSrcSpan, + SrcLoc.srcSpanStart, + SrcLoc.srcSpanStartLine, + SrcLoc.srcSpanStartCol, + SrcLoc.srcSpanEnd, + SrcLoc.srcSpanEndLine, + SrcLoc.srcSpanEndCol, + SrcLoc.srcSpanFile, + SrcLoc.srcLocCol, + SrcLoc.srcLocFile, + SrcLoc.srcLocLine, + SrcLoc.noSrcSpan, + SrcLoc.noSrcLoc, + SrcLoc.noLoc, +#if !MIN_VERSION_ghc(8,10,0) && MIN_VERSION_ghc(8,8,0) + SrcLoc.dL, +#endif + -- * Finder + FindResult(..), + mkHomeModLocation, + addBootSuffixLocnOut, + findObjectLinkableMaybe, + InstalledFindResult(..), + -- * Module and Package + ModuleOrigin(..), + PackageName(..), + -- * Linker + Unlinked(..), + Linkable(..), + unload, + initDynLinker, + -- * Hooks + Hooks, + runMetaHook, + MetaHook, + MetaRequest(..), + metaRequestE, + metaRequestP, + metaRequestT, + metaRequestD, + metaRequestAW, + -- * HPT + addToHpt, + addListToHpt, + -- * Driver-Make + Target(..), + TargetId(..), + mkModuleGraph, + -- * GHCi + initObjLinker, + loadDLL, + InteractiveImport(..), + GHC.getContext, + GHC.setContext, + GHC.parseImportDecl, + GHC.runDecls, + Warn(..), + -- * ModLocation + GHC.ModLocation, + pattern ModLocation, + Module.ml_hs_file, + Module.ml_obj_file, + Module.ml_hi_file, + Development.IDE.GHC.Compat.Core.ml_hie_file, + -- * DataCon + Development.IDE.GHC.Compat.Core.dataConExTyCoVars, + -- * Role + Role(..), + -- * Panic + PlainGhcException, + panic, + -- * Util Module re-exports +#if MIN_VERSION_ghc(9,0,0) + module GHC.Builtin.Names, + module GHC.Builtin.Types, + module GHC.Builtin.Types.Prim, + module GHC.Builtin.Utils, + module GHC.Core.Class, + module GHC.Core.Coercion, + module GHC.Core.ConLike, + module GHC.Core.DataCon, + module GHC.Core.FamInstEnv, + module GHC.Core.InstEnv, +#if !MIN_VERSION_ghc(9,2,0) + module GHC.Core.Ppr.TyThing, +#endif + module GHC.Core.PatSyn, + module GHC.Core.Predicate, + module GHC.Core.TyCon, + module GHC.Core.TyCo.Ppr, + module GHC.Core.Type, + module GHC.Core.Unify, + module GHC.Core.Utils, + + module GHC.HsToCore.Docs, + module GHC.HsToCore.Expr, + module GHC.HsToCore.Monad, + + module GHC.Iface.Tidy, + module GHC.Iface.Syntax, + +#if MIN_VERSION_ghc(9,2,0) + module Language.Haskell.Syntax.Expr, +#endif + + module GHC.Rename.Names, + module GHC.Rename.Splice, + + module GHC.Tc.Instance.Family, + module GHC.Tc.Module, + module GHC.Tc.Types, + module GHC.Tc.Types.Evidence, + module GHC.Tc.Utils.Env, + module GHC.Tc.Utils.Monad, + + module GHC.Types.Basic, + module GHC.Types.Id, + module GHC.Types.Name , + module GHC.Types.Name.Set, + + module GHC.Types.Name.Cache, + module GHC.Types.Name.Env, + module GHC.Types.Name.Reader, +#if MIN_VERSION_ghc(9,2,0) + module GHC.Types.SourceFile, + module GHC.Types.SourceText, + module GHC.Types.TyThing, + module GHC.Types.TyThing.Ppr, +#endif + module GHC.Types.Unique.Supply, + module GHC.Types.Var, + module GHC.Unit.Module, + module GHC.Utils.Error, +#else + module BasicTypes, + module Class, +#if MIN_VERSION_ghc(8,10,0) + module Coercion, + module Predicate, +#endif + 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 TidyPgm, + module TyCon, + module TysPrim, + module TysWiredIn, + module Type, + module Unify, + module UniqSupply, + module Var, +#endif + -- * Syntax re-exports +#if MIN_VERSION_ghc(9,0,0) + module GHC.Hs, + module GHC.Parser, + module GHC.Parser.Header, + module GHC.Parser.Lexer, +#else +#if MIN_VERSION_ghc(8,10,0) + module GHC.Hs, +#else + module HsBinds, + module HsDecls, + module HsDoc, + module HsExtension, + noExtField, + module HsExpr, + module HsImpExp, + module HsLit, + module HsPat, + module HsSyn, + module HsTypes, + module HsUtils, +#endif + module ExtractDocs, + module Parser, + module Lexer, +#endif + ) where + +import qualified GHC + +#if MIN_VERSION_ghc(9,0,0) +import GHC.Builtin.Names hiding (Unique, printName) +import GHC.Builtin.Types +import GHC.Builtin.Types.Prim +import GHC.Builtin.Utils +import GHC.Core.Class +import GHC.Core.Coercion +import GHC.Core.ConLike +import GHC.Core.DataCon hiding (dataConExTyCoVars) +import qualified GHC.Core.DataCon as DataCon +import GHC.Core.FamInstEnv +import GHC.Core.InstEnv +#if MIN_VERSION_ghc(9,2,0) +import GHC.Core.Multiplicity (scaledThing) +#else +import GHC.Core.Ppr.TyThing hiding (pprFamInst) +import GHC.Core.TyCo.Rep (scaledThing) +#endif +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, mkVisFunTys) +import GHC.Core.Unify +import GHC.Core.Utils + +#if MIN_VERSION_ghc(9,2,0) +import GHC.Driver.Env +#else +import GHC.Driver.Finder +import GHC.Driver.Types +import GHC.Driver.Ways +#endif +import GHC.Driver.CmdLine (Warn (..)) +import GHC.Driver.Hooks +import GHC.Driver.Main +import GHC.Driver.Monad +import GHC.Driver.Phases +import GHC.Driver.Pipeline +import GHC.Driver.Plugins +import GHC.Driver.Session hiding (ExposePackage) +import qualified GHC.Driver.Session as DynFlags +#if !MIN_VERSION_ghc(9,2,0) +import GHC.Hs +#endif +import GHC.HsToCore.Docs +import GHC.HsToCore.Expr +import GHC.HsToCore.Monad +import GHC.Iface.Load +import GHC.Iface.Make (mkFullIface, mkIfaceTc, + mkPartialIface) +import GHC.Iface.Recomp +import GHC.Iface.Syntax +import GHC.Iface.Tidy +import GHC.IfaceToCore +import GHC.Parser +import GHC.Parser.Header hiding (getImports) +import GHC.Parser.Lexer +#if MIN_VERSION_ghc(9,2,0) +import GHC.Linker.Loader +import GHC.Linker.Types +import GHC.Platform.Ways +#else +import GHC.Runtime.Linker +#endif +import GHC.Rename.Names +import GHC.Rename.Splice +import GHC.Runtime.Interpreter +import GHC.Tc.Instance.Family +import GHC.Tc.Module +import GHC.Tc.Types +import GHC.Tc.Types.Evidence hiding ((<.>)) +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.Monad hiding (Applicative (..), IORef, + MonadFix (..), MonadIO (..), allM, + anyM, concatMapM, mapMaybeM, (<$>)) +import GHC.Tc.Utils.TcType as TcType +import qualified GHC.Types.Avail as Avail +#if MIN_VERSION_ghc(9,2,0) +import GHC.Types.Meta +#endif +import GHC.Types.Basic +import GHC.Types.Id +import GHC.Types.Name hiding (varName) +import GHC.Types.Name.Cache +import GHC.Types.Name.Env +import GHC.Types.Name.Reader +#if MIN_VERSION_ghc(9,2,0) +import GHC.Types.Name.Set +import GHC.Types.SourceFile (HscSource (..), + SourceModified (..)) +import GHC.Types.SourceText +import GHC.Types.TyThing +import GHC.Types.TyThing.Ppr +#else +import GHC.Types.Name.Set +#endif +import GHC.Types.SrcLoc (BufSpan, SrcSpan (UnhelpfulSpan)) +import qualified GHC.Types.SrcLoc as SrcLoc +import GHC.Types.Unique.Supply +import GHC.Types.Var (Var (varName), setTyVarUnique, + setVarUnique) +#if MIN_VERSION_ghc(9,2,0) +import GHC.Unit.Finder +import GHC.Unit.Home.ModInfo +#endif +import GHC.Unit.Info (PackageName (..)) +import GHC.Unit.Module hiding (ModLocation (..), UnitId, + addBootSuffixLocnOut, moduleUnit, + toUnitId) +import qualified GHC.Unit.Module as Module +#if MIN_VERSION_ghc(9,2,0) +import GHC.Unit.Module.Imported +import GHC.Unit.Module.ModDetails +import GHC.Unit.Module.ModGuts +import GHC.Unit.Module.ModIface (IfaceExport) +#endif +import GHC.Unit.State (ModuleOrigin (..)) +import GHC.Utils.Error (Severity (..)) +import GHC.Utils.Panic hiding (try) +import qualified GHC.Utils.Panic.Plain as Plain +#else +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 +#if MIN_VERSION_ghc(8,10,0) +import GHC.Hs +#endif +import GHCi +import GhcMonad +import HeaderInfo hiding (getImports) +import Hooks +import HscMain +import HscTypes +#if !MIN_VERSION_ghc(8,10,0) +-- Syntax imports +import HsBinds +import HsDecls +import HsDoc +import HsExpr +import HsExtension +import HsImpExp +import HsLit +import HsPat +import HsSyn hiding (wildCardName) +import HsTypes hiding (wildCardName) +import HsUtils +#endif +import Id +import IfaceSyn +import InstEnv +import Lexer hiding (getSrcLoc) +import Linker +import LoadIface +import MkIface +import Module hiding (ModLocation (..), UnitId, + addBootSuffixLocnOut, moduleUnitId) +import qualified Module +import Name hiding (varName) +import NameCache +import NameEnv +import NameSet +import Packages +#if MIN_VERSION_ghc(8,8,0) +import Panic hiding (try) +import qualified PlainPanic as Plain +#else +import Panic hiding (GhcException, try) +import qualified Panic as Plain +#endif +import Parser +import PatSyn +#if MIN_VERSION_ghc(8,8,0) +import Plugins +#endif +import PprTyThing hiding (pprFamInst) +import PrelInfo +import PrelNames hiding (Unique, printName) +import 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 hiding (mkVisFunTys) +import qualified TcType +import TidyPgm +import qualified TyCoRep +import TyCon +import Type hiding (mkVisFunTys) +import TysPrim +import TysWiredIn +import Unify +import UniqSupply +import Var (Var (varName), setTyVarUnique, + setVarUnique, varType) + +#if MIN_VERSION_ghc(8,10,0) +import Coercion (coercionKind) +import Predicate +import SrcLoc (SrcSpan (UnhelpfulSpan)) +#else +import SrcLoc (RealLocated, + SrcSpan (UnhelpfulSpan)) +#endif +#endif + +#if !MIN_VERSION_ghc(8,8,0) +import Data.List (isSuffixOf) +import System.FilePath +#endif + +#if !MIN_VERSION_ghc(9,0,0) +type BufSpan = () +#endif + +pattern RealSrcSpan :: SrcLoc.RealSrcSpan -> Maybe BufSpan -> SrcLoc.SrcSpan +#if 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 +#endif +{-# COMPLETE RealSrcSpan, UnhelpfulSpan #-} + + +pattern AvailTC :: Name -> [Name] -> [FieldLabel] -> Avail.AvailInfo +#if __GLASGOW_HASKELL__ >= 902 +pattern AvailTC n names pieces <- Avail.AvailTC n ((\gres -> foldr (\gre (names, pieces) -> case gre of + Avail.NormalGreName name -> (name: names, pieces) + Avail.FieldGreName label -> (names, label:pieces)) ([], []) gres) -> (names, pieces)) +#else +pattern AvailTC n names pieces <- Avail.AvailTC n names pieces +#endif + +pattern AvailName :: Name -> Avail.AvailInfo +#if __GLASGOW_HASKELL__ >= 902 +pattern AvailName n <- Avail.Avail (Avail.NormalGreName n) +#else +pattern AvailName n <- Avail.Avail n +#endif + +pattern AvailFL :: FieldLabel -> Avail.AvailInfo +#if __GLASGOW_HASKELL__ >= 902 +pattern AvailFL fl <- Avail.Avail (Avail.FieldGreName fl) +#else +-- pattern synonym that is never populated +pattern AvailFL x <- Avail.Avail (const (True, undefined) -> (False, x)) +#endif + +{-# COMPLETE AvailTC, AvailName, AvailFL #-} + +setImportPaths :: [FilePath] -> DynFlags -> DynFlags +setImportPaths importPaths flags = flags { importPaths = importPaths } + +pattern ExposePackage :: String -> PackageArg -> ModRenaming -> PackageFlag +-- https://github.com/facebook/fbghc +#ifdef __FACEBOOK_HASKELL__ +pattern ExposePackage s a mr <- DynFlags.ExposePackage s a _ mr +#else +pattern ExposePackage s a mr = DynFlags.ExposePackage s a mr +#endif + +pattern FunTy :: Type -> Type -> Type +#if MIN_VERSION_ghc(8,10,0) +pattern FunTy arg res <- TyCoRep.FunTy {ft_arg = arg, ft_res = res} +#else +pattern FunTy arg res <- TyCoRep.FunTy arg res +#endif + +#if MIN_VERSION_ghc(9,0,0) +-- type HasSrcSpan x a = (GenLocated SrcSpan a ~ x) +-- type HasSrcSpan x = () :: Constraint + +class HasSrcSpan a where + getLoc :: a -> SrcSpan + +instance HasSrcSpan (SrcLoc.GenLocated SrcSpan a) where + getLoc = GHC.getLoc + +-- getLoc :: GenLocated l a -> l +-- getLoc = GHC.getLoc + +#elif MIN_VERSION_ghc(8,8,0) +type HasSrcSpan = SrcLoc.HasSrcSpan +getLoc :: SrcLoc.HasSrcSpan a => a -> SrcLoc.SrcSpan +getLoc = SrcLoc.getLoc + +#else + +class HasSrcSpan a where + getLoc :: a -> SrcSpan +instance HasSrcSpan Name where + getLoc = nameSrcSpan +instance HasSrcSpan (SrcLoc.GenLocated SrcSpan a) where + getLoc = SrcLoc.getLoc + +#endif + +getRealSrcSpan :: SrcLoc.RealLocated a -> SrcLoc.RealSrcSpan +#if !MIN_VERSION_ghc(8,8,0) +getRealSrcSpan = SrcLoc.getLoc +#else +getRealSrcSpan = SrcLoc.getRealSrcSpan +#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 +#if !MIN_VERSION_ghc(8,8,0) +addBootSuffixLocnOut locn + = locn { Module.ml_hi_file = Module.addBootSuffix (Module.ml_hi_file locn) + , Module.ml_obj_file = Module.addBootSuffix (Module.ml_obj_file locn) + } +#else +addBootSuffixLocnOut = Module.addBootSuffixLocnOut +#endif + + +dataConExTyCoVars :: DataCon -> [TyCoVar] +#if __GLASGOW_HASKELL__ >= 808 +dataConExTyCoVars = DataCon.dataConExTyCoVars +#else +dataConExTyCoVars = DataCon.dataConExTyVars +#endif + +#if !MIN_VERSION_ghc(9,0,0) +-- Linear Haskell +type Scaled a = a +scaledThing :: Scaled a -> a +scaledThing = id +#endif + +mkVisFunTys :: [Scaled Type] -> Type -> Type +mkVisFunTys = +#if __GLASGOW_HASKELL__ <= 808 + mkFunTys +#else + TcType.mkVisFunTys +#endif + +mkInfForAllTys :: [TyVar] -> Type -> Type +mkInfForAllTys = +#if MIN_VERSION_ghc(9,0,0) + TcType.mkInfForAllTys +#else + mkInvForAllTys +#endif + +splitForAllTyCoVars :: Type -> ([TyCoVar], Type) +splitForAllTyCoVars = +#if MIN_VERSION_ghc(9,2,0) + TcType.splitForAllTyCoVars +#else + splitForAllTys +#endif + +tcSplitForAllTyVars :: Type -> ([TyVar], Type) +tcSplitForAllTyVars = +#if MIN_VERSION_ghc(9,2,0) + TcType.tcSplitForAllTyVars +#else + tcSplitForAllTys +#endif + + +tcSplitForAllTyVarBinder_maybe :: Type -> Maybe (TyVarBinder, Type) +tcSplitForAllTyVarBinder_maybe = +#if MIN_VERSION_ghc(9,2,0) + TcType.tcSplitForAllTyVarBinder_maybe +#else + tcSplitForAllTy_maybe +#endif + +pattern ModLocation :: Maybe FilePath -> FilePath -> FilePath -> GHC.ModLocation +#if MIN_VERSION_ghc(8,8,0) +pattern ModLocation a b c <- + GHC.ModLocation a b c _ where ModLocation a b c = GHC.ModLocation a b c "" +#else +pattern ModLocation a b c <- + GHC.ModLocation a b c where ModLocation a b c = GHC.ModLocation a b c +#endif + +#if !MIN_VERSION_ghc(8,10,0) +noExtField :: GHC.NoExt +noExtField = GHC.noExt +#endif + +ml_hie_file :: GHC.ModLocation -> FilePath +#if !MIN_VERSION_ghc(8,8,0) +ml_hie_file ml + | "boot" `isSuffixOf ` Module.ml_hi_file ml = Module.ml_hi_file ml -<.> ".hie-boot" + | otherwise = Module.ml_hi_file ml -<.> ".hie" +#else +ml_hie_file = Module.ml_hie_file +#endif + +#if !MIN_VERSION_ghc(9,0,0) +pattern NotBoot, IsBoot :: IsBootInterface +pattern NotBoot = False +pattern IsBoot = True +#endif + +#if MIN_VERSION_ghc(8,8,0) +type PlainGhcException = Plain.PlainGhcException +#else +type PlainGhcException = Plain.GhcException +#endif diff --git a/src/Development/IDE/GHC/Compat/Env.hs b/src/Development/IDE/GHC/Compat/Env.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/GHC/Compat/Env.hs @@ -0,0 +1,284 @@ +{-# LANGUAGE CPP #-} + +-- | Compat module for the main Driver types, such as 'HscEnv', +-- 'UnitEnv' and some DynFlags compat functions. +module Development.IDE.GHC.Compat.Env ( + Env.HscEnv(hsc_FC, hsc_NC, hsc_IC, hsc_mod_graph, hsc_HPT, hsc_type_env_var), + InteractiveContext(..), + setInteractivePrintName, + setInteractiveDynFlags, + Env.hsc_dflags, + hsc_EPS, + hsc_logger, + hsc_tmpfs, + hsc_unit_env, + hsc_hooks, + hscSetHooks, + TmpFs, + -- * HomeUnit + hscHomeUnit, + HomeUnit, + setHomeUnitId_, + Development.IDE.GHC.Compat.Env.mkHomeModule, + -- * Provide backwards Compatible + -- types and helper functions. + Logger(..), + UnitEnv, + hscSetUnitEnv, + hscSetFlags, + initTempFs, + -- * Home Unit + Development.IDE.GHC.Compat.Env.homeUnitId_, + -- * DynFlags Helper + setBytecodeLinkerOptions, + setInterpreterLinkerOptions, + -- * Ways + Ways, + Way, + hostFullWays, + setWays, + wayGeneralFlags, + wayUnsetGeneralFlags, + -- * Backend, backwards compatible + Backend, + setBackend, + Development.IDE.GHC.Compat.Env.platformDefaultBackend, + ) where + +import GHC (setInteractiveDynFlags) + +#if MIN_VERSION_ghc(9,0,0) +#if MIN_VERSION_ghc(9,2,0) +import GHC.Driver.Backend as Backend +import GHC.Driver.Env (HscEnv, hsc_EPS) +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.Runtime.Context +import GHC.Unit.Env (UnitEnv) +import GHC.Unit.Home as Home +import GHC.Utils.Logger +import GHC.Utils.TmpFs +#else +import qualified GHC.Driver.Session as DynFlags +import GHC.Driver.Types (HscEnv, InteractiveContext (..), hsc_EPS, + setInteractivePrintName) +import qualified GHC.Driver.Types as Env +import GHC.Driver.Ways hiding (hostFullWays) +import qualified GHC.Driver.Ways as Ways +#endif +import GHC.Driver.Hooks (Hooks) +import GHC.Driver.Session hiding (mkHomeModule) +import GHC.Unit.Module.Name +import GHC.Unit.Types (Module, Unit, UnitId, mkModule) +#else +import DynFlags +import Hooks +import HscTypes as Env +import Module +#endif + +#if MIN_VERSION_ghc(9,0,0) +import qualified Data.Set as Set +#endif +#if !MIN_VERSION_ghc(9,2,0) +import Data.IORef +#endif + +#if !MIN_VERSION_ghc(9,2,0) +type UnitEnv = () +newtype Logger = Logger { log_action :: LogAction } +type TmpFs = () +#endif + +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 } +#endif + +hscSetFlags :: DynFlags -> HscEnv -> HscEnv +hscSetFlags df env = +#if MIN_VERSION_ghc(9,2,0) + hscSetFlags df env +#else + env { Env.hsc_dflags = df } +#endif + +initTempFs :: HscEnv -> IO HscEnv +initTempFs env = do +#if MIN_VERSION_ghc(9,2,0) + tmpFs <- initTmpFs + pure env { Env.hsc_tmpfs = tmpFs } +#else + filesToClean <- newIORef emptyFilesToClean + dirsToClean <- newIORef mempty + let dflags = (Env.hsc_dflags env){filesToClean=filesToClean, dirsToClean=dirsToClean, useUnicode=True} + pure $ hscSetFlags dflags env +#endif + +hscSetUnitEnv :: UnitEnv -> HscEnv -> HscEnv +#if MIN_VERSION_ghc(9,2,0) +hscSetUnitEnv ue env = env { Env.hsc_unit_env = ue } +#else +hscSetUnitEnv _ env = env +#endif + +hsc_unit_env :: HscEnv -> UnitEnv +hsc_unit_env = +#if MIN_VERSION_ghc(9,2,0) + Env.hsc_unit_env +#else + const () +#endif + +hsc_tmpfs :: HscEnv -> TmpFs +hsc_tmpfs = +#if MIN_VERSION_ghc(9,2,0) + Env.hsc_tmpfs +#else + const () +#endif + +hsc_logger :: HscEnv -> Logger +hsc_logger = +#if MIN_VERSION_ghc(9,2,0) + Env.hsc_logger +#else + Logger . DynFlags.log_action . Env.hsc_dflags +#endif + +hsc_hooks :: HscEnv -> Hooks +hsc_hooks = +#if MIN_VERSION_ghc(9,2,0) + Env.hsc_hooks +#else + hooks . Env.hsc_dflags +#endif + +hscSetHooks :: Hooks -> HscEnv -> HscEnv +hscSetHooks hooks env = +#if MIN_VERSION_ghc(9,2,0) + env { Env.hsc_hooks = hooks } +#else + hscSetFlags ((Env.hsc_dflags env) { hooks = hooks}) env +#endif + +homeUnitId_ :: DynFlags -> UnitId +homeUnitId_ = +#if MIN_VERSION_ghc(9,2,0) + Session.homeUnitId_ +#elif MIN_VERSION_ghc(9,0,0) + homeUnitId +#else + thisPackage +#endif + + +#if MIN_VERSION_ghc(9,0,0) && !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 +#endif + +mkHomeModule :: HomeUnit -> ModuleName -> Module +mkHomeModule = +#if MIN_VERSION_ghc(9,2,0) + Home.mkHomeModule +#else + mkModule +#endif + +-- | We don't want to generate object code so we compile to bytecode +-- (HscInterpreted) which implies LinkInMemory +-- HscInterpreted +setBytecodeLinkerOptions :: DynFlags -> DynFlags +setBytecodeLinkerOptions df = df { + ghcLink = LinkInMemory +#if MIN_VERSION_ghc(9,2,0) + , backend = NoBackend +#else + , hscTarget = HscNothing +#endif + , ghcMode = CompManager + } + +setInterpreterLinkerOptions :: DynFlags -> DynFlags +setInterpreterLinkerOptions df = df { + ghcLink = LinkInMemory +#if MIN_VERSION_ghc(9,2,0) + , backend = Interpreter +#else + , hscTarget = HscInterpreted +#endif + , ghcMode = CompManager + } + +-- ------------------------------------------------------- +-- Ways helpers +-- ------------------------------------------------------- + +#if !MIN_VERSION_ghc(9,2,0) && MIN_VERSION_ghc(9,0,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 ways flags = +#if MIN_VERSION_ghc(9,2,0) + flags { Session.targetWays_ = ways} +#elif MIN_VERSION_ghc(9,0,0) + flags {ways = ways} +#else + updateWays $ flags {ways = ways} +#endif + +-- ------------------------------------------------------- +-- Backend helpers +-- ------------------------------------------------------- + +#if !MIN_VERSION_ghc(9,2,0) +type Backend = HscTarget +#endif + +platformDefaultBackend :: DynFlags -> Backend +platformDefaultBackend = +#if MIN_VERSION_ghc(9,2,0) + Backend.platformDefaultBackend . targetPlatform +#elif MIN_VERSION_ghc(8,10,0) + defaultObjectTarget +#else + defaultObjectTarget . DynFlags.targetPlatform +#endif + +setBackend :: Backend -> DynFlags -> DynFlags +setBackend backend flags = +#if MIN_VERSION_ghc(9,2,0) + flags { backend = backend } +#else + flags { hscTarget = backend } +#endif + diff --git a/src/Development/IDE/GHC/Compat/Iface.hs b/src/Development/IDE/GHC/Compat/Iface.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/GHC/Compat/Iface.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE CPP #-} + +-- | Compat module Interface file relevant code. +module Development.IDE.GHC.Compat.Iface ( + writeIfaceFile, + cannotFindModule, + ) where + +import GHC +#if MIN_VERSION_ghc(9,2,0) +import qualified GHC.Iface.Load as Iface +import GHC.Unit.Finder.Types (FindResult) +#elif MIN_VERSION_ghc(9,0,0) +import qualified GHC.Driver.Finder as Finder +import GHC.Driver.Types (FindResult) +import qualified GHC.Iface.Load as Iface +#else +import Finder (FindResult) +import qualified Finder +import qualified MkIface +#endif + +import Development.IDE.GHC.Compat.Env +import Development.IDE.GHC.Compat.Outputable + +writeIfaceFile :: HscEnv -> FilePath -> ModIface -> IO () +#if 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) +#endif + +cannotFindModule :: HscEnv -> ModuleName -> FindResult -> SDoc +cannotFindModule env modname fr = +#if MIN_VERSION_ghc(9,2,0) + Iface.cannotFindModule env modname fr +#else + Finder.cannotFindModule (hsc_dflags env) modname fr +#endif diff --git a/src/Development/IDE/GHC/Compat/Logger.hs b/src/Development/IDE/GHC/Compat/Logger.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/GHC/Compat/Logger.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE CPP #-} +-- | Compat module for GHC 9.2 Logger infrastructure. +module Development.IDE.GHC.Compat.Logger ( + putLogHook, + Development.IDE.GHC.Compat.Logger.pushLogHook, + -- * Logging stuff + LogActionCompat, + logActionCompat, + defaultLogActionHPutStrDoc, + ) where + +import Development.IDE.GHC.Compat.Core +import Development.IDE.GHC.Compat.Env as Env +import Development.IDE.GHC.Compat.Outputable + +#if MIN_VERSION_ghc(9,0,0) +import GHC.Driver.Session as DynFlags +import GHC.Utils.Outputable +#if MIN_VERSION_ghc(9,2,0) +import GHC.Driver.Env (hsc_logger) +import GHC.Utils.Logger as Logger +#endif +#else +import DynFlags +import Outputable (queryQual) +#endif + +putLogHook :: Logger -> HscEnv -> HscEnv +putLogHook logger env = +#if MIN_VERSION_ghc(9,2,0) + env { hsc_logger = logger } +#else + hscSetFlags ((hsc_dflags env) { DynFlags.log_action = Env.log_action logger }) env +#endif + +pushLogHook :: (LogAction -> LogAction) -> Logger -> Logger +pushLogHook f logger = +#if MIN_VERSION_ghc(9,2,0) + Logger.pushLogHook f logger +#else + logger { Env.log_action = f (Env.log_action logger) } +#endif + +#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 diff --git a/src/Development/IDE/GHC/Compat/Outputable.hs b/src/Development/IDE/GHC/Compat/Outputable.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/GHC/Compat/Outputable.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE CPP #-} + +module Development.IDE.GHC.Compat.Outputable ( + SDoc, + Outputable, + showSDoc, + showSDocUnsafe, + showSDocForUser, + ppr, pprPanic, text, vcat, (<+>), ($$), empty, hang, nest, + printSDocQualifiedUnsafe, + printNameWithoutUniques, + printSDocAllTheWay, + mkPrintUnqualified, + mkPrintUnqualifiedDefault, + PrintUnqualified(..), + -- * Parser errors + PsWarning, + PsError, + pprWarning, + pprError, + -- * Error infrastructure + DecoratedSDoc, + MsgEnvelope, + errMsgSpan, + errMsgSeverity, + formatErrorWithQual, + mkWarnMsg, + mkSrcErr, + srcErrorMessages, + ) where + + +#if MIN_VERSION_ghc(9,2,0) +import GHC.Driver.Ppr +import GHC.Driver.Session +import GHC.Parser.Errors +import qualified GHC.Parser.Errors.Ppr as Ppr +import qualified GHC.Types.Error as Error +import GHC.Types.Name.Ppr +import GHC.Types.SourceError +import GHC.Types.SrcLoc +import GHC.Unit.State +import GHC.Utils.Error hiding (mkWarnMsg) +import GHC.Utils.Logger +import GHC.Utils.Outputable +import GHC.Utils.Panic +#elif MIN_VERSION_ghc(9,0,0) +import GHC.Driver.Session +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 +#else +import Development.IDE.GHC.Compat.Core (GlobalRdrEnv) +import DynFlags +import ErrUtils hiding (mkWarnMsg) +import qualified ErrUtils as Err +import HscTypes +import Outputable as Out +import SrcLoc +#endif + +printNameWithoutUniques :: Outputable a => a -> String +printNameWithoutUniques = +#if MIN_VERSION_ghc(9,2,0) + renderWithContext (defaultSDocContext { sdocSuppressUniques = True }) . ppr +#else + printSDocAllTheWay dyn . ppr + where + dyn = unsafeGlobalDynFlags `gopt_set` Opt_SuppressUniques +#endif + +printSDocQualifiedUnsafe :: PrintUnqualified -> SDoc -> String +#if MIN_VERSION_ghc(9,2,0) +printSDocQualifiedUnsafe unqual doc = + -- Taken from 'showSDocForUser' + renderWithContext (defaultSDocContext { sdocStyle = sty }) doc' + where + sty = mkUserStyle unqual AllTheWay + doc' = pprWithUnitState emptyUnitState doc +#else +printSDocQualifiedUnsafe unqual doc = + showSDocForUser unsafeGlobalDynFlags unqual doc +#endif + +printSDocAllTheWay :: DynFlags -> SDoc -> String +#if MIN_VERSION_ghc(9,2,0) +printSDocAllTheWay dflags sdoc = renderWithContext ctxt sdoc + where + ctxt = initSDocContext dflags (mkUserStyle neverQualify AllTheWay) +#else +printSDocAllTheWay dflags sdoc = oldRenderWithStyle dflags sdoc (oldMkUserStyle dflags Out.neverQualify Out.AllTheWay) + +#if MIN_VERSION_ghc(9,0,0) +oldRenderWithStyle dflags sdoc sty = Out.renderWithStyle (initSDocContext dflags sty) sdoc +oldMkUserStyle _ = Out.mkUserStyle +oldMkErrStyle _ = Out.mkErrStyle + +oldFormatErrDoc :: DynFlags -> Err.ErrDoc -> Out.SDoc +oldFormatErrDoc dflags = Err.formatErrDoc dummySDocContext + where dummySDocContext = initSDocContext dflags Out.defaultUserStyle + +#else +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 +#endif + +pprWarning :: PsWarning -> MsgEnvelope DecoratedSDoc +pprWarning = +#if MIN_VERSION_ghc(9,2,0) + Ppr.pprWarning +#else + id +#endif + +pprError :: PsError -> MsgEnvelope DecoratedSDoc +pprError = +#if MIN_VERSION_ghc(9,2,0) + Ppr.pprError +#else + id +#endif + +formatErrorWithQual :: DynFlags -> MsgEnvelope DecoratedSDoc -> String +formatErrorWithQual dflags e = +#if MIN_VERSION_ghc(9,2,0) + showSDoc dflags (pprLocMsgEnvelope e) +#else + Out.showSDoc dflags + $ Out.withPprStyle (oldMkErrStyle dflags $ errMsgContext e) + $ oldFormatErrDoc dflags + $ Err.errMsgDoc e +#endif + +#if !MIN_VERSION_ghc(9,2,0) +type DecoratedSDoc = () +type MsgEnvelope e = ErrMsg + +type PsWarning = ErrMsg +type PsError = ErrMsg +#endif + +mkPrintUnqualifiedDefault :: GlobalRdrEnv -> PrintUnqualified +mkPrintUnqualifiedDefault = + HscTypes.mkPrintUnqualified unsafeGlobalDynFlags + +mkWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc +mkWarnMsg = +#if MIN_VERSION_ghc(9,2,0) + const Error.mkWarnMsg +#else + Err.mkWarnMsg +#endif diff --git a/src/Development/IDE/GHC/Compat/Parser.hs b/src/Development/IDE/GHC/Compat/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/GHC/Compat/Parser.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE CPP #-} + +-- | Parser compaibility module. +module Development.IDE.GHC.Compat.Parser ( + initParserOpts, + initParserState, +#if MIN_VERSION_ghc(9,0,0) && !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 + -- + -- Export data-type here, otherwise only the simple type. + Anno.ApiAnns(..), +#else + ApiAnns, +#endif + mkHsParsedModule, + mkParsedModule, + mkApiAnns, + -- * API Annotations + Anno.AnnKeywordId(..), + Anno.AnnotationComment(..), + ) where + +#if MIN_VERSION_ghc(9,0,0) +import qualified GHC.Parser.Lexer as Lexer +#if MIN_VERSION_ghc(9,2,0) +import qualified GHC.Driver.Config as Config +import GHC.Parser.Lexer hiding (initParserState) +#else +import qualified GHC.Parser.Annotation as Anno +#endif +#else +import qualified ApiAnnotation as Anno +import Lexer +import qualified SrcLoc +#endif +import Development.IDE.GHC.Compat.Core +import Development.IDE.GHC.Compat.Util + +#if !MIN_VERSION_ghc(9,2,0) +import qualified Data.Map as Map +#endif + +#if !MIN_VERSION_ghc(9,0,0) +type ParserOpts = DynFlags +#elif !MIN_VERSION_ghc(9,2,0) +type ParserOpts = Lexer.ParserFlags +#endif + +initParserOpts :: DynFlags -> ParserOpts +initParserOpts = +#if MIN_VERSION_ghc(9,2,0) + Config.initParserOpts +#elif MIN_VERSION_ghc(9,0,0) + Lexer.mkParserFlags +#else + id +#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 +#endif + +#if MIN_VERSION_ghc(9,2,0) +type ApiAnns = () +#else +type ApiAnns = Anno.ApiAnns +#endif + + +mkHsParsedModule :: ParsedSource -> [FilePath] -> ApiAnns -> HsParsedModule +mkHsParsedModule parsed fps hpm_annotations = + HsParsedModule + parsed + fps +#if !MIN_VERSION_ghc(9,2,0) + hpm_annotations +#endif + + +mkParsedModule :: ModSummary -> ParsedSource -> [FilePath] -> ApiAnns -> ParsedModule +mkParsedModule ms parsed extra_src_files _hpm_annotations = + ParsedModule { + pm_mod_summary = ms + , pm_parsed_source = parsed + , pm_extra_src_files = extra_src_files +#if !MIN_VERSION_ghc(9,2,0) + , pm_annotations = _hpm_annotations +#endif + } + +mkApiAnns :: PState -> ApiAnns +#if MIN_VERSION_ghc(9,2,0) +mkApiAnns = const () +#else +mkApiAnns pst = +#if MIN_VERSION_ghc(9,0,1) + -- Copied from GHC.Driver.Main + Anno.ApiAnns { + apiAnnItems = Map.fromListWith (++) $ annotations pst, + apiAnnEofPos = eof_pos 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 diff --git a/src/Development/IDE/GHC/Compat/Plugins.hs b/src/Development/IDE/GHC/Compat/Plugins.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/GHC/Compat/Plugins.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE CPP #-} + +-- | Plugin Compat utils. +module Development.IDE.GHC.Compat.Plugins ( + Plugin(..), + defaultPlugin, +#if __GLASGOW_HASKELL__ >= 808 + PluginWithArgs(..), +#endif + applyPluginsParsedResultAction, + initializePlugins, + + -- * Static plugins +#if MIN_VERSION_ghc(8,8,0) + StaticPlugin(..), + hsc_static_plugins, +#endif + ) where + +import GHC +#if MIN_VERSION_ghc(9,0,0) +#if MIN_VERSION_ghc(9,2,0) +import qualified GHC.Driver.Env as Env +#endif +import GHC.Driver.Plugins (Plugin (..), + PluginWithArgs (..), + StaticPlugin (..), + defaultPlugin, withPlugins) +import qualified GHC.Runtime.Loader as Loader +#elif MIN_VERSION_ghc(8,8,0) +import qualified DynamicLoading as Loader +import Plugins +#else +import qualified DynamicLoading as Loader +import Plugins (Plugin (..), defaultPlugin, + withPlugins) +#endif +import Development.IDE.GHC.Compat.Core +import Development.IDE.GHC.Compat.Env (hscSetFlags, hsc_dflags) +import Development.IDE.GHC.Compat.Parser as Parser + +applyPluginsParsedResultAction :: HscEnv -> DynFlags -> ModSummary -> Parser.ApiAnns -> ParsedSource -> IO ParsedSource +applyPluginsParsedResultAction env dflags ms hpm_annotations parsed = do + -- Apply parsedResultAction of plugins + let applyPluginAction p opts = parsedResultAction p opts ms + fmap hpm_module $ + runHsc env $ withPlugins +#if MIN_VERSION_ghc(9,2,0) + env +#else + dflags +#endif + applyPluginAction + (mkHsParsedModule parsed [] hpm_annotations) + +initializePlugins :: HscEnv -> IO HscEnv +initializePlugins env = do +#if MIN_VERSION_ghc(9,2,0) + Loader.initializePlugins env +#else + newDf <- Loader.initializePlugins env (hsc_dflags env) + pure $ hscSetFlags newDf env +#endif + + +#if MIN_VERSION_ghc(8,8,0) +hsc_static_plugins :: HscEnv -> [StaticPlugin] +#if MIN_VERSION_ghc(9,2,0) +hsc_static_plugins = Env.hsc_static_plugins +#else +hsc_static_plugins = staticPlugins . hsc_dflags +#endif +#endif diff --git a/src/Development/IDE/GHC/Compat/Units.hs b/src/Development/IDE/GHC/Compat/Units.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/GHC/Compat/Units.hs @@ -0,0 +1,345 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE PatternSynonyms #-} + +-- | Compat module for 'UnitState' and 'UnitInfo'. +module Development.IDE.GHC.Compat.Units ( + -- * UnitState + UnitState, + initUnits, + unitState, + getUnitName, + explicitUnits, + preloadClosureUs, + listVisibleModuleNames, + LookupResult(..), + lookupModuleWithSuggestions, + -- * UnitInfoMap + UnitInfoMap, + getUnitInfoMap, + lookupUnit, + lookupUnit', + -- * UnitInfo + UnitInfo, + unitExposedModules, + unitDepends, + unitHaddockInterfaces, + unitInfoId, + unitPackageNameString, + unitPackageVersion, + -- * UnitId helpers + UnitId, + Unit, + unitString, + stringToUnit, +#if !MIN_VERSION_ghc(9,0,0) + pattern RealUnit, +#endif + definiteUnitId, + defUnitId, + installedModule, + -- * Module + toUnitId, + moduleUnitId, + moduleUnit, + -- * ExternalPackageState + ExternalPackageState(..), + -- * Utils + filterInplaceUnits, + ) where + +#if MIN_VERSION_ghc(9,0,0) +#if MIN_VERSION_ghc(9,2,0) +import qualified GHC.Data.ShortText as ST +import GHC.Driver.Env (hsc_unit_dbs) +import GHC.Unit.Env +import GHC.Unit.External +#else +import GHC.Driver.Types +#endif +import GHC.Data.FastString +import GHC.Driver.Session (PackageArg (..), + PackageFlag (..)) +import qualified GHC.Driver.Session as DynFlags +import GHC.Types.Unique.Set +import qualified GHC.Unit.Info as UnitInfo +import GHC.Unit.Module.Name (ModuleName) +import GHC.Unit.State (LookupResult, PackageName, + UnitInfo, + UnitState (unitInfoMap)) +import qualified GHC.Unit.State as State +import GHC.Unit.Types hiding (moduleUnit, toUnitId) +import qualified GHC.Unit.Types as Unit +#else +import DynFlags (PackageArg (..), + PackageFlag (..)) +import qualified DynFlags +import FastString +import HscTypes +import Module hiding (moduleUnitId) +import qualified Module +import Packages (InstalledPackageInfo (haddockInterfaces, packageName), + LookupResult, PackageConfig, + PackageConfigMap, PackageName, + PackageState, + getPackageConfigMap, + lookupPackage') +import qualified Packages +#endif + +import Development.IDE.GHC.Compat.Env +#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0) +import Data.Map (Map) +#endif +import Data.Either +import Data.Version + +#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 +#endif + +initUnits :: HscEnv -> IO HscEnv +initUnits env = do +#if MIN_VERSION_ghc(9,2,0) + let dflags1 = hsc_dflags env + -- Copied from GHC.setSessionDynFlags + let cached_unit_dbs = hsc_unit_dbs env + (dbs,unit_state,home_unit,mconstants) <- State.initUnits (hsc_logger env) dflags1 cached_unit_dbs + + dflags <- updatePlatformConstants dflags1 mconstants + + + let unit_env = UnitEnv + { ue_platform = targetPlatform dflags + , ue_namever = ghcNameVersion dflags + , ue_home_unit = home_unit + , ue_units = unit_state + } + pure $ hscSetFlags dflags $ hscSetUnitEnv unit_env env + { hsc_unit_dbs = Just dbs + } +#elif MIN_VERSION_ghc(9,0,0) + newFlags <- State.initUnits $ hsc_dflags env + pure $ hscSetFlags newFlags env +#else + newFlags <- fmap fst . Packages.initPackages $ hsc_dflags env + pure $ hscSetFlags newFlags env +#endif + +explicitUnits :: UnitState -> [Unit] +explicitUnits ue = +#if MIN_VERSION_ghc(9,0,0) + State.explicitUnits ue +#else + Packages.explicitPackages 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 -> ModuleName -> Maybe FastString -> 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 +#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 +#endif + +-- ------------------------------------------------------------------ +-- Backwards Compatible UnitState +-- ------------------------------------------------------------------ + +-- ------------------------------------------------------------------ +-- Patterns and helpful definitions +-- ------------------------------------------------------------------ + +#if MIN_VERSION_ghc(9,2,0) +definiteUnitId = RealUnit +defUnitId = Definite +installedModule = Module + +#elif MIN_VERSION_ghc(9,0,0) +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 = + partitionEithers (map isInplace 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 diff --git a/src/Development/IDE/GHC/Compat/Util.hs b/src/Development/IDE/GHC/Compat/Util.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/GHC/Compat/Util.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +-- | GHC Utils and Datastructures re-exports. +-- +-- Mainly handles module hierarchy re-organisation of GHC +-- from version < 9.0 to >= 9.0. +-- +-- Some Functions, such as 'toList' shadow other function-names. +-- This way this module can be imported qualified more naturally. +module Development.IDE.GHC.Compat.Util ( + -- * Exception handling + MonadCatch, + GhcException, + handleGhcException, + catch, + try, + -- * Bags + Bag, + bagToList, + listToBag, + unionBags, + isEmptyBag, + -- * Boolean Formula + LBooleanFormula, + BooleanFormula(..), + -- * OverridingBool + OverridingBool(..), + -- * Maybes + MaybeErr(..), + orElse, +#if MIN_VERSION_ghc(8,10,0) + -- * Pair + Pair(..), +#endif + -- * EnumSet + EnumSet, + toList, + -- * FastString exports + FastString, +#if MIN_VERSION_ghc(9,2,0) + -- Export here, so we can coerce safely on consumer sites + LexicalFastString(..), +#endif + uniq, + unpackFS, + mkFastString, + fsLit, + pprHsString, + -- * Fingerprint + Fingerprint(..), + getFileHash, + fingerprintData, + fingerprintString, + fingerprintFingerprints, + -- * Unique + Uniquable, + nonDetCmpUnique, + getUnique, + Unique, + mkUnique, + newTagUnique, + -- * String Buffer + StringBuffer(..), + hGetStringBuffer, + stringToStringBuffer, + ) where + +#if MIN_VERSION_ghc(9,0,0) +import Control.Exception.Safe (MonadCatch, catch, try) +import GHC.Data.Bag +import GHC.Data.BooleanFormula +import GHC.Data.EnumSet + +import GHC.Data.FastString +import GHC.Data.Maybe +import GHC.Data.Pair +import GHC.Data.StringBuffer +import GHC.Types.Unique +import GHC.Utils.Fingerprint +import GHC.Utils.Misc +import GHC.Utils.Outputable (pprHsString) +import GHC.Utils.Panic hiding (try) +#else +import Bag +import BooleanFormula +import EnumSet +import qualified Exception +import FastString +import Fingerprint +import Maybes +#if MIN_VERSION_ghc(8,10,0) +import Pair +#endif +import Outputable (pprHsString) +import Panic hiding (try) +import StringBuffer +import Unique +import Util +#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/src/Development/IDE/GHC/Error.hs b/src/Development/IDE/GHC/Error.hs --- a/src/Development/IDE/GHC/Error.hs +++ b/src/Development/IDE/GHC/Error.hs @@ -29,24 +29,21 @@ , toDSeverity ) where -import Bag import Data.Maybe import Data.String (fromString) import qualified Data.Text as T -import qualified Development.IDE.GHC.Compat as GHC +import Development.IDE.GHC.Compat (DecoratedSDoc, MsgEnvelope, + errMsgSeverity, errMsgSpan, + formatErrorWithQual, + srcErrorMessages) +import qualified Development.IDE.GHC.Compat as Compat +import qualified Development.IDE.GHC.Compat.Util as Compat import Development.IDE.GHC.Orphans () import Development.IDE.Types.Diagnostics as D import Development.IDE.Types.Location -import ErrUtils -import qualified FastString as FS import GHC -import HscTypes -import qualified Outputable as Out -import Panic -import SrcLoc - diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> FileDiagnostic diagFromText diagSource sev loc msg = (toNormalizedFilePath' $ fromMaybe noFilePath $ srcSpanToFilename loc,ShowDiag,) Diagnostic @@ -60,32 +57,25 @@ } -- | Produce a GHC-style error from a source span and a message. -diagFromErrMsg :: T.Text -> DynFlags -> ErrMsg -> [FileDiagnostic] +diagFromErrMsg :: T.Text -> DynFlags -> MsgEnvelope DecoratedSDoc -> [FileDiagnostic] diagFromErrMsg diagSource dflags e = [ diagFromText diagSource sev (errMsgSpan e) $ T.pack $ formatErrorWithQual dflags e | Just sev <- [toDSeverity $ errMsgSeverity e]] -formatErrorWithQual :: DynFlags -> ErrMsg -> String -formatErrorWithQual dflags e = - Out.showSDoc dflags - $ Out.withPprStyle (GHC.oldMkErrStyle dflags $ errMsgContext e) - $ GHC.oldFormatErrDoc dflags - $ ErrUtils.errMsgDoc e - -diagFromErrMsgs :: T.Text -> DynFlags -> Bag ErrMsg -> [FileDiagnostic] -diagFromErrMsgs diagSource dflags = concatMap (diagFromErrMsg diagSource dflags) . bagToList +diagFromErrMsgs :: T.Text -> DynFlags -> Compat.Bag (MsgEnvelope DecoratedSDoc) -> [FileDiagnostic] +diagFromErrMsgs diagSource dflags = concatMap (diagFromErrMsg diagSource dflags) . Compat.bagToList -- | Convert a GHC SrcSpan to a DAML compiler Range srcSpanToRange :: SrcSpan -> Maybe Range -srcSpanToRange (UnhelpfulSpan _) = Nothing -srcSpanToRange (GHC.OldRealSrcSpan real) = Just $ realSrcSpanToRange real +srcSpanToRange (UnhelpfulSpan _) = Nothing +srcSpanToRange (Compat.RealSrcSpan real _) = Just $ realSrcSpanToRange real -- srcSpanToRange = fmap realSrcSpanToRange . realSpan realSrcSpanToRange :: RealSrcSpan -> Range realSrcSpanToRange real = - Range (realSrcLocToPosition $ realSrcSpanStart real) - (realSrcLocToPosition $ realSrcSpanEnd real) + Range (realSrcLocToPosition $ Compat.realSrcSpanStart real) + (realSrcLocToPosition $ Compat.realSrcSpanEnd real) realSrcLocToPosition :: RealSrcLoc -> Position realSrcLocToPosition real = @@ -95,12 +85,12 @@ -- FIXME This may not be an _absolute_ file name, needs fixing. srcSpanToFilename :: SrcSpan -> Maybe FilePath srcSpanToFilename (UnhelpfulSpan _) = Nothing -srcSpanToFilename (GHC.OldRealSrcSpan real) = Just $ FS.unpackFS $ srcSpanFile real +srcSpanToFilename (Compat.RealSrcSpan real _) = Just $ Compat.unpackFS $ srcSpanFile real -- srcSpanToFilename = fmap (FS.unpackFS . srcSpanFile) . realSpan realSrcSpanToLocation :: RealSrcSpan -> Location realSrcSpanToLocation real = Location file (realSrcSpanToRange real) - where file = fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath' $ FS.unpackFS $ srcSpanFile real + where file = fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath' $ Compat.unpackFS $ srcSpanFile real srcSpanToLocation :: SrcSpan -> Maybe Location srcSpanToLocation src = do @@ -110,18 +100,18 @@ pure $ Location (fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath' fs) rng rangeToSrcSpan :: NormalizedFilePath -> Range -> SrcSpan -rangeToSrcSpan = fmap GHC.OldRealSrcSpan . rangeToRealSrcSpan +rangeToSrcSpan = fmap (\x -> Compat.RealSrcSpan x Nothing) . rangeToRealSrcSpan rangeToRealSrcSpan :: NormalizedFilePath -> Range -> RealSrcSpan rangeToRealSrcSpan nfp = - mkRealSrcSpan + Compat.mkRealSrcSpan <$> positionToRealSrcLoc nfp . _start <*> positionToRealSrcLoc nfp . _end positionToRealSrcLoc :: NormalizedFilePath -> Position -> RealSrcLoc positionToRealSrcLoc nfp (Position l c)= - mkRealSrcLoc (fromString $ fromNormalizedFilePath nfp) (l + 1) (c + 1) + Compat.mkRealSrcLoc (fromString $ fromNormalizedFilePath nfp) (l + 1) (c + 1) isInsideSrcSpan :: Position -> SrcSpan -> Bool p `isInsideSrcSpan` r = case srcSpanToRange r of @@ -152,19 +142,19 @@ -- | Produces an "unhelpful" source span with the given string. noSpan :: String -> SrcSpan -noSpan = GHC.oldUnhelpfulSpan . FS.fsLit +noSpan = Compat.mkGeneralSrcSpan . Compat.fsLit -- | creates a span with zero length in the filename of the argument passed -zeroSpan :: FS.FastString -- ^ file path of span +zeroSpan :: Compat.FastString -- ^ file path of span -> RealSrcSpan -zeroSpan file = realSrcLocSpan (mkRealSrcLoc file 1 1) +zeroSpan file = Compat.realSrcLocSpan (Compat.mkRealSrcLoc file 1 1) realSpan :: SrcSpan -> Maybe RealSrcSpan realSpan = \case - GHC.OldRealSrcSpan r -> Just r - UnhelpfulSpan _ -> Nothing + Compat.RealSrcSpan r _ -> Just r + UnhelpfulSpan _ -> Nothing -- | Catch the errors thrown by GHC (SourceErrors and @@ -172,7 +162,7 @@ -- diagnostics catchSrcErrors :: DynFlags -> T.Text -> IO a -> IO (Either [FileDiagnostic] a) catchSrcErrors dflags fromWhere ghcM = do - handleGhcException (ghcExceptionToDiagnostics dflags) $ + Compat.handleGhcException (ghcExceptionToDiagnostics dflags) $ handleSourceError (sourceErrorToDiagnostics dflags) $ Right <$> ghcM where @@ -192,14 +182,14 @@ -> unwords ["Compilation Issue:", s, "\n", requestReport] PprPanic s sdoc -> unlines ["Compilation Issue", s,"" - , Out.showSDoc dflags sdoc + , Compat.showSDoc dflags sdoc , requestReport ] Sorry s -> "Unsupported feature: " <> s PprSorry s sdoc -> unlines ["Unsupported feature: ", s,"" - , Out.showSDoc dflags sdoc] + , Compat.showSDoc dflags sdoc] ---------- errors below should not happen at all -------- @@ -216,6 +206,6 @@ -> "Program error: " <> str PprProgramError str sdoc -> unlines ["Program error:", str,"" - , Out.showSDoc dflags sdoc] + , Compat.showSDoc dflags sdoc] where requestReport = "Please report this bug to the compiler authors." diff --git a/src/Development/IDE/GHC/ExactPrint.hs b/src/Development/IDE/GHC/ExactPrint.hs --- a/src/Development/IDE/GHC/ExactPrint.hs +++ b/src/Development/IDE/GHC/ExactPrint.hs @@ -29,10 +29,11 @@ Anns, Annotate, setPrecedingLinesT, + -- * Helper function + eqSrcSpan, ) where -import BasicTypes (appPrec) import Control.Applicative (Alternative) import Control.Arrow import Control.Monad @@ -53,7 +54,9 @@ import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service (runAction) import Development.IDE.Core.Shake -import Development.IDE.GHC.Compat hiding (parseExpr) +import Development.IDE.GHC.Compat hiding (parseImport, + parsePattern, + parseType) import Development.IDE.Graph (RuleResult, Rules) import Development.IDE.Graph.Classes import Development.IDE.Types.Location @@ -65,9 +68,6 @@ import Language.Haskell.GHC.ExactPrint.Parsers import Language.LSP.Types import Language.LSP.Types.Capabilities (ClientCapabilities) -import Outputable (Outputable, ppr, - showSDoc) -import Parser (parseIdentifier) import Retrie.ExactPrint hiding (parseDecl, parseExpr, parsePattern, @@ -233,8 +233,9 @@ everywhere' ( mkT $ \case - (L src _ :: Located ast) | src == dst -> val' - l -> l + (L src _ :: Located ast) + | src `eqSrcSpan` dst -> val' + l -> l ) a @@ -267,7 +268,7 @@ let (needs_parens, needs_space) = everythingWithContext (Nothing, Nothing) (<>) ( mkQ (mempty, ) $ \x s -> case x of - (L src _ :: LHsExpr GhcPs) | src == dst -> + (L src _ :: LHsExpr GhcPs) | src `eqSrcSpan` dst -> (s, s) L _ x' -> (mempty, Just *** Just $ needsParensSpace x') ) a @@ -291,7 +292,7 @@ ( mkM $ \case val@(L src _ :: LHsExpr GhcPs) - | src == dst -> do + | src `eqSrcSpan` dst -> do mval <- trans val case mval of Just val' -> do @@ -316,7 +317,7 @@ ( mkM $ \case val@(L src _ :: Located ast) - | src == dst -> do + | src `eqSrcSpan` dst -> do mval <- trans val case mval of Just val' -> do @@ -368,7 +369,7 @@ annotateDecl dflags decl let go [] = DL.empty go (L src e : rest) - | src == dst = DL.fromList decs <> DL.fromList rest + | src `eqSrcSpan` dst = DL.fromList decs <> DL.fromList rest | otherwise = DL.singleton (L src e) <> go rest modifyDeclsT (pure . DL.toList . go) a @@ -399,7 +400,7 @@ graftDeclsWithM dst toDecls = Graft $ \dflags a -> do let go [] = pure DL.empty go (e@(L src _) : rest) - | src == dst = toDecls e >>= \case + | src `eqSrcSpan` dst = toDecls e >>= \case Just decs0 -> do decs <- forM decs0 $ \decl -> hoistTransform (either Fail.fail pure) $ @@ -519,3 +520,9 @@ parenthesize :: LHsExpr GhcPs -> LHsExpr GhcPs parenthesize = parenthesizeHsExpr appPrec +------------------------------------------------------------------------------ + +-- | Equality on SrcSpan's. +-- Ignores the (Maybe BufSpan) field of SrcSpan's. +eqSrcSpan :: SrcSpan -> SrcSpan -> Bool +eqSrcSpan l r = leftmost_smallest l r == EQ diff --git a/src/Development/IDE/GHC/Orphans.hs b/src/Development/IDE/GHC/Orphans.hs --- a/src/Development/IDE/GHC/Orphans.hs +++ b/src/Development/IDE/GHC/Orphans.hs @@ -9,21 +9,35 @@ -- Note that the 'NFData' instances may not be law abiding. module Development.IDE.GHC.Orphans() where +#if MIN_VERSION_ghc(9,0,0) +import GHC.Data.Bag +import GHC.Data.FastString +import qualified GHC.Data.StringBuffer as SB +import GHC.Types.Name.Occurrence +import GHC.Types.SrcLoc +import GHC.Types.Unique (getKey) +import GHC.Unit.Info +import GHC.Utils.Outputable +#else import Bag +import GhcPlugins +import qualified StringBuffer as SB +import Unique (getKey) +#endif + +import GHC + +import Retrie.ExactPrint (Annotated) + +import Development.IDE.GHC.Compat +import Development.IDE.GHC.Util + import Control.DeepSeq import Data.Aeson import Data.Hashable import Data.String (IsString (fromString)) import Data.Text (Text) -import Development.IDE.GHC.Compat -import Development.IDE.GHC.Util -import GHC () -import GhcPlugins -import Retrie.ExactPrint (Annotated) -import qualified StringBuffer as SB -import Unique (getKey) - -- Orphan instances for types from the GHC API. instance Show CoreModule where show = prettyPrint instance NFData CoreModule where rnf = rwhnf @@ -50,7 +64,7 @@ instance Hashable GhcPlugins.InstalledUnitId where hashWithSalt salt = hashWithSalt salt . installedUnitIdString #else -instance Show InstalledUnitId where show = prettyPrint +instance Show UnitId where show = prettyPrint deriving instance Ord SrcSpan deriving instance Ord UnhelpfulSpanReason #endif @@ -93,8 +107,10 @@ instance NFData SourceModified where rnf = rwhnf +#if !MIN_VERSION_ghc(9,2,0) instance Show ModuleName where show = moduleNameString +#endif instance Hashable ModuleName where hashWithSalt salt = hashWithSalt salt . show diff --git a/src/Development/IDE/GHC/Util.hs b/src/Development/IDE/GHC/Util.hs --- a/src/Development/IDE/GHC/Util.hs +++ b/src/Development/IDE/GHC/Util.hs @@ -10,7 +10,7 @@ prettyPrint, unsafePrintSDoc, printRdrName, - printName, + Development.IDE.GHC.Util.printName, ParseResult(..), runParser, lookupPackageConfig, textToStringBuffer, @@ -30,48 +30,78 @@ disableWarningsAsErrors, ) where +#if MIN_VERSION_ghc(9,2,0) +import GHC +import GHC.Core.Multiplicity +import qualified GHC.Core.TyCo.Rep as TyCoRep +import GHC.Data.FastString +import GHC.Data.StringBuffer +import GHC.Driver.Env +import GHC.Driver.Env.Types +import GHC.Driver.Monad +import GHC.Driver.Session hiding (ExposePackage) +import qualified GHC.Driver.Session as DynFlags +import GHC.Hs.Extension +import qualified GHC.Hs.Type as GHC +import GHC.Iface.Env (updNameCache) +import GHC.Iface.Make (mkIfaceExports) +import qualified GHC.Linker.Types as LinkerTypes +import GHC.Parser.Lexer +import GHC.Runtime.Context +import GHC.Tc.Types (TcGblEnv (tcg_exports)) +import GHC.Tc.Utils.TcType (pprSigmaType) +import GHC.Types.Avail +import GHC.Types.Name.Cache +import GHC.Types.Name.Occurrence +import GHC.Types.Name.Reader +import GHC.Types.SrcLoc +import qualified GHC.Types.SrcLoc as SrcLoc +import GHC.Unit.Env +import GHC.Unit.Info (PackageName) +import qualified GHC.Unit.Info as Packages +import qualified GHC.Unit.Module.Location as Module +import GHC.Unit.Module.ModDetails +import GHC.Unit.Module.ModGuts +import GHC.Unit.Module.ModIface (mi_mod_hash) +import GHC.Unit.Module.Name (moduleNameSlashes) +import qualified GHC.Unit.State as Packages +import GHC.Unit.Types (IsBootInterface (..), + unitString) +import qualified GHC.Unit.Types as Module +import GHC.Utils.Fingerprint +import GHC.Utils.Outputable +import qualified GHC.Utils.Outputable as Outputable +#endif import Control.Concurrent -import Control.Exception -import Data.Binary.Put (Put, runPut) -import qualified Data.ByteString as BS -import Data.ByteString.Internal (ByteString (..)) -import qualified Data.ByteString.Internal as BS -import qualified Data.ByteString.Lazy as LBS +import Control.Exception as E +import Data.Binary.Put (Put, runPut) +import qualified Data.ByteString as BS +import Data.ByteString.Internal (ByteString (..)) +import qualified Data.ByteString.Internal as BS +import qualified Data.ByteString.Lazy as LBS import Data.IORef import Data.List.Extra import Data.Maybe -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Encoding.Error as T +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Encoding.Error as T import Data.Typeable -import Development.IDE.GHC.Compat as GHC +import Development.IDE.GHC.Compat as GHC +import qualified Development.IDE.GHC.Compat.Parser as Compat +import qualified Development.IDE.GHC.Compat.Units as Compat +import Development.IDE.GHC.Compat.Util import Development.IDE.Types.Location -import FastString (mkFastString) -import FileCleanup -import Fingerprint import Foreign.ForeignPtr import Foreign.Ptr import Foreign.Storable -import GHC.IO.BufferedIO (BufferedIO) -import GHC.IO.Device as IODevice +import GHC +import GHC.IO.BufferedIO (BufferedIO) +import GHC.IO.Device as IODevice import GHC.IO.Encoding import GHC.IO.Exception import GHC.IO.Handle.Internals import GHC.IO.Handle.Types -import GhcMonad -import HscTypes (CgGuts, HscEnv (hsc_dflags), - ModDetails, cg_binds, - cg_module, hsc_IC, ic_dflags, - md_types) -import Lexer -import Module (moduleNameSlashes) -import OccName (parenSymOcc) -import Outputable (Depth (..), Outputable, SDoc, - neverQualify, ppr, - showSDocUnsafe) -import RdrName (nameRdrName, rdrNameOcc) -import SrcLoc (mkRealSrcLoc) -import StringBuffer + import System.FilePath @@ -86,19 +116,15 @@ -- We do not use setSessionDynFlags here since we handle package -- initialization separately. modifySession $ \h -> - h { hsc_dflags = newFlags, hsc_IC = (hsc_IC h) {ic_dflags = newFlags} } + hscSetFlags newFlags h { hsc_IC = (hsc_IC h) {ic_dflags = newFlags} } -- | Given a 'Unit' try and find the associated 'PackageConfig' in the environment. -lookupPackageConfig :: Unit -> HscEnv -> Maybe GHC.PackageConfig +lookupPackageConfig :: Unit -> HscEnv -> Maybe GHC.UnitInfo lookupPackageConfig unit env = - -- GHC.lookupPackage' False pkgConfigMap unit - GHC.lookupUnit' False pkgConfigMap prClsre unit + Compat.lookupUnit' False unitState prClsre unit where - pkgConfigMap = - -- For some weird reason, the GHC API does not provide a way to get the PackageConfigMap - -- from PackageState so we have to wrap it in DynFlags first. - getPackageConfigMap $ hsc_dflags env - prClsre = preloadClosureUs $ hsc_dflags env + unitState = Compat.getUnitInfoMap env + prClsre = preloadClosureUs env -- | Convert from the @text@ package to the @GHC@ 'StringBuffer'. @@ -112,7 +138,7 @@ filename = "" location = mkRealSrcLoc (mkFastString filename) 1 1 buffer = stringToStringBuffer str - parseState = mkPState flags buffer location + parseState = Compat.initParserState (Compat.initParserOpts flags) buffer location stringBufferToByteString :: StringBuffer -> ByteString stringBufferToByteString StringBuffer{..} = PS buf cur len @@ -125,9 +151,7 @@ prettyPrint = unsafePrintSDoc . ppr unsafePrintSDoc :: SDoc -> String -unsafePrintSDoc sdoc = oldRenderWithStyle dflags sdoc (oldMkUserStyle dflags neverQualify AllTheWay) - where - dflags = unsafeGlobalDynFlags +unsafePrintSDoc sdoc = showSDocUnsafe sdoc -- | Pretty print a 'RdrName' wrapping operators in parens printRdrName :: RdrName -> String @@ -148,13 +172,9 @@ -- pieces, but designed to be more efficient than a standard 'runGhc'. runGhcEnv :: HscEnv -> Ghc a -> IO (HscEnv, a) runGhcEnv env act = do - filesToClean <- newIORef emptyFilesToClean - dirsToClean <- newIORef mempty - let dflags = (hsc_dflags env){filesToClean=filesToClean, dirsToClean=dirsToClean, useUnicode=True} - ref <- newIORef env{hsc_dflags=dflags} - res <- unGhc act (Session ref) `finally` do - cleanTempFiles dflags - cleanTempDirs dflags + hsc_env <- initTempFs env + ref <- newIORef hsc_env + res <- unGhc (withCleanupSession act) (Session ref) (,res) <$> readIORef ref -- | Given a module location, and its parse tree, figure out what is the include directory implied by it. @@ -218,7 +238,7 @@ -- _ <- hClose_help h2_ -- hClose_help does two things: -- 1. It flushes the buffer, we replicate this here - _ <- flushWriteBuffer h2_ `catch` \(_ :: IOException) -> pure () + _ <- flushWriteBuffer h2_ `E.catch` \(_ :: IOException) -> pure () -- 2. It closes the handle. This is redundant since dup2 takes care of that -- but even worse it is actively harmful! Once the handle has been closed -- another thread is free to reallocate it. This leads to dup2 failing with EBUSY diff --git a/src/Development/IDE/GHC/Warnings.hs b/src/Development/IDE/GHC/Warnings.hs --- a/src/Development/IDE/GHC/Warnings.hs +++ b/src/Development/IDE/GHC/Warnings.hs @@ -4,15 +4,11 @@ module Development.IDE.GHC.Warnings(withWarnings) where -import Data.List -import ErrUtils -import GhcPlugins as GHC hiding (Var, (<>)) - import Control.Concurrent.Strict +import Data.List import qualified Data.Text as T -import Development.IDE.GHC.Compat (LogActionCompat, - logActionCompat) +import Development.IDE.GHC.Compat import Development.IDE.GHC.Error import Development.IDE.Types.Diagnostics import Language.LSP.Types (type (|?) (..)) @@ -27,16 +23,20 @@ -- https://github.com/ghc/ghc/blob/5f1d949ab9e09b8d95319633854b7959df06eb58/compiler/main/GHC.hs#L623-L640 -- which basically says that log_action is taken from the ModSummary when GHC feels like it. -- The given argument lets you refresh a ModSummary log_action -withWarnings :: T.Text -> ((ModSummary -> ModSummary) -> IO a) -> IO ([(WarnReason, FileDiagnostic)], a) +withWarnings :: T.Text -> ((HscEnv -> HscEnv) -> IO a) -> IO ([(WarnReason, FileDiagnostic)], a) withWarnings diagSource action = do warnings <- newVar [] let newAction :: LogActionCompat newAction dynFlags wr _ loc prUnqual msg = do let wr_d = map ((wr,) . third3 (attachReason wr)) $ diagFromErrMsg diagSource dynFlags $ mkWarnMsg dynFlags loc prUnqual msg modifyVar_ warnings $ return . (wr_d:) - res <- action $ \x -> x{ms_hspp_opts = (ms_hspp_opts x){log_action = logActionCompat newAction}} + newLogger env = pushLogHook (const (logActionCompat newAction)) (hsc_logger env) + res <- action $ \env -> putLogHook (newLogger env) env warns <- readVar warnings return (reverse $ concat warns, res) + where + third3 :: (c -> d) -> (a, b, c) -> (a, b, d) + third3 f (a, b, c) = (a, b, f c) attachReason :: WarnReason -> Diagnostic -> Diagnostic attachReason wr d = d{_code = InR <$> showReason wr} diff --git a/src/Development/IDE/Import/FindImports.hs b/src/Development/IDE/Import/FindImports.hs --- a/src/Development/IDE/Import/FindImports.hs +++ b/src/Development/IDE/Import/FindImports.hs @@ -13,25 +13,19 @@ , mkImportDirs ) where +import Control.DeepSeq import Development.IDE.GHC.Compat as Compat +import Development.IDE.GHC.Compat.Util import Development.IDE.GHC.Error as ErrUtils import Development.IDE.GHC.Orphans () import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location --- GHC imports -import Control.DeepSeq -import FastString -import Finder -import qualified Module as M -import Outputable (ppr, pprPanic, showSDoc) -import Packages -- standard imports import Control.Monad.Extra import Control.Monad.IO.Class import Data.List (isSuffixOf) import Data.Maybe -import DriverPhases import System.FilePath data Import @@ -75,7 +69,7 @@ -> m (Maybe NormalizedFilePath) locateModuleFile import_dirss exts targetFor isSource modName = do let candidates import_dirs = - [ toNormalizedFilePath' (prefix M.moduleNameSlashes modName <.> maybeBoot ext) + [ toNormalizedFilePath' (prefix moduleNameSlashes modName <.> maybeBoot ext) | prefix <- import_dirs , ext <- exts] firstJustM (targetFor modName) (concatMap candidates import_dirss) where @@ -87,22 +81,22 @@ -- It only returns Just for unit-ids which are possible to import into the -- current module. In particular, it will return Nothing for 'main' components -- as they can never be imported into another package. -mkImportDirs :: DynFlags -> (Compat.InstalledUnitId, DynFlags) -> Maybe (PackageName, [FilePath]) -mkImportDirs df (i, DynFlags{importPaths}) = (, importPaths) <$> getPackageName df i +mkImportDirs :: HscEnv -> (UnitId, DynFlags) -> Maybe (PackageName, [FilePath]) +mkImportDirs env (i, flags) = (, importPaths flags) <$> getUnitName env i -- | locate a module in either the file system or the package database. Where we go from *daml to -- Haskell locateModule :: MonadIO m - => DynFlags - -> [(Compat.InstalledUnitId, DynFlags)] -- ^ Import directories + => HscEnv + -> [(UnitId, DynFlags)] -- ^ Import directories -> [String] -- ^ File extensions -> (ModuleName -> NormalizedFilePath -> m (Maybe NormalizedFilePath)) -- ^ does file exist predicate -> Located ModuleName -- ^ Module name -> Maybe FastString -- ^ Package name -> Bool -- ^ Is boot module -> m (Either [FileDiagnostic] Import) -locateModule dflags comp_info exts targetFor modName mbPkgName isSource = do +locateModule env comp_info exts targetFor modName mbPkgName isSource = do case mbPkgName of -- "this" means that we should only look in the current package Just "this" -> do @@ -111,7 +105,7 @@ Just pkgName | Just dirs <- lookup (PackageName pkgName) import_paths -> lookupLocal [dirs] - | otherwise -> lookupInPackageDB dflags + | otherwise -> lookupInPackageDB env Nothing -> do -- first try to find the module as a file. If we can't find it try to find it in the package -- database. @@ -120,10 +114,11 @@ -- each component will end up being found in the wrong place and cause a multi-cradle match failure. mbFile <- locateModuleFile (importPaths dflags : map snd import_paths) exts targetFor isSource $ unLoc modName case mbFile of - Nothing -> lookupInPackageDB dflags + Nothing -> lookupInPackageDB env Just file -> toModLocation file where - import_paths = mapMaybe (mkImportDirs dflags) comp_info + dflags = hsc_dflags env + import_paths = mapMaybe (mkImportDirs env) comp_info toModLocation file = liftIO $ do loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file) return $ Right $ FileImport $ ArtifactsLocation file (Just loc) (not isSource) @@ -131,20 +126,21 @@ lookupLocal dirs = do mbFile <- locateModuleFile dirs exts targetFor isSource $ unLoc modName case mbFile of - Nothing -> return $ Left $ notFoundErr dflags modName $ LookupNotFound [] + Nothing -> return $ Left $ notFoundErr env modName $ LookupNotFound [] Just file -> toModLocation file - lookupInPackageDB dfs = - case oldLookupModuleWithSuggestions dfs (unLoc modName) mbPkgName of + lookupInPackageDB env = + case Compat.lookupModuleWithSuggestions env (unLoc modName) mbPkgName of LookupFound _m _pkgConfig -> return $ Right PackageImport - reason -> return $ Left $ notFoundErr dfs modName reason + reason -> return $ Left $ notFoundErr env modName reason -- | Don't call this on a found module. -notFoundErr :: DynFlags -> Located M.ModuleName -> LookupResult -> [FileDiagnostic] -notFoundErr dfs modName reason = - mkError' $ ppr' $ cannotFindModule dfs modName0 $ lookupToFindResult reason +notFoundErr :: HscEnv -> Located ModuleName -> LookupResult -> [FileDiagnostic] +notFoundErr env modName reason = + mkError' $ ppr' $ cannotFindModule env modName0 $ lookupToFindResult reason where - mkError' = diagFromString "not found" DsError (getLoc modName) + dfs = hsc_dflags env + mkError' = diagFromString "not found" DsError (Compat.getLoc modName) modName0 = unLoc modName ppr' = showSDoc dfs -- We convert the lookup result to a find result to reuse GHC's cannotFindMoudle pretty printer. @@ -155,12 +151,12 @@ LookupMultiple rs -> FoundMultiple rs LookupHidden pkg_hiddens mod_hiddens -> notFound - { fr_pkgs_hidden = map (moduleUnitId . fst) pkg_hiddens - , fr_mods_hidden = map (moduleUnitId . fst) mod_hiddens + { fr_pkgs_hidden = map (moduleUnit . fst) pkg_hiddens + , fr_mods_hidden = map (moduleUnit . fst) mod_hiddens } LookupUnusable unusable -> let unusables' = map get_unusable unusable - get_unusable (m, ModUnusable r) = (moduleUnitId m, r) + get_unusable (m, ModUnusable r) = (moduleUnit m, r) get_unusable (_, r) = pprPanic "findLookupResult: unexpected origin" (ppr r) in notFound {fr_unusables = unusables'} diff --git a/src/Development/IDE/LSP/Outline.hs b/src/Development/IDE/LSP/Outline.hs --- a/src/Development/IDE/LSP/Outline.hs +++ b/src/Development/IDE/LSP/Outline.hs @@ -29,8 +29,6 @@ SymbolKind (SkConstructor, SkField, SkFile, SkFunction, SkInterface, SkMethod, SkModule, SkObject, SkStruct, SkTypeParameter, SkUnknown), TextDocumentIdentifier (TextDocumentIdentifier), type (|?) (InL), uriToFilePath) -import Outputable (Outputable, ppr, - showSDocUnsafe) moduleOutline :: IdeState -> DocumentSymbolParams -> LspM c (Either ResponseError (List DocumentSymbol |? List SymbolInformation)) @@ -44,7 +42,7 @@ -> let declSymbols = mapMaybe documentSymbolForDecl hsmodDecls moduleSymbol = hsmodName >>= \case - (L (OldRealSrcSpan l) m) -> Just $ + (L (RealSrcSpan l _) m) -> Just $ (defDocumentSymbol l :: DocumentSymbol) { _name = pprText m , _kind = SkFile @@ -73,7 +71,7 @@ Nothing -> pure $ Right $ InL (List []) documentSymbolForDecl :: Located (HsDecl GhcPs) -> Maybe DocumentSymbol -documentSymbolForDecl (L (OldRealSrcSpan l) (TyClD _ FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } })) +documentSymbolForDecl (L (RealSrcSpan l _) (TyClD _ FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName n <> (case pprText fdTyVars of @@ -83,7 +81,7 @@ , _detail = Just $ pprText fdInfo , _kind = SkFunction } -documentSymbolForDecl (L (OldRealSrcSpan l) (TyClD _ ClassDecl { tcdLName = L _ name, tcdSigs, tcdTyVars })) +documentSymbolForDecl (L (RealSrcSpan l _) (TyClD _ ClassDecl { tcdLName = L _ name, tcdSigs, tcdTyVars })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName name <> (case pprText tcdTyVars of @@ -99,11 +97,11 @@ , _kind = SkMethod , _selectionRange = realSrcSpanToRange l' } - | L (OldRealSrcSpan l) (ClassOpSig _ False names _) <- tcdSigs - , L (OldRealSrcSpan l') n <- names + | L (RealSrcSpan l _) (ClassOpSig _ False names _) <- tcdSigs + , L (RealSrcSpan l' _) n <- names ] } -documentSymbolForDecl (L (OldRealSrcSpan l) (TyClD _ DataDecl { tcdLName = L _ name, tcdDataDefn = HsDataDefn { dd_cons } })) +documentSymbolForDecl (L (RealSrcSpan l _) (TyClD _ DataDecl { tcdLName = L _ name, tcdDataDefn = HsDataDefn { dd_cons } })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName name , _kind = SkStruct @@ -115,8 +113,8 @@ , _selectionRange = realSrcSpanToRange l' , _children = conArgRecordFields (con_args x) } - | L (OldRealSrcSpan l ) x <- dd_cons - , L (OldRealSrcSpan l') n <- getConNames' x + | L (RealSrcSpan l _ ) x <- dd_cons + , L (RealSrcSpan l' _) n <- getConNames' x ] } where @@ -127,48 +125,48 @@ , _kind = SkField } | L _ cdf <- lcdfs - , L (OldRealSrcSpan l) n <- rdrNameFieldOcc . unLoc <$> cd_fld_names cdf + , L (RealSrcSpan l _) n <- rdrNameFieldOcc . unLoc <$> cd_fld_names cdf ] conArgRecordFields _ = Nothing -documentSymbolForDecl (L (OldRealSrcSpan l) (TyClD _ SynDecl { tcdLName = L (OldRealSrcSpan l') n })) = Just +documentSymbolForDecl (L (RealSrcSpan l _) (TyClD _ SynDecl { tcdLName = L (RealSrcSpan l' _) n })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName n , _kind = SkTypeParameter , _selectionRange = realSrcSpanToRange l' } -documentSymbolForDecl (L (OldRealSrcSpan l) (InstD _ ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } })) +documentSymbolForDecl (L (RealSrcSpan l _) (InstD _ ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = pprText cid_poly_ty , _kind = SkInterface } -documentSymbolForDecl (L (OldRealSrcSpan l) (InstD _ DataFamInstD { dfid_inst = DataFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } })) +documentSymbolForDecl (L (RealSrcSpan l _) (InstD _ DataFamInstD { dfid_inst = DataFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords (map pprText feqn_pats) , _kind = SkInterface } -documentSymbolForDecl (L (OldRealSrcSpan l) (InstD _ TyFamInstD { tfid_inst = TyFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } })) +documentSymbolForDecl (L (RealSrcSpan l _) (InstD _ TyFamInstD { tfid_inst = TyFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords (map pprText feqn_pats) , _kind = SkInterface } -documentSymbolForDecl (L (OldRealSrcSpan l) (DerivD _ DerivDecl { deriv_type })) = +documentSymbolForDecl (L (RealSrcSpan l _) (DerivD _ DerivDecl { deriv_type })) = gfindtype deriv_type <&> \(L (_ :: SrcSpan) name) -> (defDocumentSymbol l :: DocumentSymbol) { _name = pprText @(HsType GhcPs) name , _kind = SkInterface } -documentSymbolForDecl (L (OldRealSrcSpan l) (ValD _ FunBind{fun_id = L _ name})) = Just +documentSymbolForDecl (L (RealSrcSpan l _) (ValD _ FunBind{fun_id = L _ name})) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName name , _kind = SkFunction } -documentSymbolForDecl (L (OldRealSrcSpan l) (ValD _ PatBind{pat_lhs})) = Just +documentSymbolForDecl (L (RealSrcSpan l _) (ValD _ PatBind{pat_lhs})) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = pprText pat_lhs , _kind = SkFunction } -documentSymbolForDecl (L (OldRealSrcSpan l) (ForD _ x)) = Just +documentSymbolForDecl (L (RealSrcSpan l _) (ForD _ x)) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = case x of ForeignImport{} -> name @@ -202,7 +200,7 @@ } documentSymbolForImport :: Located (ImportDecl GhcPs) -> Maybe DocumentSymbol -documentSymbolForImport (L (OldRealSrcSpan l) ImportDecl { ideclName, ideclQualified }) = Just +documentSymbolForImport (L (RealSrcSpan l _) ImportDecl { ideclName, ideclQualified }) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = "import " <> pprText ideclName , _kind = SkModule diff --git a/src/Development/IDE/Plugin/CodeAction.hs b/src/Development/IDE/Plugin/CodeAction.hs --- a/src/Development/IDE/Plugin/CodeAction.hs +++ b/src/Development/IDE/Plugin/CodeAction.hs @@ -18,8 +18,6 @@ , matchRegExMultipleImports ) where -import Bag (bagToList, - isEmptyBag) import Control.Applicative ((<|>)) import Control.Arrow (second, (>>>)) @@ -44,6 +42,7 @@ import Development.IDE.Core.Rules import Development.IDE.Core.Service import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat.Util import Development.IDE.GHC.Error import Development.IDE.GHC.Util (prettyPrint, printRdrName, @@ -57,8 +56,6 @@ import Development.IDE.Types.Location import Development.IDE.Types.Options import qualified GHC.LanguageExtensions as Lang -import HscTypes (ImportedModsVal (..), - importedByUser) import Ide.PluginUtils (subRange) import Ide.Types import qualified Language.LSP.Server as LSP @@ -77,18 +74,6 @@ type (|?) (InR), uriToFilePath) import Language.LSP.VFS -import Module (moduleEnvElts) -import OccName -import Outputable (Outputable, - ppr, - showSDoc, - showSDocUnsafe) -import RdrName (GlobalRdrElt (..), - lookupGlobalRdrEnv) -import SrcLoc (realSrcSpanEnd, - realSrcSpanStart) -import TcRnTypes (ImportAvails (..), - TcGblEnv (..)) import Text.Regex.TDFA (mrAfter, (=~), (=~~)) @@ -256,7 +241,7 @@ | Just tcM <- mTcM, Just har <- mHar, [s'] <- [x | (x, "") <- readSrcSpan $ T.unpack s], - isUnusedImportedId tcM har (T.unpack identifier) (T.unpack modName) (OldRealSrcSpan s'), + isUnusedImportedId tcM har (T.unpack identifier) (T.unpack modName) (RealSrcSpan s' Nothing), mDecl <- findImportDeclByModuleName hsmodImports $ T.unpack modName, title <- "Hide " <> identifier <> " from " <> modName = if modName == "Prelude" && null mDecl @@ -440,10 +425,10 @@ findRelatedSpans indexedContent name - (L (OldRealSrcSpan l) (ValD _ (extractNameAndMatchesFromFunBind -> Just (lname, matches)))) = + (L (RealSrcSpan l _) (ValD _ (extractNameAndMatchesFromFunBind -> Just (lname, matches)))) = case lname of (L nLoc _name) | isTheBinding nLoc -> - let findSig (L (OldRealSrcSpan l) (SigD _ sig)) = findRelatedSigSpan indexedContent name l sig + let findSig (L (RealSrcSpan l _) (SigD _ sig)) = findRelatedSigSpan indexedContent name l sig findSig _ = [] in extendForSpaces indexedContent (toRange l) : @@ -466,7 +451,7 @@ let maybeSpan = findRelatedSigSpan1 name sig in case maybeSpan of Just (_span, True) -> pure $ extendForSpaces indexedContent $ toRange l -- a :: Int - Just (OldRealSrcSpan span, False) -> pure $ toRange span -- a, b :: Int, a is unused + Just (RealSrcSpan span _, False) -> pure $ toRange span -- a, b :: Int, a is unused _ -> [] -- Second of the tuple means there is only one match @@ -517,10 +502,10 @@ indexedContent name lsigs - (L (OldRealSrcSpan l) (extractNameAndMatchesFromFunBind -> Just (lname, matches))) = + (L (RealSrcSpan l _) (extractNameAndMatchesFromFunBind -> Just (lname, matches))) = if isTheBinding (getLoc lname) then - let findSig (L (OldRealSrcSpan l) sig) = findRelatedSigSpan indexedContent name l sig + let findSig (L (RealSrcSpan l _) sig) = findRelatedSigSpan indexedContent name l sig findSig _ = [] in extendForSpaces indexedContent (toRange l) : concatMap findSig lsigs else concatMap (findRelatedSpanForMatch indexedContent name) matches @@ -562,7 +547,7 @@ -- we get the last export and the closing bracket and check for comma in that range needsComma :: T.Text -> Located [LIE GhcPs] -> Bool needsComma _ (L _ []) = False - needsComma source (L (OldRealSrcSpan l) exports) = + needsComma source (L (RealSrcSpan l _) exports) = let closeParan = _end $ realSrcSpanToRange l lastExport = fmap _end . getLocatedRange $ last exports in case lastExport of @@ -690,7 +675,7 @@ newDefinitionAction IdeOptions{..} parsedModule Range{_start} name typ | Range _ lastLineP : _ <- [ realSrcSpanToRange sp - | (L l@(OldRealSrcSpan sp) _) <- hsmodDecls + | (L l@(RealSrcSpan sp _) _) <- hsmodDecls , _start `isInsideSrcSpan` l] , nextLineP <- Position{ _line = _line lastLineP + 1, _character = 0} = [ ("Define " <> sig @@ -1015,10 +1000,10 @@ liftParseAST @(HsExpr GhcPs) df $ prettyPrint $ HsVar @GhcPs noExtField $ - L (oldUnhelpfulSpan "") rdr + L (mkGeneralSrcSpan "") rdr else Rewrite (rangeToSrcSpan "" _range) $ \df -> liftParseAST @RdrName df $ - prettyPrint $ L (oldUnhelpfulSpan "") rdr + prettyPrint $ L (mkGeneralSrcSpan "") rdr ] findImportDeclByRange :: [LImportDecl GhcPs] -> Range -> Maybe (LImportDecl GhcPs) @@ -1316,7 +1301,7 @@ findPositionFromImportsOrModuleDecl :: HasSrcSpan a => t -> (t -> a) -> Bool -> Maybe ((Int, Int), Int) findPositionFromImportsOrModuleDecl hsField f hasImports = case getLoc (f hsField) of - OldRealSrcSpan s -> + RealSrcSpan s _ -> let col = calcCol s in Just ((srcLocLine (realSrcSpanEnd s), col), col) _ -> Nothing diff --git a/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs b/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs --- a/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs +++ b/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs @@ -29,21 +29,17 @@ import Data.Maybe (fromJust, isNothing, mapMaybe) import qualified Data.Text as T -import Development.IDE.GHC.Compat hiding (parseExpr) +import Development.IDE.GHC.Compat +import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.GHC.Error import Development.IDE.GHC.ExactPrint (ASTElement (parseAST), Annotate) import Development.IDE.Spans.Common -import FieldLabel (flLabel) import GHC.Exts (IsList (fromList)) -import GhcPlugins (mkRdrUnqual, sigPrec) import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Types (DeltaPos (DP), KeywordId (G), mkAnnKey) import Language.LSP.Types -import OccName -import Outputable (ppr, showSDocUnsafe) -import Retrie.GHC (rdrNameOcc, unpackFS) ------------------------------------------------------------------------------ @@ -453,5 +449,5 @@ ty wild (filter ((/= symbol) . unqualIEWrapName . unLoc) cons) - (filter ((/= symbol) . T.pack . unpackFS . flLabel . unLoc) flds) + (filter ((/= symbol) . T.pack . Util.unpackFS . flLabel . unLoc) flds) killLie v = Just v diff --git a/src/Development/IDE/Plugin/Completions.hs b/src/Development/IDE/Plugin/Completions.hs --- a/src/Development/IDE/Plugin/Completions.hs +++ b/src/Development/IDE/Plugin/Completions.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} @@ -31,7 +30,7 @@ import Development.IDE.GHC.Util (prettyPrint) import Development.IDE.Graph import Development.IDE.Graph.Classes -import Development.IDE.Import.FindImports +import qualified Development.IDE.Types.KnownTargets as KT import Development.IDE.Plugin.CodeAction (newImport, newImportToEdit) import Development.IDE.Plugin.CodeAction.ExactPrint @@ -48,11 +47,6 @@ import qualified Language.LSP.Server as LSP import Language.LSP.Types import qualified Language.LSP.VFS as VFS -#if MIN_VERSION_ghc(9,0,0) -import GHC.Tc.Module (tcRnImportDecls) -#else -import TcRnDriver (tcRnImportDecls) -#endif descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) @@ -139,7 +133,9 @@ nonLocalCompls <- useWithStaleFast NonLocalCompletions npath pm <- useWithStaleFast GetParsedModule npath binds <- fromMaybe (mempty, zeroMapping) <$> useWithStaleFast GetBindings npath - + knownTargets <- liftIO $ runAction "Completion" ide $ useNoFile GetKnownTargets + let localModules = maybe [] Map.keys knownTargets + let lModules = mempty{importableModules = map toModueNameText localModules} -- set up the exports map including both package and project-level identifiers packageExportsMapIO <- fmap(envPackageExports . fst) <$> useWithStaleFast GhcSession npath packageExportsMap <- mapM liftIO packageExportsMapIO @@ -149,7 +145,7 @@ let moduleExports = getModuleExportsMap exportsMap exportsCompItems = foldMap (map (fromIdentInfo uri) . Set.toList) . Map.elems . getExportsMap $ exportsMap exportsCompls = mempty{anyQualCompls = exportsCompItems} - let compls = (fst <$> localCompls) <> (fst <$> nonLocalCompls) <> Just exportsCompls + let compls = (fst <$> localCompls) <> (fst <$> nonLocalCompls) <> Just exportsCompls <> Just lModules pure (opts, fmap (,pm,binds) compls, moduleExports) case compls of @@ -168,6 +164,11 @@ _ -> return (InL $ List []) ---------------------------------------------------------------------------------------------------- + +toModueNameText :: KT.Target -> T.Text +toModueNameText target = case target of + KT.TargetModule m -> T.pack $ moduleNameString m + _ -> T.empty extendImportCommand :: PluginCommand IdeState extendImportCommand = diff --git a/src/Development/IDE/Plugin/Completions/Logic.hs b/src/Development/IDE/Plugin/Completions/Logic.hs --- a/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/src/Development/IDE/Plugin/Completions/Logic.hs @@ -24,29 +24,19 @@ listToMaybe, mapMaybe) import qualified Data.Text as T -import qualified Text.Fuzzy as Fuzzy - -import HscTypes -import Name -import RdrName -import Type -#if MIN_VERSION_ghc(8,10,0) -import Coercion -import Pair -import Predicate (isDictTy) -#endif +import qualified Text.Fuzzy.Parallel as Fuzzy -import ConLike import Control.Monad import Data.Aeson (ToJSON (toJSON)) import Data.Either (fromRight) import Data.Functor import qualified Data.HashMap.Strict as HM -import qualified Data.Set as Set import qualified Data.HashSet as HashSet +import qualified Data.Set as Set import Development.IDE.Core.Compile import Development.IDE.Core.PositionMapping -import Development.IDE.GHC.Compat as GHC +import Development.IDE.GHC.Compat as GHC hiding (ppr) +import Development.IDE.GHC.Compat.Util import Development.IDE.GHC.Error import Development.IDE.GHC.Util import Development.IDE.Plugin.Completions.Types @@ -56,16 +46,17 @@ import Development.IDE.Types.Exports import Development.IDE.Types.HscEnvEq import Development.IDE.Types.Options -import GhcPlugins (flLabel, unpackFS) import Ide.PluginUtils (mkLspCommand) import Ide.Types (CommandId (..), PluginId) import Language.LSP.Types import Language.LSP.Types.Capabilities import qualified Language.LSP.VFS as VFS -import Outputable (Outputable) -import TyCoRep +-- Chunk size used for parallelizing fuzzy matching +chunkSize :: Int +chunkSize = 1000 + -- From haskell-ide-engine/hie-plugin-api/Haskell/Ide/Engine/Context.hs -- | A context of a declaration in the program @@ -164,7 +155,7 @@ -- Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet) -- Nothing Nothing Nothing Nothing Nothing -mkCompl :: PluginId -> IdeOptions -> CompItem -> IO CompletionItem +mkCompl :: PluginId -> IdeOptions -> CompItem -> CompletionItem mkCompl pId IdeOptions {..} @@ -178,7 +169,7 @@ docs, additionalTextEdits } = do - mbCommand <- mkAdditionalEditsCommand pId `traverse` additionalTextEdits + let mbCommand = mkAdditionalEditsCommand pId `fmap` additionalTextEdits let ci = CompletionItem {_label = label, _kind = kind, @@ -197,7 +188,7 @@ _commitCharacters = Nothing, _command = mbCommand, _xdata = Nothing} - return $ removeSnippetsWhen (isJust isInfix) ci + removeSnippetsWhen (isJust isInfix) ci where kind = Just compKind docs' = imported : spanDocToMarkdown docs @@ -209,8 +200,8 @@ MarkupContent MkMarkdown $ T.intercalate sectionSeparator docs' -mkAdditionalEditsCommand :: PluginId -> ExtendImport -> IO Command -mkAdditionalEditsCommand pId edits = pure $ +mkAdditionalEditsCommand :: PluginId -> ExtendImport -> Command +mkAdditionalEditsCommand pId edits = mkLspCommand pId (CommandId extendImportCommandId) "extend import" (Just [toJSON edits]) mkNameCompItem :: Uri -> Maybe T.Text -> OccName -> ModuleName -> Maybe Type -> Maybe Backtick -> SpanDoc -> Maybe (LImportDecl GhcPs) -> CompItem @@ -266,7 +257,7 @@ getArgs t | isPredTy t = [] | isDictTy t = [] - | isForAllTy t = getArgs $ snd (splitForAllTys t) + | isForAllTy t = getArgs $ snd (splitForAllTyCoVars t) | isFunTy t = let (args, ret) = splitFunTys t in if isForAllTy ret @@ -334,7 +325,7 @@ packageState = hscEnv env curModName = moduleName curMod - importMap = Map.fromList [ (l, imp) | imp@(L (OldRealSrcSpan l) _) <- limports ] + importMap = Map.fromList [ (l, imp) | imp@(L (RealSrcSpan l _) _) <- limports ] iDeclToModName :: ImportDecl name -> ModuleName iDeclToModName = unLoc . ideclName @@ -503,14 +494,14 @@ ppr = T.pack . prettyPrint toggleSnippets :: ClientCapabilities -> CompletionsConfig -> CompletionItem -> CompletionItem -toggleSnippets ClientCapabilities {_textDocument} (CompletionsConfig with _) = - removeSnippetsWhen (not $ with && supported) +toggleSnippets ClientCapabilities {_textDocument} CompletionsConfig{..} = + removeSnippetsWhen (not $ enableSnippets && supported) where supported = Just True == (_textDocument >>= _completion >>= _completionItem >>= _snippetSupport) toggleAutoExtend :: CompletionsConfig -> CompItem -> CompItem -toggleAutoExtend (CompletionsConfig _ False) x = x {additionalTextEdits = Nothing} +toggleAutoExtend CompletionsConfig{enableAutoExtend=False} x = x {additionalTextEdits = Nothing} toggleAutoExtend _ x = x removeSnippetsWhen :: Bool -> CompletionItem -> CompletionItem @@ -548,12 +539,14 @@ -} pos = VFS.cursorPos prefixInfo + maxC = maxCompletions config + filtModNameCompls = map mkModCompl $ mapMaybe (T.stripPrefix enteredQual) - $ Fuzzy.simpleFilter fullPrefix allModNamesAsNS + $ Fuzzy.simpleFilter chunkSize fullPrefix allModNamesAsNS - filtCompls = map Fuzzy.original $ Fuzzy.filter prefixText ctxCompls "" "" label False + filtCompls = map Fuzzy.original $ Fuzzy.filter chunkSize prefixText ctxCompls "" "" label False where mcc = case maybe_parsed of @@ -600,7 +593,7 @@ filtListWith f list = [ f label - | label <- Fuzzy.simpleFilter fullPrefix list + | label <- Fuzzy.simpleFilter chunkSize fullPrefix list , enteredQual `T.isPrefixOf` label ] @@ -611,8 +604,8 @@ | otherwise = [] if - -- TODO: handle multiline imports - | "import " `T.isPrefixOf` fullLine + -- TODO: handle multiline imports + | "import " `T.isPrefixOf` fullLine && (List.length (words (T.unpack fullLine)) >= 2) && "(" `isInfixOf` T.unpack fullLine -> do @@ -628,8 +621,9 @@ -> return [] | otherwise -> do -- assumes that nubOrdBy is stable - let uniqueFiltCompls = nubOrdBy uniqueCompl filtCompls - compls <- mapM (mkCompl plId ideOpts) uniqueFiltCompls + -- nubOrd is very slow - take 10x the maximum configured + let uniqueFiltCompls = nubOrdBy uniqueCompl $ take (maxC*10) filtCompls + let compls = map (mkCompl plId ideOpts) uniqueFiltCompls return $ filtModNameCompls ++ filtKeywordCompls ++ map (toggleSnippets caps config) compls diff --git a/src/Development/IDE/Plugin/Completions/Types.hs b/src/Development/IDE/Plugin/Completions/Types.hs --- a/src/Development/IDE/Plugin/Completions/Types.hs +++ b/src/Development/IDE/Plugin/Completions/Types.hs @@ -9,15 +9,16 @@ import Control.DeepSeq import qualified Data.Map as Map import qualified Data.Text as T -import SrcLoc import Data.Aeson (FromJSON, ToJSON) import Data.Text (Text) +import Development.IDE.GHC.Compat import Development.IDE.Spans.Common import GHC.Generics (Generic) import Ide.Plugin.Config (Config) +import qualified Ide.Plugin.Config as Config import Ide.Plugin.Properties -import Ide.PluginUtils (usePropertyLsp) +import Ide.PluginUtils (getClientConfig, usePropertyLsp) import Ide.Types (PluginId) import Language.LSP.Server (MonadLsp) import Language.LSP.Types (CompletionItemKind (..), Uri) @@ -46,11 +47,13 @@ CompletionsConfig <$> usePropertyLsp #snippetsOn pId properties <*> usePropertyLsp #autoExtendOn pId properties + <*> (Config.maxCompletions <$> getClientConfig) data CompletionsConfig = CompletionsConfig { enableSnippets :: Bool, - enableAutoExtend :: Bool + enableAutoExtend :: Bool, + maxCompletions :: Int } data ExtendImport = ExtendImport diff --git a/src/Development/IDE/Plugin/Test.hs b/src/Development/IDE/Plugin/Test.hs --- a/src/Development/IDE/Plugin/Test.hs +++ b/src/Development/IDE/Plugin/Test.hs @@ -28,13 +28,11 @@ import Development.IDE.GHC.Compat import Development.IDE.Graph (Action) import Development.IDE.LSP.Server -import Development.IDE.Plugin import qualified Development.IDE.Plugin as P import Development.IDE.Types.Action import Development.IDE.Types.HscEnvEq (HscEnvEq (hscEnv)) import Development.IDE.Types.Location (fromUri) import GHC.Generics (Generic) -import GhcPlugins (HscEnv (hsc_dflags)) import Ide.Types import qualified Language.LSP.Server as LSP import Language.LSP.Types @@ -52,7 +50,7 @@ newtype WaitForIdeRuleResult = WaitForIdeRuleResult { ideResultSuccess::Bool} deriving newtype (FromJSON, ToJSON) -plugin :: Plugin c +plugin :: P.Plugin c plugin = def { P.pluginRules = return (), P.pluginHandlers = requestHandler (SCustomMethod "test") testRequestHandler' diff --git a/src/Development/IDE/Plugin/TypeLenses.hs b/src/Development/IDE/Plugin/TypeLenses.hs --- a/src/Development/IDE/Plugin/TypeLenses.hs +++ b/src/Development/IDE/Plugin/TypeLenses.hs @@ -12,7 +12,6 @@ GlobalBindingTypeSigsResult (..), ) where -import Avail (availsToNameSet) import Control.DeepSeq (rwhnf) import Control.Monad (mzero) import Control.Monad.Extra (whenMaybe) @@ -42,13 +41,6 @@ toNormalizedFilePath', uriToFilePath') import GHC.Generics (Generic) -import GhcPlugins (GlobalRdrEnv, - HscEnv (hsc_dflags), SDoc, - elemNameSet, getSrcSpan, - idName, mkRealSrcLoc, - realSrcLocSpan, - tidyOpenType) -import HscTypes (mkPrintUnqualified) import Ide.Plugin.Config (Config) import Ide.Plugin.Properties import Ide.PluginUtils (mkLspCommand, @@ -73,16 +65,6 @@ TextDocumentIdentifier (TextDocumentIdentifier), TextEdit (TextEdit), WorkspaceEdit (WorkspaceEdit)) -import Outputable (showSDocForUser) -import PatSyn (PatSyn, mkPatSyn, - patSynBuilder, - patSynFieldLabels, - patSynIsInfix, - patSynMatcher, patSynName, - patSynSig, pprPatSynType) -import TcEnv (tcInitTidyEnv) -import TcRnMonad (initTcWithGbl) -import TcRnTypes (TcGblEnv (..)) import Text.Regex.TDFA ((=~), (=~~)) typeLensCommandId :: T.Text @@ -185,7 +167,7 @@ , Just TcModuleResult{tmrTypechecked = TcGblEnv{tcg_rdr_env, tcg_sigs}} <- mTmr , -- not a top-level thing, to avoid duplication not $ name `elemNameSet` tcg_sigs - , tyMsg <- showSDocForUser unsafeGlobalDynFlags (mkPrintUnqualified unsafeGlobalDynFlags tcg_rdr_env) $ pprSigmaType ty + , tyMsg <- printSDocQualifiedUnsafe (mkPrintUnqualifiedDefault tcg_rdr_env) $ pprSigmaType ty , signature <- T.pack $ printName name <> " :: " <> tyMsg , startCharacter <- _character _start , startOfLine <- Position (_line _start) startCharacter @@ -229,8 +211,8 @@ -------------------------------------------------------------------------------- -showDocRdrEnv :: DynFlags -> GlobalRdrEnv -> SDoc -> String -showDocRdrEnv dflags rdrEnv = showSDocForUser dflags (mkPrintUnqualified dflags rdrEnv) +showDocRdrEnv :: HscEnv -> GlobalRdrEnv -> SDoc -> String +showDocRdrEnv env rdrEnv = showSDocForUser (hsc_dflags env) (mkPrintUnqualified (hsc_dflags env) rdrEnv) data GetGlobalBindingTypeSigs = GetGlobalBindingTypeSigs deriving (Generic, Show, Eq, Ord, Hashable, NFData, Binary) @@ -269,9 +251,8 @@ sigs = tcg_sigs gblEnv binds = collectHsBindsBinders $ tcg_binds gblEnv patSyns = tcg_patsyns gblEnv - dflags = hsc_dflags hsc rdrEnv = tcg_rdr_env gblEnv - showDoc = showDocRdrEnv dflags rdrEnv + showDoc = showDocRdrEnv hsc rdrEnv hasSig :: (Monad m) => Name -> m a -> m (Maybe a) hasSig name f = whenMaybe (name `elemNameSet` sigs) f bindToSig id = do diff --git a/src/Development/IDE/Spans/AtPoint.hs b/src/Development/IDE/Spans/AtPoint.hs --- a/src/Development/IDE/Spans/AtPoint.hs +++ b/src/Development/IDE/Spans/AtPoint.hs @@ -30,25 +30,16 @@ import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes import Development.IDE.GHC.Compat +import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.Spans.Common import Development.IDE.Types.Options --- GHC API imports -import FastString (unpackFS) -import IfaceType -import Name -import NameEnv -import Outputable hiding ((<>)) -import SrcLoc -import TyCoRep hiding (FunTy) -import TyCon -import qualified Var - import Control.Applicative import Control.Monad.Extra import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe +import Data.Coerce (coerce) import qualified Data.HashMap.Strict as HM import qualified Data.Map.Strict as M import Data.Maybe @@ -130,12 +121,12 @@ Just mod -> do -- Look for references (strictly in project files, not dependencies), -- excluding the files in the FOIs (since those are in foiRefs) - rows <- liftIO $ findReferences hiedb True (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnitId mod) exclude + rows <- liftIO $ findReferences hiedb True (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnit mod) exclude pure $ mapMaybe rowToLoc rows typeRefs <- forM names $ \name -> case nameModule_maybe name of Just mod | isTcClsNameSpace (occNameSpace $ nameOccName name) -> do - refs <- liftIO $ findTypeRefs hiedb True (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnitId mod) exclude + refs <- liftIO $ findTypeRefs hiedb True (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnit mod) exclude pure $ mapMaybe typeRowToLoc refs _ -> pure [] pure $ nubOrd $ foiRefs ++ concat nonFOIRefs ++ concat typeRefs @@ -208,10 +199,10 @@ :: IdeOptions -> HieAstResult -> DocAndKindMap - -> DynFlags + -> HscEnv -> Position -> Maybe (Maybe Range, [T.Text]) -atPoint IdeOptions{} (HAR _ hf _ _ kind) (DKMap dm km) df pos = listToMaybe $ pointCommand hf pos hoverInfo +atPoint IdeOptions{} (HAR _ hf _ _ kind) (DKMap dm km) env pos = listToMaybe $ pointCommand hf pos hoverInfo where -- Hover info for values/data hoverInfo ast = (Just range, prettyNames ++ pTypes) @@ -240,10 +231,10 @@ prettyPackageName n = do m <- nameModule_maybe n - let pid = moduleUnitId m - conf <- lookupPackage df pid - let pkgName = T.pack $ packageNameString conf - version = T.pack $ showVersion (packageVersion conf) + let pid = moduleUnit m + conf <- lookupUnit env pid + let pkgName = T.pack $ unitPackageNameString conf + version = T.pack $ showVersion (unitPackageVersion conf) pure $ " *(" <> pkgName <> "-" <> version <> ")*" prettyTypes = map (("_ :: "<>) . prettyType) types @@ -300,10 +291,10 @@ in fmap nubOrd $ concatMapM (fmap (fromMaybe []) . nameToLocation hiedb lookupModule) (getTypes ts) namesInType :: Type -> [Name] -namesInType (TyVarTy n) = [Var.varName n] +namesInType (TyVarTy n) = [varName n] namesInType (AppTy a b) = getTypes [a,b] namesInType (TyConApp tc ts) = tyConName tc : getTypes ts -namesInType (ForAllTy b t) = Var.varName (binderVar b) : namesInType t +namesInType (ForAllTy b t) = varName (binderVar b) : namesInType t namesInType (FunTy a b) = getTypes [a,b] namesInType (CastTy t _) = namesInType t namesInType (LitTy _) = [] @@ -333,9 +324,9 @@ nameToLocation :: MonadIO m => HieDb -> LookupModule m -> Name -> m (Maybe [Location]) nameToLocation hiedb lookupModule name = runMaybeT $ case nameSrcSpan name of - sp@(OldRealSrcSpan rsp) + sp@(RealSrcSpan rsp _) -- Lookup in the db if we got a location in a boot file - | fs <- unpackFS (srcSpanFile rsp) + | fs <- Util.unpackFS (srcSpanFile rsp) , not $ "boot" `isSuffixOf` fs -> do itExists <- liftIO $ doesFileExist fs @@ -353,7 +344,7 @@ -- In this case the interface files contain garbage source spans -- so we instead read the .hie files to get useful source spans. mod <- MaybeT $ return $ nameModule_maybe name - erow <- liftIO $ findDef hiedb (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnitId mod) + erow <- liftIO $ findDef hiedb (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnit mod) case erow of [] -> do -- If the lookup failed, try again without specifying a unit-id. @@ -398,7 +389,17 @@ pointCommand :: HieASTs t -> Position -> (HieAST t -> a) -> [a] pointCommand hf pos k = catMaybes $ M.elems $ flip M.mapWithKey (getAsts hf) $ \fs ast -> - case selectSmallestContaining (sp fs) ast of + -- Since GHC 9.2: + -- getAsts :: Map HiePath (HieAst a) + -- type HiePath = LexialFastString + -- + -- but before: + -- getAsts :: Map HiePath (HieAst a) + -- type HiePath = FastString + -- + -- 'coerce' here to avoid an additional function for maintaining + -- backwards compatibility. + case selectSmallestContaining (sp $ coerce fs) ast of Nothing -> Nothing Just ast' -> Just $ k ast' where diff --git a/src/Development/IDE/Spans/Common.hs b/src/Development/IDE/Spans/Common.hs --- a/src/Development/IDE/Spans/Common.hs +++ b/src/Development/IDE/Spans/Common.hs @@ -23,20 +23,13 @@ import qualified Data.Text as T import GHC.Generics -import ConLike -import DynFlags import GHC -import NameEnv -import Outputable hiding ((<>)) -import Var -import Development.IDE.GHC.Compat (oldMkUserStyle, - oldRenderWithStyle) +import Development.IDE.GHC.Compat import Development.IDE.GHC.Orphans () import Development.IDE.GHC.Util import qualified Documentation.Haddock.Parser as H import qualified Documentation.Haddock.Types as H -import RdrName (rdrNameOcc) type DocMap = NameEnv SpanDoc type KindMap = NameEnv TyThing @@ -48,11 +41,7 @@ showSD = T.pack . unsafePrintSDoc showNameWithoutUniques :: Outputable a => a -> T.Text -showNameWithoutUniques = T.pack . prettyprint - where - dyn = unsafeGlobalDynFlags `gopt_set` Opt_SuppressUniques - prettyprint x = oldRenderWithStyle dyn (ppr x) style - style = oldMkUserStyle dyn neverQualify AllTheWay +showNameWithoutUniques = T.pack . printNameWithoutUniques -- | Shows IEWrappedName, without any modifier, qualifier or unique identifier. unqualIEWrapName :: IEWrappedName RdrName -> T.Text @@ -66,9 +55,9 @@ safeTyThingType _ = Nothing safeTyThingId :: TyThing -> Maybe Id -safeTyThingId (AnId i) = Just i -safeTyThingId (AConLike conLike) = conLikeWrapId_maybe conLike -safeTyThingId _ = Nothing +safeTyThingId (AnId i) = Just i +safeTyThingId (AConLike (RealDataCon dataCon)) = Just (dataConWrapId dataCon) +safeTyThingId _ = Nothing -- Possible documentation for an element in the code data SpanDoc diff --git a/src/Development/IDE/Spans/Documentation.hs b/src/Development/IDE/Spans/Documentation.hs --- a/src/Development/IDE/Spans/Documentation.hs +++ b/src/Development/IDE/Spans/Documentation.hs @@ -13,6 +13,7 @@ ) where import Control.Monad +import Control.Monad.IO.Class import Control.Monad.Extra (findM) import Data.Either import Data.Foldable @@ -24,20 +25,13 @@ import Development.IDE.Core.Compile import Development.IDE.Core.RuleTypes import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat.Util import Development.IDE.GHC.Error import Development.IDE.Spans.Common import System.Directory import System.FilePath -import ExtractDocs -import FastString -import GhcMonad -import HscTypes (HscEnv (hsc_dflags)) import Language.LSP.Types (filePathToUri, getUri) -import Name -import NameEnv -import SrcLoc (RealLocated) -import TcRnTypes mkDocMap :: HscEnv @@ -86,12 +80,11 @@ -- Get the uris to the documentation and source html pages if they exist getUris name = do - let df = hsc_dflags env (docFu, srcFu) <- case nameModule_maybe name of Just mod -> liftIO $ do - doc <- toFileUriText $ lookupDocHtmlForModule df mod - src <- toFileUriText $ lookupSrcHtmlForModule df mod + doc <- toFileUriText $ lookupDocHtmlForModule env mod + src <- toFileUriText $ lookupSrcHtmlForModule env mod return (doc, src) Nothing -> pure (Nothing, Nothing) let docUri = (<> "#" <> selector <> showNameWithoutUniques name) <$> docFu @@ -183,28 +176,28 @@ -- | Given a module finds the local @doc/html/Foo-Bar-Baz.html@ page. -- An example for a cabal installed module: -- @~/.cabal/store/ghc-8.10.1/vctr-0.12.1.2-98e2e861/share/doc/html/Data-Vector-Primitive.html@ -lookupDocHtmlForModule :: DynFlags -> Module -> IO (Maybe FilePath) +lookupDocHtmlForModule :: HscEnv -> Module -> IO (Maybe FilePath) lookupDocHtmlForModule = lookupHtmlForModule (\pkgDocDir modDocName -> pkgDocDir modDocName <.> "html") -- | Given a module finds the hyperlinked source @doc/html/src/Foo.Bar.Baz.html@ page. -- An example for a cabal installed module: -- @~/.cabal/store/ghc-8.10.1/vctr-0.12.1.2-98e2e861/share/doc/html/src/Data.Vector.Primitive.html@ -lookupSrcHtmlForModule :: DynFlags -> Module -> IO (Maybe FilePath) +lookupSrcHtmlForModule :: HscEnv -> Module -> IO (Maybe FilePath) lookupSrcHtmlForModule = lookupHtmlForModule (\pkgDocDir modDocName -> pkgDocDir "src" modDocName <.> "html") -lookupHtmlForModule :: (FilePath -> FilePath -> FilePath) -> DynFlags -> Module -> IO (Maybe FilePath) -lookupHtmlForModule mkDocPath df m = do +lookupHtmlForModule :: (FilePath -> FilePath -> FilePath) -> HscEnv -> Module -> IO (Maybe FilePath) +lookupHtmlForModule mkDocPath hscEnv m = do -- try all directories - let mfs = fmap (concatMap go) (lookupHtmls df ui) + let mfs = fmap (concatMap go) (lookupHtmls hscEnv ui) html <- findM doesFileExist (concat . maybeToList $ mfs) -- canonicalize located html to remove /../ indirection which can break some clients -- (vscode on Windows at least) traverse canonicalizePath html where go pkgDocDir = map (mkDocPath pkgDocDir) mns - ui = moduleUnitId m + ui = moduleUnit m -- try to locate html file from most to least specific name e.g. -- first Language.LSP.Types.Uri.html and Language-Haskell-LSP-Types-Uri.html -- then Language.LSP.Types.html and Language-Haskell-LSP-Types.html etc. @@ -213,8 +206,8 @@ -- The file might use "." or "-" as separator map (`intercalate` chunks) [".", "-"] -lookupHtmls :: DynFlags -> Unit -> Maybe [FilePath] +lookupHtmls :: HscEnv -> Unit -> Maybe [FilePath] lookupHtmls df ui = -- use haddockInterfaces instead of haddockHTMLs: GHC treats haddockHTMLs as URL not path -- and therefore doesn't expand $topdir on Windows - map takeDirectory . haddockInterfaces <$> lookupPackage df ui + map takeDirectory . unitHaddockInterfaces <$> lookupUnit df ui diff --git a/src/Development/IDE/Spans/LocalBindings.hs b/src/Development/IDE/Spans/LocalBindings.hs --- a/src/Development/IDE/Spans/LocalBindings.hs +++ b/src/Development/IDE/Spans/LocalBindings.hs @@ -20,12 +20,13 @@ import Development.IDE.GHC.Compat (Name, RefMap, Scope (..), Type, getBindSiteFromContext, getScopeFromContext, identInfo, - identType) + identType, NameEnv, nameEnvElts, + unitNameEnv, isSystemName, + RealSrcSpan, realSrcSpanStart, + realSrcSpanEnd) + import Development.IDE.GHC.Error import Development.IDE.Types.Location -import Name (isSystemName) -import NameEnv -import SrcLoc ------------------------------------------------------------------------------ -- | Turn a 'RealSrcSpan' into an 'Interval'. diff --git a/src/Development/IDE/Types/Exports.hs b/src/Development/IDE/Types/Exports.hs --- a/src/Development/IDE/Types/Exports.hs +++ b/src/Development/IDE/Types/Exports.hs @@ -7,10 +7,11 @@ createExportsMap, createExportsMapMg, createExportsMapTc, - buildModuleExportMapFrom -,createExportsMapHieDb,size) where + buildModuleExportMapFrom, + createExportsMapHieDb, + size, + ) where -import Avail (AvailInfo (..)) import Control.DeepSeq (NFData (..)) import Control.Monad import Data.Bifunctor (Bifunctor (second)) @@ -24,12 +25,8 @@ import Development.IDE.GHC.Compat import Development.IDE.GHC.Orphans () import Development.IDE.GHC.Util -import FieldLabel (flSelector) import GHC.Generics (Generic) -import GhcPlugins (IfaceExport, ModGuts (..)) import HieDb -import Name -import TcRnTypes (TcGblEnv (..)) data ExportsMap = ExportsMap @@ -81,8 +78,12 @@ occ = occName n mkIdentInfos :: Text -> AvailInfo -> [IdentInfo] -mkIdentInfos mod (Avail n) = +mkIdentInfos mod (AvailName n) = [IdentInfo (nameOccName n) (renderIEWrapped n) Nothing (isDataConName n) mod] +mkIdentInfos mod (AvailFL fl) = + [IdentInfo (nameOccName n) (renderIEWrapped n) Nothing (isDataConName n) mod] + where + n = flSelector fl mkIdentInfos mod (AvailTC parent (n:nn) flds) -- Following the GHC convention that parent == n if parent is exported | n == parent diff --git a/src/Development/IDE/Types/HscEnvEq.hs b/src/Development/IDE/Types/HscEnvEq.hs --- a/src/Development/IDE/Types/HscEnvEq.hs +++ b/src/Development/IDE/Types/HscEnvEq.hs @@ -11,37 +11,33 @@ ) where -import Control.Concurrent.Async (Async, async, waitCatch) -import Control.Concurrent.Strict (modifyVar, newVar) -import Control.DeepSeq (force) -import Control.Exception (evaluate, mask, throwIO) -import Control.Monad.Extra (eitherM, join, mapMaybeM) +import Control.Concurrent.Async (Async, async, waitCatch) +import Control.Concurrent.Strict (modifyVar, newVar) +import Control.DeepSeq (force) +import Control.Exception (evaluate, mask, throwIO) +import Control.Monad.Extra (eitherM, join, mapMaybeM) import Control.Monad.IO.Class -import Data.Either (fromRight) -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Unique +import Data.Either (fromRight) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Unique (Unique) +import qualified Data.Unique as Unique import Development.IDE.GHC.Compat -import Development.IDE.GHC.Error (catchSrcErrors) -import Development.IDE.GHC.Util (lookupPackageConfig) +import qualified Development.IDE.GHC.Compat.Util as Maybes +import Development.IDE.GHC.Error (catchSrcErrors) +import Development.IDE.GHC.Util (lookupPackageConfig) import Development.IDE.Graph.Classes -import Development.IDE.Types.Exports (ExportsMap, createExportsMap) -import GhcPlugins (HscEnv (hsc_dflags)) -import LoadIface (loadInterface) -import qualified Maybes --- import Module (InstalledUnitId) -import OpenTelemetry.Eventlog (withSpan) -import System.Directory (canonicalizePath) +import Development.IDE.Types.Exports (ExportsMap, createExportsMap) +import OpenTelemetry.Eventlog (withSpan) +import System.Directory (canonicalizePath) import System.FilePath -import TcRnMonad (WhereFrom (ImportByUser), - initIfaceLoad) -- | An 'HscEnv' with equality. Two values are considered equal -- if they are created with the same call to 'newHscEnvEq'. data HscEnvEq = HscEnvEq { envUnique :: !Unique , hscEnv :: !HscEnv - , deps :: [(InstalledUnitId, DynFlags)] + , deps :: [(UnitId, DynFlags)] -- ^ In memory components for this HscEnv -- This is only used at the moment for the import dirs in -- the DynFlags @@ -57,7 +53,7 @@ } -- | Wrap an 'HscEnv' into an 'HscEnvEq'. -newHscEnvEq :: FilePath -> HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq +newHscEnvEq :: FilePath -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq newHscEnvEq cradlePath hscEnv0 deps = do let relativeToCradle = (takeDirectory cradlePath ) hscEnv = removeImportPaths hscEnv0 @@ -68,29 +64,29 @@ newHscEnvEqWithImportPaths (Just $ Set.fromList importPathsCanon) hscEnv deps -newHscEnvEqWithImportPaths :: Maybe (Set FilePath) -> HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq +newHscEnvEqWithImportPaths :: Maybe (Set FilePath) -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq newHscEnvEqWithImportPaths envImportPaths hscEnv deps = do let dflags = hsc_dflags hscEnv - envUnique <- newUnique + envUnique <- Unique.newUnique -- it's very important to delay the package exports computation envPackageExports <- onceAsync $ withSpan "Package Exports" $ \_sp -> do -- compute the package imports - let pkgst = pkgState dflags - depends = explicitPackages pkgst + let pkgst = unitState hscEnv + depends = explicitUnits pkgst targets = [ (pkg, mn) | d <- depends , Just pkg <- [lookupPackageConfig d hscEnv] - , (mn, _) <- exposedModules pkg + , (mn, _) <- unitExposedModules pkg ] doOne (pkg, mn) = do modIface <- liftIO $ initIfaceLoad hscEnv $ loadInterface "" - (mkModule (packageConfigId pkg) mn) + (mkModule (unitInfoId pkg) mn) (ImportByUser NotBoot) return $ case modIface of Maybes.Failed _r -> Nothing @@ -104,13 +100,13 @@ <$> catchSrcErrors dflags "listVisibleModuleNames" - (evaluate . force . Just $ oldListVisibleModuleNames dflags) + (evaluate . force . Just $ listVisibleModuleNames hscEnv) return HscEnvEq{..} -- | Wrap an 'HscEnv' into an 'HscEnvEq'. newHscEnvEqPreserveImportPaths - :: HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq + :: HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq newHscEnvEqPreserveImportPaths = newHscEnvEqWithImportPaths Nothing -- | Unwrap the 'HscEnv' with the original import paths. @@ -118,15 +114,15 @@ hscEnvWithImportPaths :: HscEnvEq -> HscEnv hscEnvWithImportPaths HscEnvEq{..} | Just imps <- envImportPaths - = hscEnv{hsc_dflags = (hsc_dflags hscEnv){importPaths = Set.toList imps}} + = hscSetFlags (setImportPaths (Set.toList imps) (hsc_dflags hscEnv)) hscEnv | otherwise = hscEnv removeImportPaths :: HscEnv -> HscEnv -removeImportPaths hsc = hsc{hsc_dflags = (hsc_dflags hsc){importPaths = []}} +removeImportPaths hsc = hscSetFlags (setImportPaths [] (hsc_dflags hsc)) hsc instance Show HscEnvEq where - show HscEnvEq{envUnique} = "HscEnvEq " ++ show (hashUnique envUnique) + show HscEnvEq{envUnique} = "HscEnvEq " ++ show (Unique.hashUnique envUnique) instance Eq HscEnvEq where a == b = envUnique a == envUnique b @@ -134,7 +130,7 @@ instance NFData HscEnvEq where rnf (HscEnvEq a b c d _ _) = -- deliberately skip the package exports map and visible module names - rnf (hashUnique a) `seq` b `seq` c `seq` rnf d + rnf (Unique.hashUnique a) `seq` b `seq` c `seq` rnf d instance Hashable HscEnvEq where hashWithSalt s = hashWithSalt s . envUnique diff --git a/src/Development/IDE/Types/Location.hs b/src/Development/IDE/Types/Location.hs --- a/src/Development/IDE/Types/Location.hs +++ b/src/Development/IDE/Types/Location.hs @@ -31,11 +31,17 @@ import Data.Hashable (Hashable (hash)) import Data.Maybe (fromMaybe) import Data.String + +#if MIN_VERSION_ghc(9,0,0) +import GHC.Data.FastString +import GHC.Types.SrcLoc as GHC +#else import FastString +import SrcLoc as GHC +#endif import Language.LSP.Types (Location (..), Position (..), Range (..)) import qualified Language.LSP.Types as LSP -import SrcLoc as GHC import Text.ParserCombinators.ReadP as ReadP toNormalizedFilePath' :: FilePath -> LSP.NormalizedFilePath diff --git a/src/Development/IDE/Types/Options.hs b/src/Development/IDE/Types/Options.hs --- a/src/Development/IDE/Types/Options.hs +++ b/src/Development/IDE/Types/Options.hs @@ -160,10 +160,10 @@ -- | The set of options used to locate files belonging to external packages. data IdePkgLocationOptions = IdePkgLocationOptions - { optLocateHieFile :: PackageConfig -> Module -> IO (Maybe FilePath) + { optLocateHieFile :: UnitState -> Module -> IO (Maybe FilePath) -- ^ Locate the HIE file for the given module. The PackageConfig can be -- used to lookup settings like importDirs. - , optLocateSrcFile :: PackageConfig -> Module -> IO (Maybe FilePath) + , optLocateSrcFile :: UnitState -> Module -> IO (Maybe FilePath) -- ^ Locate the source file for the given module. The PackageConfig can be -- used to lookup settings like importDirs. For DAML, we place them in the package DB. -- For cabal this could point somewhere in ~/.cabal/packages. diff --git a/src/Text/Fuzzy/Parallel.hs b/src/Text/Fuzzy/Parallel.hs new file mode 100644 --- /dev/null +++ b/src/Text/Fuzzy/Parallel.hs @@ -0,0 +1,105 @@ +-- | Parallel versions of 'filter' and 'simpleFilter' +module Text.Fuzzy.Parallel +( filter, + simpleFilter, + -- reexports + Fuzzy(..), + match +) where + +import Control.Monad.ST (runST) +import Control.Parallel.Strategies (Eval, Strategy, evalTraversable, + parTraversable, rseq, using) +import Data.Function (on) +import Data.Monoid.Textual (TextualMonoid) +import Data.Ord (Down (Down)) +import Data.Vector (Vector, (!)) +import qualified Data.Vector as V +-- need to use a stable sort +import Data.Bifunctor (second) +import qualified Data.Vector.Algorithms.Tim as VA +import Prelude hiding (filter) +import Text.Fuzzy (Fuzzy (..), match) + +-- | The function to filter a list of values by fuzzy search on the text extracted from them. +-- +-- >>> length $ filter 1000 200 "ML" (concat $ replicate 10000 [("Standard ML", 1990),("OCaml",1996),("Scala",2003)]) "<" ">" fst False +-- 200 +filter :: (TextualMonoid s) + => Int -- ^ Chunk size. 1000 works well. + -> s -- ^ Pattern. + -> [t] -- ^ The list of values containing the text to search in. + -> s -- ^ The text to add before each match. + -> s -- ^ The text to add after each match. + -> (t -> s) -- ^ The function to extract the text from the container. + -> Bool -- ^ Case sensitivity. + -> [Fuzzy t s] -- ^ The list of results, sorted, highest score first. +filter chunkSize pattern ts pre post extract caseSen = runST $ do + let v = (V.mapMaybe id + (V.map (\t -> match pattern t pre post extract caseSen) (V.fromList ts) + `using` + parVectorChunk chunkSize (evalTraversable forceScore))) + v' <- V.unsafeThaw v + VA.sortBy (compare `on` (Down . score)) v' + v'' <- V.unsafeFreeze v' + return $ V.toList v'' + +-- | Return all elements of the list that have a fuzzy +-- match against the pattern. Runs with default settings where +-- nothing is added around the matches, as case insensitive. +-- +-- >>> simpleFilter "vm" ["vim", "emacs", "virtual machine"] +-- ["vim","virtual machine"] +{-# INLINABLE simpleFilter #-} +simpleFilter :: (TextualMonoid s) + => Int -- ^ Chunk size. 1000 works well. + -> s -- ^ Pattern to look for. + -> [s] -- ^ List of texts to check. + -> [s] -- ^ The ones that match. +simpleFilter chunk pattern xs = + map original $ filter chunk pattern xs mempty mempty id False + +-------------------------------------------------------------------------------- + +-- | Evaluation that forces the 'score' field +forceScore :: TextualMonoid s => Fuzzy t s -> Eval(Fuzzy t s) +forceScore it@Fuzzy{score} = do + score' <- rseq score + return it{score = score'} + +-------------------------------------------------------------------------------- + +-- | Divides a vector in chunks, applies the strategy in parallel to each chunk. +parVectorChunk :: Int -> Strategy a -> Vector a -> Eval (Vector a) +parVectorChunk chunkSize st v = + V.concat <$> parTraversable (evalTraversable st) (chunkVector chunkSize v) + +-- >>> chunkVector 3 (V.fromList [0..10]) +-- >>> chunkVector 3 (V.fromList [0..11]) +-- >>> chunkVector 3 (V.fromList [0..12]) +-- [[0,1,2],[3,4,5],[6,7,8],[9,10]] +-- [[0,1,2],[3,4,5],[6,7,8],[9,10,11]] +-- [[0,1,2],[3,4,5],[6,7,8],[9,10,11],[12]] +chunkVector :: Int -> Vector a -> [Vector a] +chunkVector chunkSize v = do + let indices = chunkIndices chunkSize (0,l) + l = V.length v + [V.fromListN (h-l+1) [v ! j | j <- [l .. h]] + | (l,h) <- indices] + +-- >>> chunkIndices 3 (0,9) +-- >>> chunkIndices 3 (0,10) +-- >>> chunkIndices 3 (0,11) +-- [(0,2),(3,5),(6,8)] +-- [(0,2),(3,5),(6,8),(9,9)] +-- [(0,2),(3,5),(6,8),(9,10)] +chunkIndices :: Int -> (Int,Int) -> [(Int,Int)] +chunkIndices chunkSize (from,to) = + map (second pred) $ + pairwise $ + [from, from+chunkSize .. to-1] ++ [to] + +pairwise :: [a] -> [(a,a)] +pairwise [] = [] +pairwise [_] = [] +pairwise (x:y:xs) = (x,y) : pairwise (y:xs) diff --git a/test/data/cabal-exe/dist-newstyle/build/x86_64-osx/ghc-8.10.3/a-0.1.0.0/x/a/build/a/autogen/Paths_a.hs b/test/data/cabal-exe/dist-newstyle/build/x86_64-osx/ghc-8.10.3/a-0.1.0.0/x/a/build/a/autogen/Paths_a.hs new file mode 100644 --- /dev/null +++ b/test/data/cabal-exe/dist-newstyle/build/x86_64-osx/ghc-8.10.3/a-0.1.0.0/x/a/build/a/autogen/Paths_a.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoRebindableSyntax #-} +{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} +module Paths_a ( + version, + getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, + getDataFileName, getSysconfDir + ) where + +import qualified Control.Exception as Exception +import Data.Version (Version(..)) +import System.Environment (getEnv) +import Prelude + +#if defined(VERSION_base) + +#if MIN_VERSION_base(4,0,0) +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#else +catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a +#endif + +#else +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#endif +catchIO = Exception.catch + +version :: Version +version = Version [0,1,0,0] [] +bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath + +bindir = "/Users/pepeiborra/.cabal/bin" +libdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.3/a-0.1.0.0-inplace-a" +dynlibdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.3" +datadir = "/Users/pepeiborra/.cabal/share/x86_64-osx-ghc-8.10.3/a-0.1.0.0" +libexecdir = "/Users/pepeiborra/.cabal/libexec/x86_64-osx-ghc-8.10.3/a-0.1.0.0" +sysconfdir = "/Users/pepeiborra/.cabal/etc" + +getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath +getBinDir = catchIO (getEnv "a_bindir") (\_ -> return bindir) +getLibDir = catchIO (getEnv "a_libdir") (\_ -> return libdir) +getDynLibDir = catchIO (getEnv "a_dynlibdir") (\_ -> return dynlibdir) +getDataDir = catchIO (getEnv "a_datadir") (\_ -> return datadir) +getLibexecDir = catchIO (getEnv "a_libexecdir") (\_ -> return libexecdir) +getSysconfDir = catchIO (getEnv "a_sysconfdir") (\_ -> return sysconfdir) + +getDataFileName :: FilePath -> IO FilePath +getDataFileName name = do + dir <- getDataDir + return (dir ++ "/" ++ name) diff --git a/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.2/a-1.0.0/build/autogen/Paths_a.hs b/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.2/a-1.0.0/build/autogen/Paths_a.hs new file mode 100644 --- /dev/null +++ b/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.2/a-1.0.0/build/autogen/Paths_a.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoRebindableSyntax #-} +{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} +module Paths_a ( + version, + getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, + getDataFileName, getSysconfDir + ) where + +import qualified Control.Exception as Exception +import Data.Version (Version(..)) +import System.Environment (getEnv) +import Prelude + +#if defined(VERSION_base) + +#if MIN_VERSION_base(4,0,0) +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#else +catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a +#endif + +#else +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#endif +catchIO = Exception.catch + +version :: Version +version = Version [1,0,0] [] +bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath + +bindir = "/Users/pepeiborra/.cabal/bin" +libdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.2/a-1.0.0-inplace" +dynlibdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.2" +datadir = "/Users/pepeiborra/.cabal/share/x86_64-osx-ghc-8.10.2/a-1.0.0" +libexecdir = "/Users/pepeiborra/.cabal/libexec/x86_64-osx-ghc-8.10.2/a-1.0.0" +sysconfdir = "/Users/pepeiborra/.cabal/etc" + +getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath +getBinDir = catchIO (getEnv "a_bindir") (\_ -> return bindir) +getLibDir = catchIO (getEnv "a_libdir") (\_ -> return libdir) +getDynLibDir = catchIO (getEnv "a_dynlibdir") (\_ -> return dynlibdir) +getDataDir = catchIO (getEnv "a_datadir") (\_ -> return datadir) +getLibexecDir = catchIO (getEnv "a_libexecdir") (\_ -> return libexecdir) +getSysconfDir = catchIO (getEnv "a_sysconfdir") (\_ -> return sysconfdir) + +getDataFileName :: FilePath -> IO FilePath +getDataFileName name = do + dir <- getDataDir + return (dir ++ "/" ++ name) diff --git a/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/a-1.0.0/build/autogen/Paths_a.hs b/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/a-1.0.0/build/autogen/Paths_a.hs new file mode 100644 --- /dev/null +++ b/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/a-1.0.0/build/autogen/Paths_a.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoRebindableSyntax #-} +{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} +module Paths_a ( + version, + getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, + getDataFileName, getSysconfDir + ) where + +import qualified Control.Exception as Exception +import Data.Version (Version(..)) +import System.Environment (getEnv) +import Prelude + +#if defined(VERSION_base) + +#if MIN_VERSION_base(4,0,0) +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#else +catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a +#endif + +#else +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#endif +catchIO = Exception.catch + +version :: Version +version = Version [1,0,0] [] +bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath + +bindir = "/Users/pepeiborra/.cabal/bin" +libdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.3/a-1.0.0-inplace" +dynlibdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.3" +datadir = "/Users/pepeiborra/.cabal/share/x86_64-osx-ghc-8.10.3/a-1.0.0" +libexecdir = "/Users/pepeiborra/.cabal/libexec/x86_64-osx-ghc-8.10.3/a-1.0.0" +sysconfdir = "/Users/pepeiborra/.cabal/etc" + +getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath +getBinDir = catchIO (getEnv "a_bindir") (\_ -> return bindir) +getLibDir = catchIO (getEnv "a_libdir") (\_ -> return libdir) +getDynLibDir = catchIO (getEnv "a_dynlibdir") (\_ -> return dynlibdir) +getDataDir = catchIO (getEnv "a_datadir") (\_ -> return datadir) +getLibexecDir = catchIO (getEnv "a_libexecdir") (\_ -> return libexecdir) +getSysconfDir = catchIO (getEnv "a_sysconfdir") (\_ -> return sysconfdir) + +getDataFileName :: FilePath -> IO FilePath +getDataFileName name = do + dir <- getDataDir + return (dir ++ "/" ++ name) diff --git a/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/b-1.0.0/build/autogen/Paths_b.hs b/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/b-1.0.0/build/autogen/Paths_b.hs new file mode 100644 --- /dev/null +++ b/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/b-1.0.0/build/autogen/Paths_b.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoRebindableSyntax #-} +{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} +module Paths_b ( + version, + getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, + getDataFileName, getSysconfDir + ) where + +import qualified Control.Exception as Exception +import Data.Version (Version(..)) +import System.Environment (getEnv) +import Prelude + +#if defined(VERSION_base) + +#if MIN_VERSION_base(4,0,0) +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#else +catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a +#endif + +#else +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#endif +catchIO = Exception.catch + +version :: Version +version = Version [1,0,0] [] +bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath + +bindir = "/Users/pepeiborra/.cabal/bin" +libdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.3/b-1.0.0-inplace" +dynlibdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.3" +datadir = "/Users/pepeiborra/.cabal/share/x86_64-osx-ghc-8.10.3/b-1.0.0" +libexecdir = "/Users/pepeiborra/.cabal/libexec/x86_64-osx-ghc-8.10.3/b-1.0.0" +sysconfdir = "/Users/pepeiborra/.cabal/etc" + +getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath +getBinDir = catchIO (getEnv "b_bindir") (\_ -> return bindir) +getLibDir = catchIO (getEnv "b_libdir") (\_ -> return libdir) +getDynLibDir = catchIO (getEnv "b_dynlibdir") (\_ -> return dynlibdir) +getDataDir = catchIO (getEnv "b_datadir") (\_ -> return datadir) +getLibexecDir = catchIO (getEnv "b_libexecdir") (\_ -> return libexecdir) +getSysconfDir = catchIO (getEnv "b_sysconfdir") (\_ -> return sysconfdir) + +getDataFileName :: FilePath -> IO FilePath +getDataFileName name = do + dir <- getDataDir + return (dir ++ "/" ++ name) diff --git a/test/exe/Main.hs b/test/exe/Main.hs --- a/test/exe/Main.hs +++ b/test/exe/Main.hs @@ -56,6 +56,7 @@ import Development.IDE.Test.Runfiles import qualified Development.IDE.Types.Diagnostics as Diagnostics import Development.IDE.Types.Location +import qualified Language.LSP.Types.Lens as Lens (label) import Development.Shake (getDirectoryFilesIO) import qualified Experiments as Bench import Ide.Plugin.Config @@ -4589,7 +4590,24 @@ <- compls , _label == "anidentifier" ] - liftIO $ compls' @?= ["Defined in 'A"] + liftIO $ compls' @?= ["Defined in 'A"], + testSession' "auto complete project imports" $ \dir-> do + liftIO $ writeFile (dir "hie.yaml") + "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"ALocalModule\", \"B\"]}}" + _ <- createDoc "ALocalModule.hs" "haskell" $ T.unlines + [ "module ALocalModule (anidentifier) where", + "anidentifier = ()" + ] + _ <- waitForDiagnostics + -- Note that B does not import A + doc <- createDoc "B.hs" "haskell" $ T.unlines + [ "module B where", + "import ALocal" + ] + compls <- getCompletions doc (Position 1 13) + let item = head $ filter ((== "ALocalModule") . (^. Lens.label)) compls + liftIO $ do + item ^. Lens.label @?= "ALocalModule" ] highlightTests :: TestTree