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.1 +version: 1.4.2.2 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.5 || == 8.8.3 || == 8.8.4 || == 8.10.5 || == 8.10.6 || == 8.10.7 || == 9.0.1 +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 extra-source-files: README.md CHANGELOG.md test/data/**/*.project test/data/**/*.cabal @@ -61,7 +61,7 @@ hie-compat ^>= 0.2.0.0, hls-plugin-api ^>= 1.2.0.0, lens, - hiedb == 0.4.1.*, + hiedb == 0.4.0.*, lsp-types >= 1.3.0.1 && < 1.4, lsp == 1.2.*, monoid-subclasses, @@ -112,6 +112,22 @@ 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 @@ -157,15 +173,6 @@ 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 @@ -217,14 +224,6 @@ 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 @@ -233,9 +232,6 @@ build-depends: base == 4.* - if !flag(test-exe) - buildable: False - benchmark benchHist type: exitcode-stdio-1.0 default-language: Haskell2010 @@ -274,10 +270,6 @@ text, yaml -flag executable - description: Build the ghcide executable - default: True - executable ghcide default-language: Haskell2010 hs-source-dirs: exe @@ -337,9 +329,6 @@ TypeApplications ViewPatterns - if !flag(executable) - buildable: False - test-suite ghcide-tests type: exitcode-stdio-1.0 default-language: Haskell2010 @@ -422,10 +411,6 @@ TypeApplications ViewPatterns -flag bench-exe - description: Build the ghcide-bench executable - default: True - executable ghcide-bench default-language: Haskell2010 build-tool-depends: @@ -470,6 +455,3 @@ 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 as Safe +import Control.Exception.Safe import Control.Monad import Control.Monad.Extra import Control.Monad.IO.Class @@ -42,13 +42,9 @@ import Data.Version import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake -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.Compat hiding (Target, + TargetFile, TargetModule) +import qualified Development.IDE.GHC.Compat as GHC import Development.IDE.GHC.Util import Development.IDE.Graph (Action) import Development.IDE.Session.VersionCheck @@ -75,6 +71,12 @@ 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 @@ -103,7 +105,7 @@ , getCacheDirs :: String -> [String] -> IO CacheDirs -- | Return the GHC lib dir to use for the 'unsafeGlobalDynFlags' , getInitialGhcLibDir :: FilePath -> IO (Maybe LibDir) - , fakeUid :: UnitId + , fakeUid :: GHC.InstalledUnitId -- ^ 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 @@ -116,7 +118,7 @@ ,loadCradle = loadWithImplicitCradle ,getCacheDirs = getCacheDirsDefault ,getInitialGhcLibDir = getInitialGhcLibDirDefault - ,fakeUid = Compat.toUnitId (Compat.stringToUnit "main") + ,fakeUid = GHC.toInstalledUnitId (GHC.stringToUnit "main") } -- | Find the cradle for a given 'hie.yaml' configuration. @@ -171,7 +173,7 @@ runWithDb fp k = do -- Delete the database if it has an incompatible schema version withHieDb fp (const $ pure ()) - `Safe.catch` \IncompatibleSchemaVersion{} -> removeFile fp + `catch` \IncompatibleSchemaVersion{} -> removeFile fp withHieDb fp $ \writedb -> do initConn writedb chan <- newTQueueIO @@ -185,15 +187,15 @@ forever $ do k <- atomically $ readTQueue chan k db - `Safe.catch` \e@SQLError{} -> do + `catch` \e@SQLError{} -> do hPutStrLn stderr $ "SQLite error in worker, ignoring: " ++ show e - `Safe.catchAny` \e -> do + `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, Compat.ghcVersionStr, hiedbDataVersion] <.> "hiedb" + let db = intercalate "-" [dirHash, takeBaseName dir, ghcVersionStr, hiedbDataVersion] <.> "hiedb" dirHash = B.unpack $ B16.encode $ H.hash $ B.pack dir cDir <- IO.getXdgDirectory IO.XdgCache cacheDir createDirectoryIfMissing True cDir @@ -295,7 +297,7 @@ -- We will modify the unitId and DynFlags used for -- compilation but these are the true source of -- information. - new_deps = RawComponentInfo (homeUnitId_ df) df targets cfp opts dep_info + new_deps = RawComponentInfo (thisInstalledUnitId 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 @@ -480,7 +482,7 @@ ncfp <- toNormalizedFilePath' <$> canonicalizePath file cachedHieYamlLocation <- HM.lookup ncfp <$> readVar filesMap hieYaml <- cradleLoc file - sessionOpts (join cachedHieYamlLocation <|> hieYaml, file) `Safe.catch` \e -> + sessionOpts (join cachedHieYamlLocation <|> hieYaml, file) `catch` \e -> return (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml) returnWithVersion $ \file -> do @@ -520,11 +522,11 @@ emptyHscEnv :: IORef NameCache -> FilePath -> IO HscEnv emptyHscEnv nc libDir = do env <- runGhc (Just libDir) getSession - when (Compat.ghcVersion < Compat.GHC90) $ + when (ghcVersion < 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 (hscSetFlags ((hsc_dflags env){useUnicode = True }) env) + pure $ setNameCache nc env{ hsc_dflags = (hsc_dflags env){useUnicode = True } } data TargetDetails = TargetDetails { @@ -569,13 +571,13 @@ -> Maybe FilePath -- Path to cradle -> NormalizedFilePath -- Path to file that caused the creation of this component -> HscEnv - -> [(UnitId, DynFlags)] + -> [(InstalledUnitId, DynFlags)] -> ComponentInfo -> IO ( [TargetDetails], (IdeResult HscEnvEq, DependencyInfo)) newComponentCache logger exts cradlePath cfp hsc_env uids ci = do let df = componentDynFlags ci - let hscEnv' = hscSetFlags df hsc_env - { hsc_IC = (hsc_IC hsc_env) { ic_dflags = df } } + let hscEnv' = hsc_env { hsc_dflags = df + , hsc_IC = (hsc_IC hsc_env) { ic_dflags = df } } let newFunc = maybe newHscEnvEqPreserveImportPaths newHscEnvEq cradlePath henv <- newFunc hscEnv' uids @@ -674,7 +676,7 @@ -- This is pristine information about a component data RawComponentInfo = RawComponentInfo - { rawComponentUnitId :: UnitId + { rawComponentUnitId :: InstalledUnitId -- | Unprocessed DynFlags. Contains inplace packages such as libraries. -- We do not want to use them unprocessed. , rawComponentDynFlags :: DynFlags @@ -691,14 +693,14 @@ -- This is processed information about the component, in particular the dynflags will be modified. data ComponentInfo = ComponentInfo - { componentUnitId :: UnitId + { componentUnitId :: InstalledUnitId -- | 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 :: [UnitId] + , _componentInternalUnits :: [InstalledUnitId] -- | All targets of this components. , componentTargets :: [GHC.Target] -- | Filepath which caused the creation of this component @@ -731,7 +733,7 @@ where tryIO :: IO a -> IO (Either IOException a) - tryIO = Safe.try + tryIO = try do_one :: FilePath -> IO (FilePath, Maybe UTCTime) do_one fp = (fp,) . eitherToMaybe <$> tryIO (getModificationTime fp) @@ -745,14 +747,18 @@ -- 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 - :: UnitId -- ^ fake uid to use for our internal component - -> [UnitId] + :: InstalledUnitId -- ^ fake uid to use for our internal component + -> [InstalledUnitId] -> DynFlags - -> (DynFlags, [UnitId]) -removeInplacePackages fake_uid us df = (setHomeUnitId_ fake_uid $ + -> (DynFlags, [InstalledUnitId]) +removeInplacePackages fake_uid us df = (setThisInstalledUnitId fake_uid $ df { packageFlags = ps }, uids) where - (uids, ps) = Compat.filterInplaceUnits us (packageFlags df) + (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 -- | Memoize an IO function, with the characteristics: -- @@ -784,16 +790,25 @@ -- also, it can confuse the interface stale check dontWriteHieFiles $ setIgnoreInterfacePragmas $ - setBytecodeLinkerOptions $ + setLinkerOptions $ disableOptimisation $ - Compat.setUpTypedHoles $ + 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. - env <- hscSetFlags dflags'' <$> getSession - final_env' <- liftIO $ wrapPackageSetupException $ Compat.initUnits env - return (hsc_dflags final_env', targets) + 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 + } 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,12 +23,17 @@ import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service import Development.IDE.Core.Shake -import Development.IDE.GHC.Compat hiding (writeHieFile) +import Development.IDE.GHC.Compat hiding (TargetFile, + TargetModule, + parseModule, + typecheckModule, + 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 (..)) @@ -39,7 +44,7 @@ :: HieDbWriter -- ^ access the database -> FilePath -- ^ The `.hie` file we got from the database -> ModuleName - -> Unit + -> UnitId -> Bool -- ^ Is this file a boot file? -> MaybeT IdeAction Uri lookupMod _dbchan _hie_f _mod _uid _boot = MaybeT $ pure Nothing @@ -59,11 +64,11 @@ opts <- liftIO $ getIdeOptionsIO ide (hf, mapping) <- useE GetHieAst file - env <- hscEnv . fst <$> useE GhcSession file + df <- hsc_dflags . 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 env pos' + MaybeT $ pure $ first (toCurrentRange mapping =<<) <$> AtPoint.atPoint opts hf dkMap df 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,18 +43,19 @@ import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import Development.IDE.Types.Options - -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 Outputable hiding ((<>)) 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 @@ -62,13 +63,35 @@ 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) @@ -85,13 +108,13 @@ 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) - --- GHC API imports -import GHC (GetDocsFailure (..), - parsedSource) +import TcEnv (tcLookup) import Control.Concurrent.Extra import Control.Concurrent.STM hiding (orElse) @@ -101,7 +124,8 @@ import Data.Functor import qualified Data.HashMap.Strict as HashMap import Data.Tuple.Extra (dupe) -import Data.Unique as Unique +import Data.Unique +import GHC.Fingerprint import qualified Language.LSP.Server as LSP import qualified Language.LSP.Types as LSP @@ -122,10 +146,11 @@ -- | Given a package identifier, what packages does it depend on computePackageDeps :: HscEnv - -> Unit - -> IO (Either [FileDiagnostic] [UnitId]) + -> InstalledUnitId + -> IO (Either [FileDiagnostic] [InstalledUnitId]) computePackageDeps env pkg = do - case lookupUnit env pkg of + let dflags = hsc_dflags env + case oldLookupInstalledPackage dflags pkg of Nothing -> return $ Left [ideErrorText (toNormalizedFilePath' noFilePath) $ T.pack $ "unknown package: " ++ show pkg] Just pkgInfo -> return $ Right $ unitDepends pkgInfo @@ -144,12 +169,7 @@ modSummary' <- initPlugins hsc modSummary (warnings, tcm) <- withWarnings "typecheck" $ \tweak -> - 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''} + tcRnModule hsc keep_lbls $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'} let errorPipeline = unDefer . hideDiag dflags . tagDiag diags = map errorPipeline warnings deferedError = any fst diags @@ -160,10 +180,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 :: HscEnv -> (HscEnv -> IO a) -> IO (a, Splices) -captureSplices env k = do +captureSplices :: DynFlags -> (DynFlags -> IO a) -> IO (a, Splices) +captureSplices dflags k = do splice_ref <- newIORef mempty - res <- k (hscSetHooks (addSpliceHook splice_ref (hsc_hooks env)) env) + res <- k (dflags { hooks = addSpliceHook splice_ref (hooks dflags)}) splices <- readIORef splice_ref return (res, splices) where @@ -197,13 +217,14 @@ tcRnModule :: HscEnv -> [Linkable] -> ParsedModule -> IO TcModuleResult tcRnModule hsc_env keep_lbls pmod = do let ms = pm_mod_summary pmod - hsc_env_tmp = hscSetFlags (ms_hspp_opts ms) hsc_env + hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } unload hsc_env_tmp keep_lbls ((tc_gbl_env, mrn_info), splices) - <- liftIO $ captureSplices (hscSetFlags (ms_hspp_opts ms) hsc_env) $ \hsc_env_tmp -> - do hscTypecheckRename hsc_env_tmp ms $ + <- liftIO $ captureSplices (ms_hspp_opts ms) $ \dflags -> + do let hsc_env_tmp = hsc_env { hsc_dflags = dflags } + hscTypecheckRename hsc_env_tmp ms $ HsParsedModule { hpm_module = parsedSource pmod, hpm_src_files = pm_extra_src_files pmod, hpm_annotations = pm_annotations pmod } @@ -214,7 +235,7 @@ mkHiFileResultNoCompile :: HscEnv -> TcModuleResult -> IO HiFileResult mkHiFileResultNoCompile session tcm = do - let hsc_env_tmp = hscSetFlags (ms_hspp_opts ms) session + let hsc_env_tmp = session { hsc_dflags = ms_hspp_opts ms } ms = pm_mod_summary $ tmrParsed tcm tcGblEnv = tmrTypechecked tcm details <- makeSimpleDetails hsc_env_tmp tcGblEnv @@ -234,7 +255,7 @@ -> LinkableType -- ^ use object code or byte code? -> IO (IdeResult HiFileResult) mkHiFileResultCompile session' tcm simplified_guts ltype = catchErrs $ do - let session = hscSetFlags (ms_hspp_opts ms) session' + let session = session' { hsc_dflags = ms_hspp_opts ms } ms = pm_mod_summary $ tmrParsed tcm tcGblEnv = tmrTypechecked tcm @@ -276,8 +297,8 @@ initPlugins :: HscEnv -> ModSummary -> IO ModSummary initPlugins session modSummary = do - session1 <- liftIO $ initializePlugins (hscSetFlags (ms_hspp_opts modSummary) session) - return modSummary{ms_hspp_opts = hsc_dflags session1} + dflags <- liftIO $ initializePlugins session $ ms_hspp_opts modSummary + return modSummary{ms_hspp_opts = dflags} -- | Whether we should run the -O0 simplifier when generating core. -- @@ -297,9 +318,9 @@ fmap (either (, Nothing) (second Just)) $ catchSrcErrors (hsc_dflags session) "compile" $ do (warnings,desugared_guts) <- withWarnings "compile" $ \tweak -> do - 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 + let ms' = tweak ms + session' = session{ hsc_dflags = ms_hspp_opts ms'} + desugar <- hscDesugar session' ms' tcg if simplify then do plugins <- readIORef (tcg_th_coreplugins tcg) @@ -316,20 +337,23 @@ fp = replaceExtension dot_o "s" createDirectoryIfMissing True (takeDirectory fp) (warnings, dot_o_fp) <- - 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 + 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}} #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)) @@ -346,9 +370,8 @@ catchSrcErrors (hsc_dflags hscEnv) "bytecode" $ do (warnings, (_, bytecode, sptEntries)) <- withWarnings "bytecode" $ \_tweak -> do - 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 } + let summary' = _tweak summary + session = hscEnv { hsc_dflags = ms_hspp_opts summary' } hscInteractive session guts #if MIN_VERSION_ghc(8,10,0) (ms_location summary') @@ -452,16 +475,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 = Util.listToBag (map (mkVarBind unitDataConId) (spliceExpresions $ tmrTopLevelSplices tcm)) + let fake_splice_binds = 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 :: Util.Bag EvBind + top_ev_binds = tcg_ev_binds ts :: Bag EvBind insts = tcg_insts ts :: [ClsInst] tcs = tcg_tcs ts :: [TyCon] - Just <$> GHC.enrichHie (fake_splice_binds `Util.unionBags` real_binds) (tmrRenamed tcm) top_ev_binds insts tcs + Just <$> GHC.enrichHie (fake_splice_binds `unionBags` real_binds) (tmrRenamed tcm) top_ev_binds insts tcs #else - Just <$> GHC.enrichHie (fake_splice_binds `Util.unionBags` real_binds) (tmrRenamed tcm) + Just <$> GHC.enrichHie (fake_splice_binds `unionBags` real_binds) (tmrRenamed tcm) #endif where dflags = hsc_dflags hscEnv @@ -504,7 +527,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 -> Util.Fingerprint -> Compat.HieFile -> IO () +indexHieFile :: ShakeExtras -> ModSummary -> NormalizedFilePath -> Fingerprint -> Compat.HieFile -> IO () indexHieFile se mod_summary srcPath !hash hf = do IdeOptions{optProgressStyle} <- getIdeOptionsIO se atomically $ do @@ -542,7 +565,7 @@ case lspEnv se of Nothing -> pure Nothing Just env -> LSP.runLspT env $ do - u <- LSP.ProgressTextToken . T.pack . show . hashUnique <$> liftIO Unique.newUnique + u <- LSP.ProgressTextToken . T.pack . show . hashUnique <$> liftIO 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 $ @@ -611,7 +634,7 @@ hf <- runHsc hscEnv $ GHC.mkHieFile' mod_summary exports ast source atomicFileWrite targetPath $ flip GHC.writeHieFile hf - hash <- Util.getFileHash targetPath + hash <- getFileHash targetPath indexHieFile se mod_summary srcPath hash hf where dflags = hsc_dflags hscEnv @@ -622,7 +645,7 @@ writeHiFile hscEnv tc = handleGenerationErrors dflags "interface write" $ do atomicFileWrite targetPath $ \fp -> - writeIfaceFile hscEnv fp modIface + writeIfaceFile dflags fp modIface where modIface = hm_iface $ hirHomeMod tc targetPath = ml_hi_file $ ms_location $ hirModSummary tc @@ -651,7 +674,7 @@ -- Make modules available for others that import them, -- by putting them in the finder cache. - let ims = map (installedModule (homeUnitId_ $ hsc_dflags session) . moduleName . ms_mod) mss + let ims = map (installedModule (thisInstalledUnitId $ 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 @@ -695,7 +718,7 @@ :: HscEnv -> FilePath -> UTCTime - -> Maybe Util.StringBuffer + -> Maybe SB.StringBuffer -> ExceptT [FileDiagnostic] IO ModSummaryResult getModSummaryFromImports env fp modTime contents = do (contents, opts, dflags) <- preprocessor env fp contents @@ -707,7 +730,7 @@ let mb_mod = hsmodName hsmod imps = hsmodImports hsmod - mod = fmap unLoc mb_mod `Util.orElse` mAIN_NAME + mod = fmap unLoc mb_mod `orElse` mAIN_NAME (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource.unLoc) imps @@ -733,7 +756,7 @@ modLoc <- liftIO $ mkHomeModLocation dflags mod fp - let modl = mkHomeModule (hscHomeUnit (hscSetFlags dflags env)) mod + let modl = mkModule (thisPackage dflags) mod sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile msrModSummary = ModSummary @@ -762,14 +785,14 @@ -- eliding the timestamps, the preprocessed source and other non relevant fields computeFingerprint opts ModSummary{..} = do fingerPrintImports <- fingerprintFromPut $ do - put $ Util.uniq $ moduleNameFS $ moduleName ms_mod + put $ uniq $ moduleNameFS $ moduleName ms_mod forM_ (ms_srcimps ++ ms_textual_imps) $ \(mb_p, m) -> do - put $ Util.uniq $ moduleNameFS $ unLoc m - whenJust mb_p $ put . Util.uniq - return $! Util.fingerprintFingerprints $ - [ Util.fingerprintString fp + put $ uniq $ moduleNameFS $ unLoc m + whenJust mb_p $ put . uniq + return $! fingerprintFingerprints $ + [ fingerprintString fp , fingerPrintImports - ] ++ map Util.fingerprintString opts + ] ++ map fingerprintString opts -- | Parse only the module header @@ -777,15 +800,15 @@ :: Monad m => DynFlags -- ^ flags to use -> FilePath -- ^ the filename (for source locations) - -> Util.StringBuffer -- ^ Haskell module source text (full Unicode is supported) + -> SB.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 (Util.mkFastString filename) 1 1 - case unP Compat.parseHeader (initParserState (initParserOpts dflags) contents loc) of + let loc = mkRealSrcLoc (mkFastString filename) 1 1 + case unP Parser.parseHeader (mkPState dflags contents loc) of #if MIN_VERSION_ghc(8,10,0) PFailed pst -> throwE $ diagFromErrMsgs "parser" dflags $ getErrorMessages pst dflags @@ -805,9 +828,9 @@ -- errors are those from which a parse tree just can't -- be produced. unless (null errs) $ - throwE $ diagFromErrMsgs "parser" dflags (fmap pprError errs) + throwE $ diagFromErrMsgs "parser" dflags errs - let warnings = diagFromErrMsgs "parser" dflags (fmap pprWarning warns) + let warnings = diagFromErrMsgs "parser" dflags warns return (warnings, rdr_module) -- | Given a buffer, flags, and file path, produce a @@ -820,10 +843,10 @@ -> ModSummary -> ExceptT [FileDiagnostic] IO ([FileDiagnostic], ParsedModule) parseFileContents env customPreprocessor filename ms = do - let loc = mkRealSrcLoc (Util.mkFastString filename) 1 1 + let loc = mkRealSrcLoc (mkFastString filename) 1 1 dflags = ms_hspp_opts ms contents = fromJust $ ms_hspp_buf ms - case unP Compat.parseModule (initParserState (initParserOpts dflags) contents loc) of + case unP Parser.parseModule (mkPState dflags contents loc) of #if MIN_VERSION_ghc(8,10,0) PFailed pst -> throwE $ diagFromErrMsgs "parser" dflags $ getErrorMessages pst dflags #else @@ -831,8 +854,21 @@ throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr #endif POk pst rdr_module -> - let - hpm_annotations = mkApiAnns pst + 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 (warns, errs) = getMessages pst dflags in do @@ -872,7 +908,7 @@ $ filter (/= n_hspp) $ map normalise $ filter (not . isPrefixOf "<") - $ map Util.unpackFS + $ map unpackFS $ srcfiles pst srcs1 = case ml_hs_file (ms_location ms) of Just f -> filter (/= normalise f) srcs0 @@ -883,7 +919,13 @@ -- filter them out: srcs2 <- liftIO $ filterM doesFileExist srcs1 - let pm = mkParsedModule ms parsed' srcs2 hpm_annotations + let pm = + ParsedModule { + pm_mod_summary = ms + , pm_parsed_source = parsed' + , pm_extra_src_files = srcs2 + , pm_annotations = hpm_annotations + } warnings = diagFromErrMsgs "parser" dflags warns pure (warnings ++ preproc_warnings, pm) @@ -902,7 +944,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 = hscSetFlags (ms_hspp_opts ms) session + let sessionWithMsDynFlags = session{hsc_dflags = ms_hspp_opts ms} res <- liftIO $ checkOldIface sessionWithMsDynFlags ms sourceMod Nothing case res of (UpToDate, Just iface) @@ -977,7 +1019,7 @@ UnhelpfulLoc {} -> True fakeSpan :: RealSrcSpan -fakeSpan = realSrcLocSpan $ mkRealSrcLoc (Util.fsLit "") 1 1 +fakeSpan = realSrcLocSpan $ mkRealSrcLoc (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,52 +26,56 @@ 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 Util.StringBuffer -> ExceptT [FileDiagnostic] IO (Util.StringBuffer, [String], DynFlags) -preprocessor env0 filename mbContents = do +preprocessor :: HscEnv -> FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] IO (StringBuffer, [String], DynFlags) +preprocessor env filename mbContents = do -- Perform unlit (isOnDisk, contents) <- if isLiterate filename then do - newcontent <- liftIO $ runLhs env0 filename mbContents + let dflags = hsc_dflags env + newcontent <- liftIO $ runLhs dflags filename mbContents return (False, newcontent) else do - contents <- liftIO $ maybe (Util.hGetStringBuffer filename) return mbContents + contents <- liftIO $ maybe (hGetStringBuffer filename) return mbContents let isOnDisk = isNothing mbContents return (isOnDisk, contents) -- Perform cpp - (opts, dflags) <- ExceptT $ parsePragmasIntoDynFlags env0 filename contents - let env1 = hscSetFlags dflags env0 - let logger = hsc_logger env1 + (opts, dflags) <- ExceptT $ parsePragmasIntoDynFlags env filename contents (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 (putLogHook newLogger env1) filename + $ (Right <$> (runCpp dflags {log_action = logActionCompat $ logAction cppLogs} filename $ if isOnDisk then Nothing else Just contents)) `catch` - ( \(e :: Util.GhcException) -> do + ( \(e :: GhcException) -> do logs <- readIORef cppLogs case diagsFromCPPLogs filename (reverse logs) of [] -> throw e diags -> return $ Left diags ) - (opts, dflags) <- ExceptT $ parsePragmasIntoDynFlags env1 filename contents + (opts, dflags) <- ExceptT $ parsePragmasIntoDynFlags env 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 env1 filename $ if isOnDisk then Nothing else Just contents - (opts, dflags) <- ExceptT $ parsePragmasIntoDynFlags env1 filename contents + contents <- liftIO $ runPreprocessor dflags filename $ if isOnDisk then Nothing else Just contents + (opts, dflags) <- ExceptT $ parsePragmasIntoDynFlags env filename contents return (contents, opts, dflags) where logAction :: IORef [CPPLog] -> LogActionCompat @@ -103,7 +107,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 (RealSrcSpan span _) msg : logs) = + go acc (CPPLog sev (OldRealSrcSpan span) msg : logs) = let diag = CPPDiag (realSrcSpanToRange span) (toDSeverity sev) [msg] in go (diag : acc) logs go (diag : diags) (CPPLog _sev (UnhelpfulSpan _) msg : logs) = @@ -130,22 +134,22 @@ parsePragmasIntoDynFlags :: HscEnv -> FilePath - -> Util.StringBuffer + -> SB.StringBuffer -> IO (Either [FileDiagnostic] ([String], DynFlags)) parsePragmasIntoDynFlags env fp contents = catchSrcErrors dflags0 "pragmas" $ do - let opts = getOptions dflags0 contents fp + let opts = Hdr.getOptions dflags0 contents fp -- Force bits that might keep the dflags and stringBuffer alive unnecessarily evaluate $ rnf opts (dflags, _, _) <- parseDynamicFilePragma dflags0 opts - hsc_env' <- initializePlugins (hscSetFlags dflags env) - return (map unLoc opts, disableWarningsAsErrors (hsc_dflags hsc_env')) + dflags' <- initializePlugins env dflags + return (map unLoc opts, disableWarningsAsErrors dflags') where dflags0 = hsc_dflags env -- | Run (unlit) literate haskell preprocessor on a file, or buffer if set -runLhs :: HscEnv -> FilePath -> Maybe Util.StringBuffer -> IO Util.StringBuffer -runLhs env filename contents = withTempDir $ \dir -> do +runLhs :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer +runLhs dflags filename contents = withTempDir $ \dir -> do let fout = dir takeFileName filename <.> "unlit" filesrc <- case contents of Nothing -> return filename @@ -155,17 +159,14 @@ hPutStringBuffer h cnts return fsrc unlit filesrc fout - Util.hGetStringBuffer fout + SB.hGetStringBuffer fout where - logger = hsc_logger env - dflags = hsc_dflags env - - unlit filein fileout = runUnlit logger dflags (args filein fileout) + unlit filein fileout = SysTools.runUnlit dflags (args filein fileout) args filein fileout = [ - Option "-h" - , Option (escape filename) -- name this file - , FileOption "" filein -- input file - , FileOption "" fileout ] -- output file + SysTools.Option "-h" + , SysTools.Option (escape filename) -- name this file + , SysTools.FileOption "" filein -- input file + , SysTools.FileOption "" fileout ] -- output file -- taken from ghc's DriverPipeline.hs escape ('\\':cs) = '\\':'\\': escape cs escape ('\"':cs) = '\\':'\"': escape cs @@ -174,32 +175,31 @@ escape [] = [] -- | Run CPP on a file -runCpp :: HscEnv -> FilePath -> Maybe Util.StringBuffer -> IO Util.StringBuffer -runCpp env0 filename contents = withTempDir $ \dir -> do +runCpp :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer +runCpp dflags filename contents = withTempDir $ \dir -> do let out = dir takeFileName filename <.> "out" - let dflags1 = addOptP "-D__GHCIDE__" (hsc_dflags env0) - let env1 = hscSetFlags dflags1 env0 + dflags <- pure $ addOptP "-D__GHCIDE__" dflags 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 env1 True filename out - liftIO $ Util.hGetStringBuffer out + doCpp dflags True filename out + liftIO $ SB.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. - let dflags2 = addIncludePathsQuote (takeDirectory filename) dflags1 - let env2 = hscSetFlags dflags2 env0 + dflags <- return $ addIncludePathsQuote (takeDirectory filename) dflags + -- 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 env2 True inp out + doCpp dflags 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 - Util.stringToStringBuffer . unlines . map tweak . lines <$> readFileUTF8' out + stringToStringBuffer . unlines . map tweak . lines <$> readFileUTF8' out -- | Run a preprocessor on a file -runPreprocessor :: HscEnv -> FilePath -> Maybe Util.StringBuffer -> IO Util.StringBuffer -runPreprocessor env filename contents = withTempDir $ \dir -> do +runPreprocessor :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer +runPreprocessor dflags filename contents = withTempDir $ \dir -> do let out = dir takeFileName filename <.> "out" inp <- case contents of Nothing -> return filename @@ -225,8 +225,5 @@ withBinaryFile inp WriteMode $ \h -> hPutStringBuffer h contents return inp - runPp logger dflags [Option filename, Option inp, FileOption "" out] - Util.hGetStringBuffer out - where - logger = hsc_logger env - dflags = hsc_dflags env + runPp dflags [SysTools.Option filename, SysTools.Option inp, SysTools.FileOption "" out] + SB.hGetStringBuffer out 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,7 +25,6 @@ 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 @@ -33,6 +32,11 @@ 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 @@ -42,8 +46,10 @@ 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,9 +58,6 @@ 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 @@ -106,14 +103,12 @@ import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service import Development.IDE.Core.Shake -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.Compat hiding + (TargetFile, + TargetModule, + parseModule, + typecheckModule, + writeHieFile) import Development.IDE.GHC.Error import Development.IDE.GHC.ExactPrint import Development.IDE.GHC.Util hiding @@ -130,16 +125,23 @@ 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, @@ -341,7 +343,7 @@ | otherwise = return Nothing (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do - diagOrImp <- locateModule (hscSetFlags dflags env) import_dirs (optExtensions opt) getTargetFor modName mbPkgName isSource + diagOrImp <- locateModule dflags 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)) @@ -501,8 +503,8 @@ let allFiles = reachableModules depInfo _ <- uses_ ReportImportCycles allFiles opts <- getIdeOptions - let mbFingerprints = map (Util.fingerprintString . fromNormalizedFilePath) allFiles <$ optShakeFiles opts - return (fingerprintToBS . Util.fingerprintFingerprints <$> mbFingerprints, transitiveDeps depInfo file) + let mbFingerprints = map (fingerprintString . fromNormalizedFilePath) allFiles <$ optShakeFiles opts + return (fingerprintToBS . fingerprintFingerprints <$> mbFingerprints, transitiveDeps depInfo file) getHieAstsRule :: Rules () getHieAstsRule = @@ -521,9 +523,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 = 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) + 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) getHieAstRuleDefinition :: NormalizedFilePath -> HscEnv -> TcModuleResult -> Action (IdeResult HieAstResult) getHieAstRuleDefinition f hsc tmr = do @@ -544,8 +546,8 @@ liftIO $ writeAndIndexHieFile hsc se msum f exports asts source _ -> pure [] - let refmap = Compat.generateReferencesMap . Compat.getAsts <$> masts - typemap = AtPoint.computeTypeReferences . Compat.getAsts <$> masts + let refmap = generateReferencesMap . getAsts <$> masts + typemap = AtPoint.computeTypeReferences . getAsts <$> masts pure (diags <> diagsWrite, HAR (ms_mod $ tmrModSummary tmr) <$> masts <*> refmap <*> typemap <*> pure HieFresh) getImportMapRule :: Rules () @@ -582,7 +584,7 @@ persistentDocMapRule :: Rules () persistentDocMapRule = addPersistentRule GetDocMap $ \_ -> pure $ Just (DKMap mempty mempty, idDelta, Nothing) -readHieFileForSrcFromDisk :: NormalizedFilePath -> MaybeT IdeAction Compat.HieFile +readHieFileForSrcFromDisk :: NormalizedFilePath -> MaybeT IdeAction HieFile readHieFileForSrcFromDisk file = do db <- asks hiedb log <- asks $ L.logDebug . logger @@ -591,7 +593,7 @@ liftIO $ log $ "LOADING HIE FILE :" <> T.pack (show file) exceptToMaybeT $ readHieFileFromDisk hie_loc -readHieFileFromDisk :: FilePath -> ExceptT SomeException IdeAction Compat.HieFile +readHieFileFromDisk :: FilePath -> ExceptT SomeException IdeAction HieFile readHieFileFromDisk hie_loc = do nc <- asks ideNc log <- asks $ L.logDebug . logger @@ -752,8 +754,8 @@ -- GetModIfaceFromDisk should have written a `.hie` file, must check if it matches version in db let ms = hirModSummary x - hie_loc = Compat.ml_hie_file $ ms_location ms - hash <- liftIO $ Util.getFileHash hie_loc + hie_loc = ml_hie_file $ ms_location ms + hash <- liftIO $ getFileHash hie_loc mrow <- liftIO $ HieDb.lookupHieFileFromSource hiedb (fromNormalizedFilePath f) hie_loc' <- liftIO $ traverse (canonicalizePath . HieDb.hieModuleHieFile) mrow case mrow of @@ -783,7 +785,7 @@ isHiFileStableRule = defineEarlyCutoff $ RuleNoDiagnostics $ \IsHiFileStable f -> do ms <- msrModSummary <$> use_ GetModSummaryWithoutTimestamps f let hiFile = toNormalizedFilePath' - $ Compat.ml_hi_file $ ms_location ms + $ ml_hi_file $ ms_location ms mbHiVersion <- use GetModificationTime_{missingFileDiagnostics=False} hiFile modVersion <- use_ GetModificationTime f sourceModified <- case mbHiVersion of @@ -809,7 +811,7 @@ defineEarlyCutoff $ Rule $ \GetModSummary f -> do session' <- hscEnv <$> use_ GhcSession f modify_dflags <- getModifyDynFlags dynFlagsModifyGlobal - let session = hscSetFlags (modify_dflags $ hsc_dflags session') session' + let session = session' { hsc_dflags = modify_dflags $ hsc_dflags session' } (modTime, mFileContent) <- getFileContents f let fp = fromNormalizedFilePath f modS <- liftIO $ runExceptT $ @@ -818,7 +820,7 @@ Right res -> do bufFingerPrint <- liftIO $ fingerprintFromStringBuffer $ fromJust $ ms_hspp_buf $ msrModSummary res - let fingerPrint = Util.fingerprintFingerprints + let fingerPrint = fingerprintFingerprints [ msrFingerprint res, bufFingerPrint ] return ( Just (fingerprintToBS fingerPrint) , ([], Just res)) Left diags -> return (Nothing, (diags, Nothing)) @@ -1045,7 +1047,7 @@ writeHiFileAction :: HscEnv -> HiFileResult -> Action [FileDiagnostic] writeHiFileAction hsc hiFile = do extras <- getShakeExtras - let targetPath = Compat.ml_hi_file $ ms_location $ hirModSummary hiFile + let targetPath = 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,11 +109,7 @@ import Development.IDE.Core.ProgressReporting import Development.IDE.Core.RuleTypes import Development.IDE.Core.Tracing -import Development.IDE.GHC.Compat (NameCacheUpdater (..), - upNameCache, NameCache, - initNameCache, - mkSplitUniqSupply, - knownKeyNames) +import Development.IDE.GHC.Compat (NameCacheUpdater (..), upNameCache) import Development.IDE.GHC.Orphans () import Development.IDE.Graph hiding (ShakeValue) import qualified Development.IDE.Graph as Shake @@ -141,7 +137,10 @@ 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,9 +21,7 @@ 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,9 +29,6 @@ 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, @@ -39,6 +36,8 @@ realSrcSpanToRange) import qualified Development.IDE.Core.PositionMapping as P import qualified Development.IDE.Core.Shake as IDE +import qualified FastString as FS +import SrcLoc ------------------------------------------------------------------------------ @@ -114,7 +113,7 @@ instance MapAge RealSrcSpan where mapAgeFrom = - invMapAge (\fs -> rangeToRealSrcSpan (fromString $ unpackFS fs)) + invMapAge (\fs -> rangeToRealSrcSpan (fromString $ FS.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,8 +1,17 @@ -- 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 #-} ----------------------------------------------------------------------------- -- @@ -15,26 +24,149 @@ module Development.IDE.GHC.CPP(doCpp, addOptP) where -import GHC import Development.IDE.GHC.Compat as Compat -#if !MIN_VERSION_ghc(8,10,0) -import qualified Development.IDE.GHC.Compat.CPP as CPP -#else -import Development.IDE.GHC.Compat.Util +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 - -#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 qualified DriverPipeline as Pipeline +import Fingerprint 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 -import DynFlags + | 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 [] + addOptP :: String -> DynFlags -> DynFlags #if MIN_VERSION_ghc (8,10,0) addOptP f = alterToolSettings $ \s -> s @@ -51,13 +183,47 @@ onOptP f x = x{sOpt_P = f $ sOpt_P x} #endif -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 +-- --------------------------------------------------------------------------- +-- 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]) + + 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,144 +4,248 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS -Wno-incomplete-uni-patterns -Wno-dodgy-imports #-} +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS -Wno-dodgy-imports -Wno-incomplete-uni-patterns #-} +{-# OPTIONS -Wno-missing-signatures #-} -- TODO: Remove! -- | 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(9,0,1) +#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 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, - -- * 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, + ghcVersionStr ) where -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 +#if MIN_VERSION_ghc(8,10,0) +import LinkerTypes +#endif -#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 +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 #else -import GHC.Driver.Types +import Module (InstalledUnitId, + UnitId (DefiniteUnitId), + toInstalledUnitId) +import TcType (pprSigmaType) #endif -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 DynFlags hiding (ExposePackage) +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 hiding (writeIfaceFile) -import qualified Avail +import MkIface +import NameCache +import Packages +import TcRnTypes +#if MIN_VERSION_ghc(8,10,0) +import GHC.Hs.Extension +#else +import HsExtension +#endif + +import Avail +import GHC hiding (HasSrcSpan, ModLocation, getLoc, + lookupName) +import qualified GHC +import qualified TyCoRep #if MIN_VERSION_ghc(8,8,0) -import StringBuffer (hPutStringBuffer) +import Data.List (foldl') +#else +import Data.List (foldl', isSuffixOf) #endif -import qualified SysTools +import qualified Data.Map as M +import DynamicLoading +import Plugins (Plugin (parsedResultAction), + withPlugins) + #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) -upNameCache = updNameCache -#else +#if !MIN_VERSION_ghc(8,8,0) upNameCache ref upd_fn = atomicModifyIORef' ref upd_fn +#else +upNameCache = updNameCache #endif + #if !MIN_VERSION_ghc(9,0,1) -type RefMap a = Map.Map Identifier [(Span, IdentifierDetails a)] +type RefMap a = M.Map Identifier [(Span, IdentifierDetails a)] #endif mkHieFile' :: ModSummary - -> [Avail.AvailInfo] + -> [AvailInfo] -> HieASTs Type -> BS.ByteString -> Hsc HieFile @@ -162,6 +266,15 @@ 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) @@ -199,11 +312,46 @@ } -nameListFromAvails :: [Avail.AvailInfo] -> [(SrcSpan, Name)] +nameListFromAvails :: [AvailInfo] -> [(SrcSpan, Name)] nameListFromAvails as = - map (\n -> (nameSrcSpan n, n)) (concatMap Avail.availNames as) + map (\n -> (nameSrcSpan n, n)) (concatMap 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 @@ -211,7 +359,138 @@ 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 ..] @@ -220,8 +499,42 @@ 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 @@ -234,21 +547,19 @@ #if MIN_VERSION_ghc(9,0,0) -getNodeIds :: HieAST a -> Map.Map Identifier (IdentifierDetails a) -getNodeIds = Map.foldl' combineNodeIds Map.empty . getSourcedNodeInfo . sourcedNodeInfo +getNodeIds :: HieAST a -> M.Map Identifier (IdentifierDetails a) +getNodeIds = M.foldl' combineNodeIds M.empty . getSourcedNodeInfo . sourcedNodeInfo -combineNodeIds :: Map.Map Identifier (IdentifierDetails a) - -> NodeInfo a -> Map.Map Identifier (IdentifierDetails a) -ad `combineNodeIds` (NodeInfo _ _ bd) = Map.unionWith (<>) ad bd +ad `combineNodeIds` (NodeInfo _ _ bd) = M.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' = Map.foldl' combineNodeInfo' emptyNodeInfo . getSourcedNodeInfo . sourcedNodeInfo +nodeInfo' = M.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) (Map.unionWith (<>) ad bd) + NodeInfo (S.union as bs) (mergeSorted ai bi) (M.unionWith (<>) ad bd) where mergeSorted :: Ord a => [a] -> [a] -> [a] mergeSorted la@(a:as) lb@(b:bs) = case compare a b of @@ -258,9 +569,10 @@ 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 @@ -268,10 +580,15 @@ 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 @@ -279,16 +596,13 @@ | GHC88 | GHC810 | GHC90 - | GHC92 deriving (Eq, Ord, Show) ghcVersionStr :: String ghcVersionStr = VERSION_ghc ghcVersion :: GhcVersion -#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) -ghcVersion = GHC92 -#elif MIN_VERSION_GLASGOW_HASKELL(9,0,0,0) +#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0) ghcVersion = GHC90 #elif MIN_VERSION_GLASGOW_HASKELL(8,10,0,0) ghcVersion = GHC810 @@ -296,20 +610,4 @@ 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 deleted file mode 100644 --- a/src/Development/IDE/GHC/Compat/CPP.hs +++ /dev/null @@ -1,204 +0,0 @@ --- 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 deleted file mode 100644 --- a/src/Development/IDE/GHC/Compat/Core.hs +++ /dev/null @@ -1,848 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Development/IDE/GHC/Compat/Env.hs +++ /dev/null @@ -1,284 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Development/IDE/GHC/Compat/Iface.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Development/IDE/GHC/Compat/Logger.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Development/IDE/GHC/Compat/Outputable.hs +++ /dev/null @@ -1,165 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Development/IDE/GHC/Compat/Parser.hs +++ /dev/null @@ -1,117 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Development/IDE/GHC/Compat/Plugins.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Development/IDE/GHC/Compat/Units.hs +++ /dev/null @@ -1,345 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Development/IDE/GHC/Compat/Util.hs +++ /dev/null @@ -1,110 +0,0 @@ -{-# 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,21 +29,24 @@ , toDSeverity ) where +import Bag import Data.Maybe import Data.String (fromString) import qualified Data.Text as T -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 qualified Development.IDE.GHC.Compat as GHC 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 @@ -57,25 +60,32 @@ } -- | Produce a GHC-style error from a source span and a message. -diagFromErrMsg :: T.Text -> DynFlags -> MsgEnvelope DecoratedSDoc -> [FileDiagnostic] +diagFromErrMsg :: T.Text -> DynFlags -> ErrMsg -> [FileDiagnostic] diagFromErrMsg diagSource dflags e = [ diagFromText diagSource sev (errMsgSpan e) $ T.pack $ formatErrorWithQual dflags e | Just sev <- [toDSeverity $ errMsgSeverity e]] -diagFromErrMsgs :: T.Text -> DynFlags -> Compat.Bag (MsgEnvelope DecoratedSDoc) -> [FileDiagnostic] -diagFromErrMsgs diagSource dflags = concatMap (diagFromErrMsg diagSource dflags) . Compat.bagToList +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 + -- | Convert a GHC SrcSpan to a DAML compiler Range srcSpanToRange :: SrcSpan -> Maybe Range -srcSpanToRange (UnhelpfulSpan _) = Nothing -srcSpanToRange (Compat.RealSrcSpan real _) = Just $ realSrcSpanToRange real +srcSpanToRange (UnhelpfulSpan _) = Nothing +srcSpanToRange (GHC.OldRealSrcSpan real) = Just $ realSrcSpanToRange real -- srcSpanToRange = fmap realSrcSpanToRange . realSpan realSrcSpanToRange :: RealSrcSpan -> Range realSrcSpanToRange real = - Range (realSrcLocToPosition $ Compat.realSrcSpanStart real) - (realSrcLocToPosition $ Compat.realSrcSpanEnd real) + Range (realSrcLocToPosition $ realSrcSpanStart real) + (realSrcLocToPosition $ realSrcSpanEnd real) realSrcLocToPosition :: RealSrcLoc -> Position realSrcLocToPosition real = @@ -85,12 +95,12 @@ -- FIXME This may not be an _absolute_ file name, needs fixing. srcSpanToFilename :: SrcSpan -> Maybe FilePath srcSpanToFilename (UnhelpfulSpan _) = Nothing -srcSpanToFilename (Compat.RealSrcSpan real _) = Just $ Compat.unpackFS $ srcSpanFile real +srcSpanToFilename (GHC.OldRealSrcSpan real) = Just $ FS.unpackFS $ srcSpanFile real -- srcSpanToFilename = fmap (FS.unpackFS . srcSpanFile) . realSpan realSrcSpanToLocation :: RealSrcSpan -> Location realSrcSpanToLocation real = Location file (realSrcSpanToRange real) - where file = fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath' $ Compat.unpackFS $ srcSpanFile real + where file = fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath' $ FS.unpackFS $ srcSpanFile real srcSpanToLocation :: SrcSpan -> Maybe Location srcSpanToLocation src = do @@ -100,18 +110,18 @@ pure $ Location (fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath' fs) rng rangeToSrcSpan :: NormalizedFilePath -> Range -> SrcSpan -rangeToSrcSpan = fmap (\x -> Compat.RealSrcSpan x Nothing) . rangeToRealSrcSpan +rangeToSrcSpan = fmap GHC.OldRealSrcSpan . rangeToRealSrcSpan rangeToRealSrcSpan :: NormalizedFilePath -> Range -> RealSrcSpan rangeToRealSrcSpan nfp = - Compat.mkRealSrcSpan + mkRealSrcSpan <$> positionToRealSrcLoc nfp . _start <*> positionToRealSrcLoc nfp . _end positionToRealSrcLoc :: NormalizedFilePath -> Position -> RealSrcLoc positionToRealSrcLoc nfp (Position l c)= - Compat.mkRealSrcLoc (fromString $ fromNormalizedFilePath nfp) (l + 1) (c + 1) + mkRealSrcLoc (fromString $ fromNormalizedFilePath nfp) (l + 1) (c + 1) isInsideSrcSpan :: Position -> SrcSpan -> Bool p `isInsideSrcSpan` r = case srcSpanToRange r of @@ -142,19 +152,19 @@ -- | Produces an "unhelpful" source span with the given string. noSpan :: String -> SrcSpan -noSpan = Compat.mkGeneralSrcSpan . Compat.fsLit +noSpan = GHC.oldUnhelpfulSpan . FS.fsLit -- | creates a span with zero length in the filename of the argument passed -zeroSpan :: Compat.FastString -- ^ file path of span +zeroSpan :: FS.FastString -- ^ file path of span -> RealSrcSpan -zeroSpan file = Compat.realSrcLocSpan (Compat.mkRealSrcLoc file 1 1) +zeroSpan file = realSrcLocSpan (mkRealSrcLoc file 1 1) realSpan :: SrcSpan -> Maybe RealSrcSpan realSpan = \case - Compat.RealSrcSpan r _ -> Just r - UnhelpfulSpan _ -> Nothing + GHC.OldRealSrcSpan r -> Just r + UnhelpfulSpan _ -> Nothing -- | Catch the errors thrown by GHC (SourceErrors and @@ -162,7 +172,7 @@ -- diagnostics catchSrcErrors :: DynFlags -> T.Text -> IO a -> IO (Either [FileDiagnostic] a) catchSrcErrors dflags fromWhere ghcM = do - Compat.handleGhcException (ghcExceptionToDiagnostics dflags) $ + handleGhcException (ghcExceptionToDiagnostics dflags) $ handleSourceError (sourceErrorToDiagnostics dflags) $ Right <$> ghcM where @@ -182,14 +192,14 @@ -> unwords ["Compilation Issue:", s, "\n", requestReport] PprPanic s sdoc -> unlines ["Compilation Issue", s,"" - , Compat.showSDoc dflags sdoc + , Out.showSDoc dflags sdoc , requestReport ] Sorry s -> "Unsupported feature: " <> s PprSorry s sdoc -> unlines ["Unsupported feature: ", s,"" - , Compat.showSDoc dflags sdoc] + , Out.showSDoc dflags sdoc] ---------- errors below should not happen at all -------- @@ -206,6 +216,6 @@ -> "Program error: " <> str PprProgramError str sdoc -> unlines ["Program error:", str,"" - , Compat.showSDoc dflags sdoc] + , Out.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,11 +29,10 @@ Anns, Annotate, setPrecedingLinesT, - -- * Helper function - eqSrcSpan, ) where +import BasicTypes (appPrec) import Control.Applicative (Alternative) import Control.Arrow import Control.Monad @@ -54,9 +53,7 @@ import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service (runAction) import Development.IDE.Core.Shake -import Development.IDE.GHC.Compat hiding (parseImport, - parsePattern, - parseType) +import Development.IDE.GHC.Compat hiding (parseExpr) import Development.IDE.Graph (RuleResult, Rules) import Development.IDE.Graph.Classes import Development.IDE.Types.Location @@ -68,6 +65,9 @@ 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,9 +233,8 @@ everywhere' ( mkT $ \case - (L src _ :: Located ast) - | src `eqSrcSpan` dst -> val' - l -> l + (L src _ :: Located ast) | src == dst -> val' + l -> l ) a @@ -268,7 +267,7 @@ let (needs_parens, needs_space) = everythingWithContext (Nothing, Nothing) (<>) ( mkQ (mempty, ) $ \x s -> case x of - (L src _ :: LHsExpr GhcPs) | src `eqSrcSpan` dst -> + (L src _ :: LHsExpr GhcPs) | src == dst -> (s, s) L _ x' -> (mempty, Just *** Just $ needsParensSpace x') ) a @@ -292,7 +291,7 @@ ( mkM $ \case val@(L src _ :: LHsExpr GhcPs) - | src `eqSrcSpan` dst -> do + | src == dst -> do mval <- trans val case mval of Just val' -> do @@ -317,7 +316,7 @@ ( mkM $ \case val@(L src _ :: Located ast) - | src `eqSrcSpan` dst -> do + | src == dst -> do mval <- trans val case mval of Just val' -> do @@ -369,7 +368,7 @@ annotateDecl dflags decl let go [] = DL.empty go (L src e : rest) - | src `eqSrcSpan` dst = DL.fromList decs <> DL.fromList rest + | src == dst = DL.fromList decs <> DL.fromList rest | otherwise = DL.singleton (L src e) <> go rest modifyDeclsT (pure . DL.toList . go) a @@ -400,7 +399,7 @@ graftDeclsWithM dst toDecls = Graft $ \dflags a -> do let go [] = pure DL.empty go (e@(L src _) : rest) - | src `eqSrcSpan` dst = toDecls e >>= \case + | src == dst = toDecls e >>= \case Just decs0 -> do decs <- forM decs0 $ \decl -> hoistTransform (either Fail.fail pure) $ @@ -520,9 +519,3 @@ 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,35 +9,21 @@ -- 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 @@ -64,7 +50,7 @@ instance Hashable GhcPlugins.InstalledUnitId where hashWithSalt salt = hashWithSalt salt . installedUnitIdString #else -instance Show UnitId where show = prettyPrint +instance Show InstalledUnitId where show = prettyPrint deriving instance Ord SrcSpan deriving instance Ord UnhelpfulSpanReason #endif @@ -107,10 +93,8 @@ 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, - Development.IDE.GHC.Util.printName, + printName, ParseResult(..), runParser, lookupPackageConfig, textToStringBuffer, @@ -30,78 +30,48 @@ 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 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 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 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 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.GHC.Compat as GHC import Development.IDE.Types.Location +import FastString (mkFastString) +import FileCleanup +import Fingerprint import Foreign.ForeignPtr import Foreign.Ptr import Foreign.Storable -import GHC -import GHC.IO.BufferedIO (BufferedIO) -import GHC.IO.Device as IODevice +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 @@ -116,15 +86,19 @@ -- We do not use setSessionDynFlags here since we handle package -- initialization separately. modifySession $ \h -> - hscSetFlags newFlags h { hsc_IC = (hsc_IC h) {ic_dflags = newFlags} } + h { hsc_dflags = newFlags, 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.UnitInfo +lookupPackageConfig :: Unit -> HscEnv -> Maybe GHC.PackageConfig lookupPackageConfig unit env = - Compat.lookupUnit' False unitState prClsre unit + -- GHC.lookupPackage' False pkgConfigMap unit + GHC.lookupUnit' False pkgConfigMap prClsre unit where - unitState = Compat.getUnitInfoMap env - prClsre = preloadClosureUs env + 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 -- | Convert from the @text@ package to the @GHC@ 'StringBuffer'. @@ -138,7 +112,7 @@ filename = "" location = mkRealSrcLoc (mkFastString filename) 1 1 buffer = stringToStringBuffer str - parseState = Compat.initParserState (Compat.initParserOpts flags) buffer location + parseState = mkPState flags buffer location stringBufferToByteString :: StringBuffer -> ByteString stringBufferToByteString StringBuffer{..} = PS buf cur len @@ -151,7 +125,9 @@ prettyPrint = unsafePrintSDoc . ppr unsafePrintSDoc :: SDoc -> String -unsafePrintSDoc sdoc = showSDocUnsafe sdoc +unsafePrintSDoc sdoc = oldRenderWithStyle dflags sdoc (oldMkUserStyle dflags neverQualify AllTheWay) + where + dflags = unsafeGlobalDynFlags -- | Pretty print a 'RdrName' wrapping operators in parens printRdrName :: RdrName -> String @@ -172,9 +148,13 @@ -- pieces, but designed to be more efficient than a standard 'runGhc'. runGhcEnv :: HscEnv -> Ghc a -> IO (HscEnv, a) runGhcEnv env act = do - hsc_env <- initTempFs env - ref <- newIORef hsc_env - res <- unGhc (withCleanupSession act) (Session ref) + 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 (,res) <$> readIORef ref -- | Given a module location, and its parse tree, figure out what is the include directory implied by it. @@ -238,7 +218,7 @@ -- _ <- hClose_help h2_ -- hClose_help does two things: -- 1. It flushes the buffer, we replicate this here - _ <- flushWriteBuffer h2_ `E.catch` \(_ :: IOException) -> pure () + _ <- flushWriteBuffer h2_ `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,11 +4,15 @@ module Development.IDE.GHC.Warnings(withWarnings) where -import Control.Concurrent.Strict import Data.List +import ErrUtils +import GhcPlugins as GHC hiding (Var, (<>)) + +import Control.Concurrent.Strict import qualified Data.Text as T -import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat (LogActionCompat, + logActionCompat) import Development.IDE.GHC.Error import Development.IDE.Types.Diagnostics import Language.LSP.Types (type (|?) (..)) @@ -23,20 +27,16 @@ -- 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 -> ((HscEnv -> HscEnv) -> IO a) -> IO ([(WarnReason, FileDiagnostic)], a) +withWarnings :: T.Text -> ((ModSummary -> ModSummary) -> 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:) - newLogger env = pushLogHook (const (logActionCompat newAction)) (hsc_logger env) - res <- action $ \env -> putLogHook (newLogger env) env + res <- action $ \x -> x{ms_hspp_opts = (ms_hspp_opts x){log_action = logActionCompat newAction}} 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,19 +13,25 @@ , 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 @@ -69,7 +75,7 @@ -> m (Maybe NormalizedFilePath) locateModuleFile import_dirss exts targetFor isSource modName = do let candidates import_dirs = - [ toNormalizedFilePath' (prefix moduleNameSlashes modName <.> maybeBoot ext) + [ toNormalizedFilePath' (prefix M.moduleNameSlashes modName <.> maybeBoot ext) | prefix <- import_dirs , ext <- exts] firstJustM (targetFor modName) (concatMap candidates import_dirss) where @@ -81,22 +87,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 :: HscEnv -> (UnitId, DynFlags) -> Maybe (PackageName, [FilePath]) -mkImportDirs env (i, flags) = (, importPaths flags) <$> getUnitName env i +mkImportDirs :: DynFlags -> (Compat.InstalledUnitId, DynFlags) -> Maybe (PackageName, [FilePath]) +mkImportDirs df (i, DynFlags{importPaths}) = (, importPaths) <$> getPackageName df i -- | locate a module in either the file system or the package database. Where we go from *daml to -- Haskell locateModule :: MonadIO m - => HscEnv - -> [(UnitId, DynFlags)] -- ^ Import directories + => DynFlags + -> [(Compat.InstalledUnitId, 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 env comp_info exts targetFor modName mbPkgName isSource = do +locateModule dflags 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 @@ -105,7 +111,7 @@ Just pkgName | Just dirs <- lookup (PackageName pkgName) import_paths -> lookupLocal [dirs] - | otherwise -> lookupInPackageDB env + | otherwise -> lookupInPackageDB dflags 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. @@ -114,11 +120,10 @@ -- 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 env + Nothing -> lookupInPackageDB dflags Just file -> toModLocation file where - dflags = hsc_dflags env - import_paths = mapMaybe (mkImportDirs env) comp_info + import_paths = mapMaybe (mkImportDirs dflags) comp_info toModLocation file = liftIO $ do loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file) return $ Right $ FileImport $ ArtifactsLocation file (Just loc) (not isSource) @@ -126,21 +131,20 @@ lookupLocal dirs = do mbFile <- locateModuleFile dirs exts targetFor isSource $ unLoc modName case mbFile of - Nothing -> return $ Left $ notFoundErr env modName $ LookupNotFound [] + Nothing -> return $ Left $ notFoundErr dflags modName $ LookupNotFound [] Just file -> toModLocation file - lookupInPackageDB env = - case Compat.lookupModuleWithSuggestions env (unLoc modName) mbPkgName of + lookupInPackageDB dfs = + case oldLookupModuleWithSuggestions dfs (unLoc modName) mbPkgName of LookupFound _m _pkgConfig -> return $ Right PackageImport - reason -> return $ Left $ notFoundErr env modName reason + reason -> return $ Left $ notFoundErr dfs modName reason -- | Don't call this on a found module. -notFoundErr :: HscEnv -> Located ModuleName -> LookupResult -> [FileDiagnostic] -notFoundErr env modName reason = - mkError' $ ppr' $ cannotFindModule env modName0 $ lookupToFindResult reason +notFoundErr :: DynFlags -> Located M.ModuleName -> LookupResult -> [FileDiagnostic] +notFoundErr dfs modName reason = + mkError' $ ppr' $ cannotFindModule dfs modName0 $ lookupToFindResult reason where - dfs = hsc_dflags env - mkError' = diagFromString "not found" DsError (Compat.getLoc modName) + mkError' = diagFromString "not found" DsError (getLoc modName) modName0 = unLoc modName ppr' = showSDoc dfs -- We convert the lookup result to a find result to reuse GHC's cannotFindMoudle pretty printer. @@ -151,12 +155,12 @@ LookupMultiple rs -> FoundMultiple rs LookupHidden pkg_hiddens mod_hiddens -> notFound - { fr_pkgs_hidden = map (moduleUnit . fst) pkg_hiddens - , fr_mods_hidden = map (moduleUnit . fst) mod_hiddens + { fr_pkgs_hidden = map (moduleUnitId . fst) pkg_hiddens + , fr_mods_hidden = map (moduleUnitId . fst) mod_hiddens } LookupUnusable unusable -> let unusables' = map get_unusable unusable - get_unusable (m, ModUnusable r) = (moduleUnit m, r) + get_unusable (m, ModUnusable r) = (moduleUnitId 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,6 +29,8 @@ 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)) @@ -42,7 +44,7 @@ -> let declSymbols = mapMaybe documentSymbolForDecl hsmodDecls moduleSymbol = hsmodName >>= \case - (L (RealSrcSpan l _) m) -> Just $ + (L (OldRealSrcSpan l) m) -> Just $ (defDocumentSymbol l :: DocumentSymbol) { _name = pprText m , _kind = SkFile @@ -71,7 +73,7 @@ Nothing -> pure $ Right $ InL (List []) documentSymbolForDecl :: Located (HsDecl GhcPs) -> Maybe DocumentSymbol -documentSymbolForDecl (L (RealSrcSpan l _) (TyClD _ FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } })) +documentSymbolForDecl (L (OldRealSrcSpan l) (TyClD _ FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName n <> (case pprText fdTyVars of @@ -81,7 +83,7 @@ , _detail = Just $ pprText fdInfo , _kind = SkFunction } -documentSymbolForDecl (L (RealSrcSpan l _) (TyClD _ ClassDecl { tcdLName = L _ name, tcdSigs, tcdTyVars })) +documentSymbolForDecl (L (OldRealSrcSpan l) (TyClD _ ClassDecl { tcdLName = L _ name, tcdSigs, tcdTyVars })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName name <> (case pprText tcdTyVars of @@ -97,11 +99,11 @@ , _kind = SkMethod , _selectionRange = realSrcSpanToRange l' } - | L (RealSrcSpan l _) (ClassOpSig _ False names _) <- tcdSigs - , L (RealSrcSpan l' _) n <- names + | L (OldRealSrcSpan l) (ClassOpSig _ False names _) <- tcdSigs + , L (OldRealSrcSpan l') n <- names ] } -documentSymbolForDecl (L (RealSrcSpan l _) (TyClD _ DataDecl { tcdLName = L _ name, tcdDataDefn = HsDataDefn { dd_cons } })) +documentSymbolForDecl (L (OldRealSrcSpan l) (TyClD _ DataDecl { tcdLName = L _ name, tcdDataDefn = HsDataDefn { dd_cons } })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName name , _kind = SkStruct @@ -113,8 +115,8 @@ , _selectionRange = realSrcSpanToRange l' , _children = conArgRecordFields (con_args x) } - | L (RealSrcSpan l _ ) x <- dd_cons - , L (RealSrcSpan l' _) n <- getConNames' x + | L (OldRealSrcSpan l ) x <- dd_cons + , L (OldRealSrcSpan l') n <- getConNames' x ] } where @@ -125,48 +127,48 @@ , _kind = SkField } | L _ cdf <- lcdfs - , L (RealSrcSpan l _) n <- rdrNameFieldOcc . unLoc <$> cd_fld_names cdf + , L (OldRealSrcSpan l) n <- rdrNameFieldOcc . unLoc <$> cd_fld_names cdf ] conArgRecordFields _ = Nothing -documentSymbolForDecl (L (RealSrcSpan l _) (TyClD _ SynDecl { tcdLName = L (RealSrcSpan l' _) n })) = Just +documentSymbolForDecl (L (OldRealSrcSpan l) (TyClD _ SynDecl { tcdLName = L (OldRealSrcSpan l') n })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName n , _kind = SkTypeParameter , _selectionRange = realSrcSpanToRange l' } -documentSymbolForDecl (L (RealSrcSpan l _) (InstD _ ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } })) +documentSymbolForDecl (L (OldRealSrcSpan l) (InstD _ ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = pprText cid_poly_ty , _kind = SkInterface } -documentSymbolForDecl (L (RealSrcSpan l _) (InstD _ DataFamInstD { dfid_inst = DataFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } })) +documentSymbolForDecl (L (OldRealSrcSpan 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 (RealSrcSpan l _) (InstD _ TyFamInstD { tfid_inst = TyFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } })) +documentSymbolForDecl (L (OldRealSrcSpan 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 (RealSrcSpan l _) (DerivD _ DerivDecl { deriv_type })) = +documentSymbolForDecl (L (OldRealSrcSpan l) (DerivD _ DerivDecl { deriv_type })) = gfindtype deriv_type <&> \(L (_ :: SrcSpan) name) -> (defDocumentSymbol l :: DocumentSymbol) { _name = pprText @(HsType GhcPs) name , _kind = SkInterface } -documentSymbolForDecl (L (RealSrcSpan l _) (ValD _ FunBind{fun_id = L _ name})) = Just +documentSymbolForDecl (L (OldRealSrcSpan l) (ValD _ FunBind{fun_id = L _ name})) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName name , _kind = SkFunction } -documentSymbolForDecl (L (RealSrcSpan l _) (ValD _ PatBind{pat_lhs})) = Just +documentSymbolForDecl (L (OldRealSrcSpan l) (ValD _ PatBind{pat_lhs})) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = pprText pat_lhs , _kind = SkFunction } -documentSymbolForDecl (L (RealSrcSpan l _) (ForD _ x)) = Just +documentSymbolForDecl (L (OldRealSrcSpan l) (ForD _ x)) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = case x of ForeignImport{} -> name @@ -200,7 +202,7 @@ } documentSymbolForImport :: Located (ImportDecl GhcPs) -> Maybe DocumentSymbol -documentSymbolForImport (L (RealSrcSpan l _) ImportDecl { ideclName, ideclQualified }) = Just +documentSymbolForImport (L (OldRealSrcSpan 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,6 +18,8 @@ , matchRegExMultipleImports ) where +import Bag (bagToList, + isEmptyBag) import Control.Applicative ((<|>)) import Control.Arrow (second, (>>>)) @@ -42,7 +44,6 @@ 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, @@ -56,6 +57,8 @@ 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 @@ -74,6 +77,18 @@ 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, (=~), (=~~)) @@ -241,7 +256,7 @@ | Just tcM <- mTcM, Just har <- mHar, [s'] <- [x | (x, "") <- readSrcSpan $ T.unpack s], - isUnusedImportedId tcM har (T.unpack identifier) (T.unpack modName) (RealSrcSpan s' Nothing), + isUnusedImportedId tcM har (T.unpack identifier) (T.unpack modName) (OldRealSrcSpan s'), mDecl <- findImportDeclByModuleName hsmodImports $ T.unpack modName, title <- "Hide " <> identifier <> " from " <> modName = if modName == "Prelude" && null mDecl @@ -425,10 +440,10 @@ findRelatedSpans indexedContent name - (L (RealSrcSpan l _) (ValD _ (extractNameAndMatchesFromFunBind -> Just (lname, matches)))) = + (L (OldRealSrcSpan l) (ValD _ (extractNameAndMatchesFromFunBind -> Just (lname, matches)))) = case lname of (L nLoc _name) | isTheBinding nLoc -> - let findSig (L (RealSrcSpan l _) (SigD _ sig)) = findRelatedSigSpan indexedContent name l sig + let findSig (L (OldRealSrcSpan l) (SigD _ sig)) = findRelatedSigSpan indexedContent name l sig findSig _ = [] in extendForSpaces indexedContent (toRange l) : @@ -451,7 +466,7 @@ let maybeSpan = findRelatedSigSpan1 name sig in case maybeSpan of Just (_span, True) -> pure $ extendForSpaces indexedContent $ toRange l -- a :: Int - Just (RealSrcSpan span _, False) -> pure $ toRange span -- a, b :: Int, a is unused + Just (OldRealSrcSpan span, False) -> pure $ toRange span -- a, b :: Int, a is unused _ -> [] -- Second of the tuple means there is only one match @@ -502,10 +517,10 @@ indexedContent name lsigs - (L (RealSrcSpan l _) (extractNameAndMatchesFromFunBind -> Just (lname, matches))) = + (L (OldRealSrcSpan l) (extractNameAndMatchesFromFunBind -> Just (lname, matches))) = if isTheBinding (getLoc lname) then - let findSig (L (RealSrcSpan l _) sig) = findRelatedSigSpan indexedContent name l sig + let findSig (L (OldRealSrcSpan l) sig) = findRelatedSigSpan indexedContent name l sig findSig _ = [] in extendForSpaces indexedContent (toRange l) : concatMap findSig lsigs else concatMap (findRelatedSpanForMatch indexedContent name) matches @@ -547,7 +562,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 (RealSrcSpan l _) exports) = + needsComma source (L (OldRealSrcSpan l) exports) = let closeParan = _end $ realSrcSpanToRange l lastExport = fmap _end . getLocatedRange $ last exports in case lastExport of @@ -675,7 +690,7 @@ newDefinitionAction IdeOptions{..} parsedModule Range{_start} name typ | Range _ lastLineP : _ <- [ realSrcSpanToRange sp - | (L l@(RealSrcSpan sp _) _) <- hsmodDecls + | (L l@(OldRealSrcSpan sp) _) <- hsmodDecls , _start `isInsideSrcSpan` l] , nextLineP <- Position{ _line = _line lastLineP + 1, _character = 0} = [ ("Define " <> sig @@ -1000,10 +1015,10 @@ liftParseAST @(HsExpr GhcPs) df $ prettyPrint $ HsVar @GhcPs noExtField $ - L (mkGeneralSrcSpan "") rdr + L (oldUnhelpfulSpan "") rdr else Rewrite (rangeToSrcSpan "" _range) $ \df -> liftParseAST @RdrName df $ - prettyPrint $ L (mkGeneralSrcSpan "") rdr + prettyPrint $ L (oldUnhelpfulSpan "") rdr ] findImportDeclByRange :: [LImportDecl GhcPs] -> Range -> Maybe (LImportDecl GhcPs) @@ -1301,7 +1316,7 @@ findPositionFromImportsOrModuleDecl :: HasSrcSpan a => t -> (t -> a) -> Bool -> Maybe ((Int, Int), Int) findPositionFromImportsOrModuleDecl hsField f hasImports = case getLoc (f hsField) of - RealSrcSpan s _ -> + OldRealSrcSpan 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,17 +29,21 @@ import Data.Maybe (fromJust, isNothing, mapMaybe) import qualified Data.Text as T -import Development.IDE.GHC.Compat -import qualified Development.IDE.GHC.Compat.Util as Util +import Development.IDE.GHC.Compat hiding (parseExpr) 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) ------------------------------------------------------------------------------ @@ -449,5 +453,5 @@ ty wild (filter ((/= symbol) . unqualIEWrapName . unLoc) cons) - (filter ((/= symbol) . T.pack . Util.unpackFS . flLabel . unLoc) flds) + (filter ((/= symbol) . T.pack . 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,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} @@ -30,7 +31,7 @@ import Development.IDE.GHC.Util (prettyPrint) import Development.IDE.Graph import Development.IDE.Graph.Classes -import qualified Development.IDE.Types.KnownTargets as KT +import Development.IDE.Import.FindImports import Development.IDE.Plugin.CodeAction (newImport, newImportToEdit) import Development.IDE.Plugin.CodeAction.ExactPrint @@ -47,6 +48,11 @@ 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) @@ -133,9 +139,7 @@ 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 @@ -145,7 +149,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 <> Just lModules + let compls = (fst <$> localCompls) <> (fst <$> nonLocalCompls) <> Just exportsCompls pure (opts, fmap (,pm,binds) compls, moduleExports) case compls of @@ -164,11 +168,6 @@ _ -> 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 @@ -26,6 +26,17 @@ import qualified Data.Text as T import qualified Text.Fuzzy.Parallel 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 ConLike import Control.Monad import Data.Aeson (ToJSON (toJSON)) import Data.Either (fromRight) @@ -35,8 +46,7 @@ import qualified Data.Set as Set import Development.IDE.Core.Compile import Development.IDE.Core.PositionMapping -import Development.IDE.GHC.Compat as GHC hiding (ppr) -import Development.IDE.GHC.Compat.Util +import Development.IDE.GHC.Compat as GHC import Development.IDE.GHC.Error import Development.IDE.GHC.Util import Development.IDE.Plugin.Completions.Types @@ -46,12 +56,15 @@ 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 @@ -257,7 +270,7 @@ getArgs t | isPredTy t = [] | isDictTy t = [] - | isForAllTy t = getArgs $ snd (splitForAllTyCoVars t) + | isForAllTy t = getArgs $ snd (splitForAllTys t) | isFunTy t = let (args, ret) = splitFunTys t in if isForAllTy ret @@ -325,7 +338,7 @@ packageState = hscEnv env curModName = moduleName curMod - importMap = Map.fromList [ (l, imp) | imp@(L (RealSrcSpan l _) _) <- limports ] + importMap = Map.fromList [ (l, imp) | imp@(L (OldRealSrcSpan l) _) <- limports ] iDeclToModName :: ImportDecl name -> ModuleName iDeclToModName = unLoc . ideclName 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,10 +9,10 @@ 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) 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,11 +28,13 @@ 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 @@ -50,7 +52,7 @@ newtype WaitForIdeRuleResult = WaitForIdeRuleResult { ideResultSuccess::Bool} deriving newtype (FromJSON, ToJSON) -plugin :: P.Plugin c +plugin :: 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,6 +12,7 @@ GlobalBindingTypeSigsResult (..), ) where +import Avail (availsToNameSet) import Control.DeepSeq (rwhnf) import Control.Monad (mzero) import Control.Monad.Extra (whenMaybe) @@ -41,6 +42,13 @@ 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, @@ -65,6 +73,16 @@ 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 @@ -167,7 +185,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 <- printSDocQualifiedUnsafe (mkPrintUnqualifiedDefault tcg_rdr_env) $ pprSigmaType ty + , tyMsg <- showSDocForUser unsafeGlobalDynFlags (mkPrintUnqualified unsafeGlobalDynFlags tcg_rdr_env) $ pprSigmaType ty , signature <- T.pack $ printName name <> " :: " <> tyMsg , startCharacter <- _character _start , startOfLine <- Position (_line _start) startCharacter @@ -211,8 +229,8 @@ -------------------------------------------------------------------------------- -showDocRdrEnv :: HscEnv -> GlobalRdrEnv -> SDoc -> String -showDocRdrEnv env rdrEnv = showSDocForUser (hsc_dflags env) (mkPrintUnqualified (hsc_dflags env) rdrEnv) +showDocRdrEnv :: DynFlags -> GlobalRdrEnv -> SDoc -> String +showDocRdrEnv dflags rdrEnv = showSDocForUser dflags (mkPrintUnqualified dflags rdrEnv) data GetGlobalBindingTypeSigs = GetGlobalBindingTypeSigs deriving (Generic, Show, Eq, Ord, Hashable, NFData, Binary) @@ -251,8 +269,9 @@ sigs = tcg_sigs gblEnv binds = collectHsBindsBinders $ tcg_binds gblEnv patSyns = tcg_patsyns gblEnv + dflags = hsc_dflags hsc rdrEnv = tcg_rdr_env gblEnv - showDoc = showDocRdrEnv hsc rdrEnv + showDoc = showDocRdrEnv dflags 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,16 +30,25 @@ 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 @@ -121,12 +130,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 $ moduleUnit mod) exclude + rows <- liftIO $ findReferences hiedb True (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnitId 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 $ moduleUnit mod) exclude + refs <- liftIO $ findTypeRefs hiedb True (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnitId mod) exclude pure $ mapMaybe typeRowToLoc refs _ -> pure [] pure $ nubOrd $ foiRefs ++ concat nonFOIRefs ++ concat typeRefs @@ -199,10 +208,10 @@ :: IdeOptions -> HieAstResult -> DocAndKindMap - -> HscEnv + -> DynFlags -> Position -> Maybe (Maybe Range, [T.Text]) -atPoint IdeOptions{} (HAR _ hf _ _ kind) (DKMap dm km) env pos = listToMaybe $ pointCommand hf pos hoverInfo +atPoint IdeOptions{} (HAR _ hf _ _ kind) (DKMap dm km) df pos = listToMaybe $ pointCommand hf pos hoverInfo where -- Hover info for values/data hoverInfo ast = (Just range, prettyNames ++ pTypes) @@ -231,10 +240,10 @@ prettyPackageName n = do m <- nameModule_maybe n - let pid = moduleUnit m - conf <- lookupUnit env pid - let pkgName = T.pack $ unitPackageNameString conf - version = T.pack $ showVersion (unitPackageVersion conf) + let pid = moduleUnitId m + conf <- lookupPackage df pid + let pkgName = T.pack $ packageNameString conf + version = T.pack $ showVersion (packageVersion conf) pure $ " *(" <> pkgName <> "-" <> version <> ")*" prettyTypes = map (("_ :: "<>) . prettyType) types @@ -291,10 +300,10 @@ in fmap nubOrd $ concatMapM (fmap (fromMaybe []) . nameToLocation hiedb lookupModule) (getTypes ts) namesInType :: Type -> [Name] -namesInType (TyVarTy n) = [varName n] +namesInType (TyVarTy n) = [Var.varName n] namesInType (AppTy a b) = getTypes [a,b] namesInType (TyConApp tc ts) = tyConName tc : getTypes ts -namesInType (ForAllTy b t) = varName (binderVar b) : namesInType t +namesInType (ForAllTy b t) = Var.varName (binderVar b) : namesInType t namesInType (FunTy a b) = getTypes [a,b] namesInType (CastTy t _) = namesInType t namesInType (LitTy _) = [] @@ -324,9 +333,9 @@ nameToLocation :: MonadIO m => HieDb -> LookupModule m -> Name -> m (Maybe [Location]) nameToLocation hiedb lookupModule name = runMaybeT $ case nameSrcSpan name of - sp@(RealSrcSpan rsp _) + sp@(OldRealSrcSpan rsp) -- Lookup in the db if we got a location in a boot file - | fs <- Util.unpackFS (srcSpanFile rsp) + | fs <- unpackFS (srcSpanFile rsp) , not $ "boot" `isSuffixOf` fs -> do itExists <- liftIO $ doesFileExist fs @@ -344,7 +353,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 $ moduleUnit mod) + erow <- liftIO $ findDef hiedb (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnitId mod) case erow of [] -> do -- If the lookup failed, try again without specifying a unit-id. @@ -389,17 +398,7 @@ pointCommand :: HieASTs t -> Position -> (HieAST t -> a) -> [a] pointCommand hf pos k = catMaybes $ M.elems $ flip M.mapWithKey (getAsts hf) $ \fs ast -> - -- 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 + case selectSmallestContaining (sp 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,13 +23,20 @@ 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 +import Development.IDE.GHC.Compat (oldMkUserStyle, + oldRenderWithStyle) 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 @@ -41,7 +48,11 @@ showSD = T.pack . unsafePrintSDoc showNameWithoutUniques :: Outputable a => a -> T.Text -showNameWithoutUniques = T.pack . printNameWithoutUniques +showNameWithoutUniques = T.pack . prettyprint + where + dyn = unsafeGlobalDynFlags `gopt_set` Opt_SuppressUniques + prettyprint x = oldRenderWithStyle dyn (ppr x) style + style = oldMkUserStyle dyn neverQualify AllTheWay -- | Shows IEWrappedName, without any modifier, qualifier or unique identifier. unqualIEWrapName :: IEWrappedName RdrName -> T.Text @@ -55,9 +66,9 @@ safeTyThingType _ = Nothing safeTyThingId :: TyThing -> Maybe Id -safeTyThingId (AnId i) = Just i -safeTyThingId (AConLike (RealDataCon dataCon)) = Just (dataConWrapId dataCon) -safeTyThingId _ = Nothing +safeTyThingId (AnId i) = Just i +safeTyThingId (AConLike conLike) = conLikeWrapId_maybe conLike +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,7 +13,6 @@ ) where import Control.Monad -import Control.Monad.IO.Class import Control.Monad.Extra (findM) import Data.Either import Data.Foldable @@ -25,13 +24,20 @@ 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 @@ -80,11 +86,12 @@ -- 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 env mod - src <- toFileUriText $ lookupSrcHtmlForModule env mod + doc <- toFileUriText $ lookupDocHtmlForModule df mod + src <- toFileUriText $ lookupSrcHtmlForModule df mod return (doc, src) Nothing -> pure (Nothing, Nothing) let docUri = (<> "#" <> selector <> showNameWithoutUniques name) <$> docFu @@ -176,28 +183,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 :: HscEnv -> Module -> IO (Maybe FilePath) +lookupDocHtmlForModule :: DynFlags -> 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 :: HscEnv -> Module -> IO (Maybe FilePath) +lookupSrcHtmlForModule :: DynFlags -> Module -> IO (Maybe FilePath) lookupSrcHtmlForModule = lookupHtmlForModule (\pkgDocDir modDocName -> pkgDocDir "src" modDocName <.> "html") -lookupHtmlForModule :: (FilePath -> FilePath -> FilePath) -> HscEnv -> Module -> IO (Maybe FilePath) -lookupHtmlForModule mkDocPath hscEnv m = do +lookupHtmlForModule :: (FilePath -> FilePath -> FilePath) -> DynFlags -> Module -> IO (Maybe FilePath) +lookupHtmlForModule mkDocPath df m = do -- try all directories - let mfs = fmap (concatMap go) (lookupHtmls hscEnv ui) + let mfs = fmap (concatMap go) (lookupHtmls df 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 = moduleUnit m + ui = moduleUnitId 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. @@ -206,8 +213,8 @@ -- The file might use "." or "-" as separator map (`intercalate` chunks) [".", "-"] -lookupHtmls :: HscEnv -> Unit -> Maybe [FilePath] +lookupHtmls :: DynFlags -> 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 . unitHaddockInterfaces <$> lookupUnit df ui + map takeDirectory . haddockInterfaces <$> lookupPackage 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,13 +20,12 @@ import Development.IDE.GHC.Compat (Name, RefMap, Scope (..), Type, getBindSiteFromContext, getScopeFromContext, identInfo, - identType, NameEnv, nameEnvElts, - unitNameEnv, isSystemName, - RealSrcSpan, realSrcSpanStart, - realSrcSpanEnd) - + identType) 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,11 +7,10 @@ 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)) @@ -25,8 +24,12 @@ 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 @@ -78,12 +81,8 @@ occ = occName n mkIdentInfos :: Text -> AvailInfo -> [IdentInfo] -mkIdentInfos mod (AvailName n) = - [IdentInfo (nameOccName n) (renderIEWrapped n) Nothing (isDataConName n) mod] -mkIdentInfos mod (AvailFL fl) = +mkIdentInfos mod (Avail n) = [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,33 +11,37 @@ ) 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 (Unique) -import qualified Data.Unique as Unique +import Data.Either (fromRight) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Unique import Development.IDE.GHC.Compat -import qualified Development.IDE.GHC.Compat.Util as Maybes -import Development.IDE.GHC.Error (catchSrcErrors) -import Development.IDE.GHC.Util (lookupPackageConfig) +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 OpenTelemetry.Eventlog (withSpan) -import System.Directory (canonicalizePath) +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 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 :: [(UnitId, DynFlags)] + , deps :: [(InstalledUnitId, DynFlags)] -- ^ In memory components for this HscEnv -- This is only used at the moment for the import dirs in -- the DynFlags @@ -53,7 +57,7 @@ } -- | Wrap an 'HscEnv' into an 'HscEnvEq'. -newHscEnvEq :: FilePath -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq +newHscEnvEq :: FilePath -> HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq newHscEnvEq cradlePath hscEnv0 deps = do let relativeToCradle = (takeDirectory cradlePath ) hscEnv = removeImportPaths hscEnv0 @@ -64,29 +68,29 @@ newHscEnvEqWithImportPaths (Just $ Set.fromList importPathsCanon) hscEnv deps -newHscEnvEqWithImportPaths :: Maybe (Set FilePath) -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq +newHscEnvEqWithImportPaths :: Maybe (Set FilePath) -> HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq newHscEnvEqWithImportPaths envImportPaths hscEnv deps = do let dflags = hsc_dflags hscEnv - envUnique <- Unique.newUnique + envUnique <- newUnique -- it's very important to delay the package exports computation envPackageExports <- onceAsync $ withSpan "Package Exports" $ \_sp -> do -- compute the package imports - let pkgst = unitState hscEnv - depends = explicitUnits pkgst + let pkgst = pkgState dflags + depends = explicitPackages pkgst targets = [ (pkg, mn) | d <- depends , Just pkg <- [lookupPackageConfig d hscEnv] - , (mn, _) <- unitExposedModules pkg + , (mn, _) <- exposedModules pkg ] doOne (pkg, mn) = do modIface <- liftIO $ initIfaceLoad hscEnv $ loadInterface "" - (mkModule (unitInfoId pkg) mn) + (mkModule (packageConfigId pkg) mn) (ImportByUser NotBoot) return $ case modIface of Maybes.Failed _r -> Nothing @@ -100,13 +104,13 @@ <$> catchSrcErrors dflags "listVisibleModuleNames" - (evaluate . force . Just $ listVisibleModuleNames hscEnv) + (evaluate . force . Just $ oldListVisibleModuleNames dflags) return HscEnvEq{..} -- | Wrap an 'HscEnv' into an 'HscEnvEq'. newHscEnvEqPreserveImportPaths - :: HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq + :: HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq newHscEnvEqPreserveImportPaths = newHscEnvEqWithImportPaths Nothing -- | Unwrap the 'HscEnv' with the original import paths. @@ -114,15 +118,15 @@ hscEnvWithImportPaths :: HscEnvEq -> HscEnv hscEnvWithImportPaths HscEnvEq{..} | Just imps <- envImportPaths - = hscSetFlags (setImportPaths (Set.toList imps) (hsc_dflags hscEnv)) hscEnv + = hscEnv{hsc_dflags = (hsc_dflags hscEnv){importPaths = Set.toList imps}} | otherwise = hscEnv removeImportPaths :: HscEnv -> HscEnv -removeImportPaths hsc = hscSetFlags (setImportPaths [] (hsc_dflags hsc)) hsc +removeImportPaths hsc = hsc{hsc_dflags = (hsc_dflags hsc){importPaths = []}} instance Show HscEnvEq where - show HscEnvEq{envUnique} = "HscEnvEq " ++ show (Unique.hashUnique envUnique) + show HscEnvEq{envUnique} = "HscEnvEq " ++ show (hashUnique envUnique) instance Eq HscEnvEq where a == b = envUnique a == envUnique b @@ -130,7 +134,7 @@ instance NFData HscEnvEq where rnf (HscEnvEq a b c d _ _) = -- deliberately skip the package exports map and visible module names - rnf (Unique.hashUnique a) `seq` b `seq` c `seq` rnf d + rnf (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,17 +31,11 @@ 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 :: UnitState -> Module -> IO (Maybe FilePath) + { optLocateHieFile :: PackageConfig -> Module -> IO (Maybe FilePath) -- ^ Locate the HIE file for the given module. The PackageConfig can be -- used to lookup settings like importDirs. - , optLocateSrcFile :: UnitState -> Module -> IO (Maybe FilePath) + , optLocateSrcFile :: PackageConfig -> 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/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 deleted file mode 100644 --- 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 +++ /dev/null @@ -1,50 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.2/a-1.0.0/build/autogen/Paths_a.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/a-1.0.0/build/autogen/Paths_a.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/b-1.0.0/build/autogen/Paths_b.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# 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,7 +56,6 @@ 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 @@ -4590,24 +4589,7 @@ <- compls , _label == "anidentifier" ] - 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" + liftIO $ compls' @?= ["Defined in 'A"] ] highlightTests :: TestTree