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: 2.1.0.0 +version: 2.2.0.0 license: Apache-2.0 license-file: LICENSE author: Digital Asset and Ghcide contributors @@ -35,6 +35,11 @@ default: False manual: True +flag pedantic + description: Enable -Werror + default: False + manual: True + library default-language: Haskell2010 build-depends: @@ -65,12 +70,12 @@ haddock-library >= 1.8 && < 1.12, hashable, hie-compat ^>= 0.3.0.0, - hls-plugin-api == 2.1.0.0, + hls-plugin-api == 2.2.0.0, lens, list-t, hiedb == 0.4.3.*, - lsp-types ^>= 2.0.1.0, - lsp ^>= 2.1.0.0 , + lsp-types ^>= 2.0.2.0, + lsp ^>= 2.2.0.0 , mtl, optparse-applicative, parallel, @@ -81,7 +86,7 @@ row-types, text-rope, safe-exceptions, - hls-graph == 2.1.0.0, + hls-graph == 2.2.0.0, sorted-list, sqlite-simple, stm, @@ -221,7 +226,6 @@ ghc-options: -Wall - -Wno-name-shadowing -Wincomplete-uni-patterns -Wno-unticked-promoted-constructors -fno-ignore-asserts @@ -229,6 +233,27 @@ if flag(ghc-patched-unboxed-bytecode) cpp-options: -DGHC_PATCHED_UNBOXED_BYTECODE + if flag(pedantic) + -- We eventually want to build with Werror fully, but we haven't + -- finished purging the warnings, so some are set to not be errors + -- for now + ghc-options: -Werror + -Wwarn=unused-packages + -Wwarn=unrecognised-pragmas + -Wwarn=dodgy-imports + -Wwarn=missing-signatures + -Wwarn=duplicate-exports + -Wwarn=dodgy-exports + -Wwarn=incomplete-patterns + -Wwarn=overlapping-patterns + -Wwarn=incomplete-record-updates + + -- ambiguous-fields is only understood by GHC >= 9.2, so we only disable it + -- then. The above comment goes for here too -- this should be understood to + -- be temporary until we can remove these warnings. + if impl(ghc >= 9.2) && flag(pedantic) + ghc-options: -Wwarn=ambiguous-fields + if impl(ghc >= 9) ghc-options: -Wunused-packages @@ -346,7 +371,7 @@ hls-plugin-api, lens, list-t, - lsp-test ^>= 0.15.0.1, + lsp-test ^>= 0.16.0.0, mtl, monoid-subclasses, network-uri, 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 @@ -34,13 +34,14 @@ import Data.Bifunctor import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Char8 as B +import Data.Char (isLower) import Data.Default import Data.Either.Extra import Data.Function -import Data.Hashable +import Data.Hashable hiding (hash) import qualified Data.HashMap.Strict as HM -import Data.IORef import Data.List +import Data.List.Extra (dropPrefix, split) import qualified Data.Map.Strict as Map import Data.Maybe import Data.Proxy @@ -49,11 +50,11 @@ import Data.Version import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake hiding (Log, Priority, - withHieDb) + knownTargets, withHieDb) import qualified Development.IDE.GHC.Compat as Compat import Development.IDE.GHC.Compat.Core hiding (Target, TargetFile, TargetModule, - Var, Warning) + Var, Warning, getOptions) import qualified Development.IDE.GHC.Compat.Core as GHC import Development.IDE.GHC.Compat.Env hiding (Logger) import Development.IDE.GHC.Compat.Units (UnitId) @@ -68,6 +69,7 @@ import Development.IDE.Types.Options import GHC.Check import qualified HIE.Bios as HieBios +import qualified HIE.Bios.Cradle as HieBios import HIE.Bios.Environment hiding (getCacheDir) import HIE.Bios.Types hiding (Log) import qualified HIE.Bios.Types as HieBios @@ -108,6 +110,12 @@ import qualified System.Random as Random import System.Random (RandomGen) +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] + +#if !MIN_VERSION_ghc(9,4,0) +import Data.IORef +#endif + data Log = LogSettingInitialDynFlags | LogGetInitialGhcLibDirDefaultCradleFail !CradleError !FilePath !(Maybe FilePath) !(Cradle Void) @@ -145,21 +153,21 @@ , "Cradle:" <+> viaShow cradle ] LogGetInitialGhcLibDirDefaultCradleNone -> "Couldn't load cradle. Cradle not found." - LogHieDbRetry delay maxDelay maxRetryCount e -> + LogHieDbRetry delay maxDelay retriesRemaining e -> nest 2 $ vcat [ "Retrying hiedb action..." , "delay:" <+> pretty delay , "maximum delay:" <+> pretty maxDelay - , "retries remaining:" <+> pretty maxRetryCount + , "retries remaining:" <+> pretty retriesRemaining , "SQLite error:" <+> pretty (displayException e) ] - LogHieDbRetriesExhausted baseDelay maxDelay maxRetryCount e -> + LogHieDbRetriesExhausted baseDelay maxDelay retriesRemaining e -> nest 2 $ vcat [ "Retries exhausted for hiedb action." , "base delay:" <+> pretty baseDelay , "maximum delay:" <+> pretty maxDelay - , "retries remaining:" <+> pretty maxRetryCount + , "retries remaining:" <+> pretty retriesRemaining , "Exception:" <+> pretty (displayException e) ] LogHieDbWriterThreadSQLiteError e -> nest 2 $ @@ -196,7 +204,7 @@ "Cradle:" <+> viaShow cradle LogNewComponentCache componentCache -> "New component cache HscEnvEq:" <+> viaShow componentCache - LogHieBios log -> pretty log + LogHieBios msg -> pretty msg -- | Bump this version number when making changes to the format of the data stored in hiedb hiedbDataVersion :: String @@ -260,17 +268,16 @@ getInitialGhcLibDirDefault :: Recorder (WithPriority Log) -> FilePath -> IO (Maybe LibDir) getInitialGhcLibDirDefault recorder rootDir = do - let log = logWith recorder hieYaml <- findCradle def rootDir cradle <- loadCradle def hieYaml rootDir libDirRes <- getRuntimeGhcLibDir (toCologActionWithPrio (cmapWithPrio LogHieBios recorder)) cradle case libDirRes of CradleSuccess libdir -> pure $ Just $ LibDir libdir CradleFail err -> do - log Error $ LogGetInitialGhcLibDirDefaultCradleFail err rootDir hieYaml cradle + logWith recorder Error $ LogGetInitialGhcLibDirDefaultCradleFail err rootDir hieYaml cradle pure Nothing CradleNone -> do - log Warning LogGetInitialGhcLibDirDefaultCradleNone + logWith recorder Warning LogGetInitialGhcLibDirDefaultCradleNone pure Nothing -- | Sets `unsafeGlobalDynFlags` on using the hie-bios cradle and returns the GHC libdir @@ -298,28 +305,26 @@ -> g -- ^ random number generator -> m a -- ^ action that may throw exception -> m a -retryOnException exceptionPred recorder maxDelay !baseDelay !maxRetryCount rng action = do +retryOnException exceptionPred recorder maxDelay !baseDelay !maxTimesRetry rng action = do result <- tryJust exceptionPred action case result of Left e - | maxRetryCount > 0 -> do + | maxTimesRetry > 0 -> do -- multiply by 2 because baseDelay is midpoint of uniform range let newBaseDelay = min maxDelay (baseDelay * 2) let (delay, newRng) = Random.randomR (0, newBaseDelay) rng - let newMaxRetryCount = maxRetryCount - 1 + let newMaxTimesRetry = maxTimesRetry - 1 liftIO $ do - log Warning $ LogHieDbRetry delay maxDelay newMaxRetryCount (toException e) + logWith recorder Warning $ LogHieDbRetry delay maxDelay newMaxTimesRetry (toException e) threadDelay delay - retryOnException exceptionPred recorder maxDelay newBaseDelay newMaxRetryCount newRng action + retryOnException exceptionPred recorder maxDelay newBaseDelay newMaxTimesRetry newRng action | otherwise -> do liftIO $ do - log Warning $ LogHieDbRetriesExhausted baseDelay maxDelay maxRetryCount (toException e) + logWith recorder Warning $ LogHieDbRetriesExhausted baseDelay maxDelay maxTimesRetry (toException e) throwIO e Right b -> pure b - where - log = logWith recorder -- | in microseconds oneSecond :: Int @@ -374,21 +379,19 @@ withAsync (writerThread withWriteDbRetryable chan) $ \_ -> do withHieDb fp (\readDb -> k (makeWithHieDbRetryable recorder rng readDb) chan) where - log = logWith recorder - writerThread :: WithHieDb -> IndexQueue -> IO () writerThread withHieDbRetryable chan = do -- Clear the index of any files that might have been deleted since the last run _ <- withHieDbRetryable deleteMissingRealFiles _ <- withHieDbRetryable garbageCollectTypeNames forever $ do - k <- atomically $ readTQueue chan + l <- atomically $ readTQueue chan -- TODO: probably should let exceptions be caught/logged/handled by top level handler - k withHieDbRetryable + l withHieDbRetryable `Safe.catch` \e@SQLError{} -> do - log Error $ LogHieDbWriterThreadSQLiteError e - `Safe.catchAny` \e -> do - log Error $ LogHieDbWriterThreadException e + logWith recorder Error $ LogHieDbWriterThreadSQLiteError e + `Safe.catchAny` \f -> do + logWith recorder Error $ LogHieDbWriterThreadException f getHieDbLoc :: FilePath -> IO FilePath @@ -517,7 +520,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 : maybe [] snd oldDeps -- Get all the unit-ids for things in this component @@ -529,7 +532,7 @@ #if MIN_VERSION_ghc(9,3,0) let (df2, uids) = (rawComponentDynFlags, []) #else - let (df2, uids) = removeInplacePackages fakeUid inplace rawComponentDynFlags + let (df2, uids) = _removeInplacePackages fakeUid inplace rawComponentDynFlags #endif let prefix = show rawComponentUnitId -- See Note [Avoiding bad interface files] @@ -551,11 +554,11 @@ -- scratch again (for now) -- It's important to keep the same NameCache though for reasons -- that I do not fully understand - log Info $ LogMakingNewHscEnv inplace - hscEnv <- emptyHscEnv ideNc libDir + logWith recorder Info $ LogMakingNewHscEnv inplace + hscEnvB <- emptyHscEnv ideNc libDir !newHscEnv <- -- Add the options for the current component to the HscEnv - evalGhcEnv hscEnv $ do + evalGhcEnv hscEnvB $ do _ <- setSessionDynFlags #if !MIN_VERSION_ghc(9,3,0) $ setHomeUnitId_ fakeUid @@ -592,7 +595,7 @@ res <- loadDLL hscEnv "libm.so.6" case res of Nothing -> pure () - Just err -> log Error $ LogDLLLoadError err + Just err -> logWith recorder Error $ LogDLLLoadError err -- Make a map from unit-id to DynFlags, this is used when trying to @@ -634,21 +637,22 @@ let cs_exist = catMaybes (zipWith (<$) cfps' mmt) modIfaces <- uses GetModIface cs_exist -- update exports map - extras <- getShakeExtras + shakeExtras <- getShakeExtras let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces - liftIO $ atomically $ modifyTVar' (exportsMap extras) (exportsMap' <>) + liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>) return (second Map.keys res) let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath]) consultCradle hieYaml cfp = do - lfp <- flip makeRelative cfp <$> getCurrentDirectory - log Info $ LogCradlePath lfp + lfpLog <- flip makeRelative cfp <$> getCurrentDirectory + logWith recorder Info $ LogCradlePath lfpLog when (isNothing hieYaml) $ - log Warning $ LogCradleNotFound lfp + logWith recorder Warning $ LogCradleNotFound lfpLog cradle <- loadCradle hieYaml dir + -- TODO: Why are we repeating the same command we have on line 646? lfp <- flip makeRelative cfp <$> getCurrentDirectory when optTesting $ mRunLspT lspEnv $ @@ -664,7 +668,7 @@ addTag "result" (show res) return res - log Debug $ LogSessionLoadingResult eopts + logWith recorder Debug $ LogSessionLoadingResult eopts case eopts of -- The cradle gave us some options so get to work turning them -- into and HscEnv. @@ -681,7 +685,7 @@ Left err -> do dep_info <- getDependencyInfo (maybeToList hieYaml) let ncfp = toNormalizedFilePath' cfp - let res = (map (renderCradleError ncfp) err, Nothing) + let res = (map (renderCradleError cradle ncfp) err, Nothing) void $ modifyVar' fileToFlags $ Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info)) void $ modifyVar' filesMap $ HM.insert ncfp hieYaml @@ -724,11 +728,9 @@ opts <- liftIO $ join $ mask_ $ modifyVar runningCradle $ \as -> do -- If the cradle is not finished, then wait for it to finish. void $ wait as - as <- async $ getOptions file - return (as, wait as) + asyncRes <- async $ getOptions file + return (asyncRes, wait asyncRes) pure opts - where - log = logWith recorder -- | Run the specific cradle on a specific FilePath via hie-bios. -- This then builds dependencies or whatever based on the cradle, gets the @@ -784,14 +786,14 @@ -> DependencyInfo -> IO [TargetDetails] -- For a target module we consider all the import paths -fromTargetId is exts (GHC.TargetModule mod) env dep = do - let fps = [i moduleNameSlashes mod -<.> ext <> boot +fromTargetId is exts (GHC.TargetModule modName) env dep = do + let fps = [i moduleNameSlashes modName -<.> ext <> boot | ext <- exts , i <- is , boot <- ["", "-boot"] ] locs <- mapM (fmap toNormalizedFilePath' . makeAbsolute) fps - return [TargetDetails (TargetModule mod) env dep locs] + return [TargetDetails (TargetModule modName) env dep locs] -- For a 'TargetFile' we consider all the possible module names fromTargetId _ _ (GHC.TargetFile f _) env deps = do nf <- toNormalizedFilePath' <$> makeAbsolute f @@ -924,10 +926,71 @@ & maybe id setODir oCacheDir -renderCradleError :: NormalizedFilePath -> CradleError -> FileDiagnostic -renderCradleError nfp (CradleError _ _ec t) = - ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) nfp (T.unlines (map T.pack t)) +renderCradleError :: Cradle a -> NormalizedFilePath -> CradleError -> FileDiagnostic +renderCradleError cradle nfp (CradleError _ _ec ms) = + ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) nfp $ T.unlines $ map T.pack userFriendlyMessage + where + userFriendlyMessage :: [String] + userFriendlyMessage + | HieBios.isCabalCradle cradle = fromMaybe ms fileMissingMessage + | otherwise = ms + + fileMissingMessage :: Maybe [String] + fileMissingMessage = + multiCradleErrMessage <$> parseMultiCradleErr ms + +-- | Information included in Multi Cradle error messages +data MultiCradleErr = MultiCradleErr + { mcPwd :: FilePath + , mcFilePath :: FilePath + , mcPrefixes :: [(FilePath, String)] + } deriving (Show) + +-- | Attempt to parse a multi-cradle message +parseMultiCradleErr :: [String] -> Maybe MultiCradleErr +parseMultiCradleErr ms = do + _ <- lineAfter "Multi Cradle: " + wd <- lineAfter "pwd: " + fp <- lineAfter "filepath: " + ps <- prefixes + pure $ MultiCradleErr wd fp ps + + where + lineAfter :: String -> Maybe String + lineAfter pre = listToMaybe $ mapMaybe (stripPrefix pre) ms + + prefixes :: Maybe [(FilePath, String)] + prefixes = do + pure $ mapMaybe tuple ms + + tuple :: String -> Maybe (String, String) + tuple line = do + line' <- surround '(' line ')' + [f, s] <- pure $ split (==',') line' + pure (f, s) + + -- extracts the string surrounded by required characters + surround :: Char -> String -> Char -> Maybe String + surround start s end = do + guard (listToMaybe s == Just start) + guard (listToMaybe (reverse s) == Just end) + pure $ drop 1 $ take (length s - 1) s + +multiCradleErrMessage :: MultiCradleErr -> [String] +multiCradleErrMessage e = + [ "Loading the module '" <> moduleFileName <> "' failed. It may not be listed in your .cabal file!" + , "Perhaps you need to add `"<> moduleName <> "` to other-modules or exposed-modules." + , "For more information, visit: https://cabal.readthedocs.io/en/3.4/developing-packages.html#modules-included-in-the-package" + , "" + ] <> map prefix (mcPrefixes e) + where + localFilePath f = dropWhile (==pathSeparator) $ dropPrefix (mcPwd e) f + moduleFileName = localFilePath $ mcFilePath e + moduleName = intercalate "." $ map dropExtension $ dropWhile isSourceFolder $ splitDirectories moduleFileName + isSourceFolder p = all isLower $ take 1 p + prefix (f, r) = f <> " - " <> r + -- See Note [Multi Cradle Dependency Info] type DependencyInfo = Map.Map FilePath (Maybe UTCTime) type HieMap = Map.Map (Maybe FilePath) (HscEnv, [RawComponentInfo]) @@ -995,11 +1058,11 @@ getDependencyInfo fs = Map.fromList <$> mapM do_one fs where - tryIO :: IO a -> IO (Either IOException a) - tryIO = Safe.try + safeTryIO :: IO a -> IO (Either IOException a) + safeTryIO = Safe.try do_one :: FilePath -> IO (FilePath, Maybe UTCTime) - do_one fp = (fp,) . eitherToMaybe <$> tryIO (getModificationTime fp) + do_one fp = (fp,) . eitherToMaybe <$> safeTryIO (getModificationTime fp) -- | This function removes all the -package flags which refer to packages we -- are going to deal with ourselves. For example, if a executable depends @@ -1009,12 +1072,12 @@ -- There are several places in GHC (for example the call to hptInstances in -- 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 +_removeInplacePackages --Only used in ghc < 9.4 :: UnitId -- ^ fake uid to use for our internal component -> [UnitId] -> DynFlags -> (DynFlags, [UnitId]) -removeInplacePackages fake_uid us df = (setHomeUnitId_ fake_uid $ +_removeInplacePackages fake_uid us df = (setHomeUnitId_ fake_uid $ df { packageFlags = ps }, uids) where (uids, ps) = Compat.filterInplaceUnits us (packageFlags 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 @@ -67,7 +67,7 @@ !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) MaybeT $ liftIO $ fmap (first (toCurrentRange mapping =<<)) <$> AtPoint.atPoint opts hf dkMap env pos' --- | For each Loacation, determine if we have the PositionMapping +-- | For each Location, determine if we have the PositionMapping -- for the correct file. If not, get the correct position mapping -- and then apply the position mapping to the location. toCurrentLocations 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 @@ -39,14 +39,15 @@ , shareUsages ) where +import Prelude hiding (mod) import Control.Monad.IO.Class import Control.Concurrent.Extra import Control.Concurrent.STM.Stats hiding (orElse) -import Control.DeepSeq (NFData (..), force, liftRnf, - rnf, rwhnf) +import Control.DeepSeq (NFData (..), force, + rnf) import Control.Exception (evaluate) import Control.Exception.Safe -import Control.Lens hiding (List, (<.>)) +import Control.Lens hiding (List, (<.>), pre) import Control.Monad.Except import Control.Monad.Extra import Control.Monad.Trans.Except @@ -62,13 +63,10 @@ import Data.Generics.Schemes import qualified Data.HashMap.Strict as HashMap import Data.IntMap (IntMap) -import qualified Data.IntMap.Strict as IntMap import Data.IORef import Data.List.Extra -import Data.Map (Map) import qualified Data.Map.Strict as Map import Data.Proxy (Proxy(Proxy)) -import qualified Data.Set as Set import Data.Maybe import qualified Data.Text as T import Data.Time (UTCTime (..)) @@ -96,11 +94,10 @@ import Development.IDE.Types.Options import GHC (ForeignHValue, GetDocsFailure (..), - GhcException (..), parsedSource) import qualified GHC.LanguageExtensions as LangExt import GHC.Serialized -import HieDb +import HieDb hiding (withHieDb) import qualified Language.LSP.Server as LSP import Language.LSP.Protocol.Types (DiagnosticTag (..)) import qualified Language.LSP.Protocol.Types as LSP @@ -108,44 +105,56 @@ import System.Directory import System.FilePath import System.IO.Extra (fixIO, newTempFileWithin) -import Unsafe.Coerce +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] + +#if !MIN_VERSION_ghc(9,0,1) +import HscTypes +import TcSplice +#endif + #if MIN_VERSION_ghc(9,0,1) import GHC.Tc.Gen.Splice +#endif +#if MIN_VERSION_ghc(9,0,1) && !MIN_VERSION_ghc(9,2,1) +import GHC.Driver.Types +#endif + +#if !MIN_VERSION_ghc(9,2,0) +import qualified Data.IntMap.Strict as IntMap +#endif + +#if MIN_VERSION_ghc(9,2,0) +import qualified GHC as G +#endif + +#if MIN_VERSION_ghc(9,2,0) && !MIN_VERSION_ghc(9,3,0) +import GHC (ModuleGraph) +#endif + #if MIN_VERSION_ghc(9,2,1) import GHC.Types.ForeignStubs import GHC.Types.HpcInfo import GHC.Types.TypeEnv -#else -import GHC.Driver.Types #endif -#else -import HscTypes -import TcSplice +#if !MIN_VERSION_ghc(9,3,0) +import Data.Map (Map) +import GHC (GhcException (..)) +import Unsafe.Coerce #endif -#if MIN_VERSION_ghc(9,2,0) -import GHC (Anchor (anchor), - EpaComment (EpaComment), - EpaCommentTok (EpaBlockComment, EpaLineComment), - ModuleGraph, epAnnComments, - mgLookupModule, - mgModSummaries, - priorComments) -import qualified GHC as G -import GHC.Hs (LEpaComment) -import qualified GHC.Types.Error as Error -import Development.IDE.Import.DependencyInformation +#if MIN_VERSION_ghc(9,3,0) +import qualified Data.Set as Set #endif #if MIN_VERSION_ghc(9,5,0) -import GHC.Driver.Config.CoreToStg.Prep -import GHC.Core.Lint.Interactive +import GHC.Driver.Config.CoreToStg.Prep +import GHC.Core.Lint.Interactive #endif ---Simple constansts to make sure the source is consistently named +--Simple constants to make sure the source is consistently named sourceTypecheck :: T.Text sourceTypecheck = "typecheck" sourceParser :: T.Text @@ -178,7 +187,7 @@ newtype TypecheckHelpers = TypecheckHelpers - { getLinkables :: ([NormalizedFilePath] -> IO [LinkableResult]) -- ^ hls-graph action to get linkables for files + { getLinkables :: [NormalizedFilePath] -> IO [LinkableResult] -- ^ hls-graph action to get linkables for files } typecheckModule :: IdeDefer @@ -193,14 +202,14 @@ (initPlugins hsc modSummary) case initialized of Left errs -> return (errs, Nothing) - Right (modSummary', hsc) -> do + Right (modSummary', hscEnv) -> do (warnings, etcm) <- withWarnings sourceTypecheck $ \tweak -> let - session = tweak (hscSetFlags dflags hsc) + session = tweak (hscSetFlags dflags hscEnv) -- TODO: maybe settings ms_hspp_opts is unnecessary? mod_summary'' = modSummary' { ms_hspp_opts = hsc_dflags session} in - catchSrcErrors (hsc_dflags hsc) sourceTypecheck $ do + catchSrcErrors (hsc_dflags hscEnv) sourceTypecheck $ do tcRnModule session tc_helpers $ demoteIfDefer pm{pm_mod_summary = mod_summary''} let errorPipeline = unDefer . hideDiag dflags . tagDiag diags = map errorPipeline warnings @@ -335,8 +344,8 @@ ; moduleLocs <- readIORef (hsc_FC hsc_env) #endif ; lbs <- getLinkables [toNormalizedFilePath' file - | mod <- mods_transitive_list - , let ifr = fromJust $ lookupInstalledModuleEnv moduleLocs mod + | installedMod <- mods_transitive_list + , let ifr = fromJust $ lookupInstalledModuleEnv moduleLocs installedMod file = case ifr of InstalledFound loc _ -> fromJust $ ml_hs_file loc @@ -366,8 +375,8 @@ -- We shouldn't get boot files here, but to be safe, never map them to an installed module -- because boot files don't have linkables we can load, and we will fail if we try to look -- for them - nodeKeyToInstalledModule (NodeKey_Module (ModNodeKeyWithUid (GWIB mod IsBoot) uid)) = Nothing - nodeKeyToInstalledModule (NodeKey_Module (ModNodeKeyWithUid (GWIB mod _) uid)) = Just $ mkModule uid mod + nodeKeyToInstalledModule (NodeKey_Module (ModNodeKeyWithUid (GWIB _ IsBoot) _)) = Nothing + nodeKeyToInstalledModule (NodeKey_Module (ModNodeKeyWithUid (GWIB moduleName _) uid)) = Just $ mkModule uid moduleName nodeKeyToInstalledModule _ = Nothing moduleToNodeKey :: Module -> NodeKey moduleToNodeKey mod = NodeKey_Module $ ModNodeKeyWithUid (GWIB (moduleName mod) NotBoot) (moduleUnitId mod) @@ -434,8 +443,8 @@ hsc_env_tmp = hscSetFlags (ms_hspp_opts ms) hsc_env ((tc_gbl_env', mrn_info), splices, mod_env) - <- captureSplicesAndDeps tc_helpers hsc_env_tmp $ \hsc_env_tmp -> - do hscTypecheckRename hsc_env_tmp ms $ + <- captureSplicesAndDeps tc_helpers hsc_env_tmp $ \hscEnvTmp -> + do hscTypecheckRename hscEnvTmp ms $ HsParsedModule { hpm_module = parsedSource pmod, hpm_src_files = pm_extra_src_files pmod, hpm_annotations = pm_annotations pmod } @@ -508,7 +517,6 @@ mkHiFileResultCompile se session' tcm simplified_guts = catchErrs $ do let session = hscSetFlags (ms_hspp_opts ms) session' ms = pm_mod_summary $ tmrParsed tcm - tcGblEnv = tmrTypechecked tcm (details, guts) <- do -- write core file @@ -553,9 +561,9 @@ -- The serialized file however is much more compact and only requires a few -- hundred megabytes of memory total even in a large project with 1000s of -- modules - (core_file, !core_hash2) <- readBinCoreFile (mkUpdater $ hsc_NC session) core_fp + (coreFile, !core_hash2) <- readBinCoreFile (mkUpdater $ hsc_NC session) core_fp pure $ assert (core_hash1 == core_hash2) - $ Just (core_file, fingerprintToBS core_hash2) + $ Just (coreFile, fingerprintToBS core_hash2) -- Verify core file by roundtrip testing and comparison IdeOptions{optVerifyCoreFile} <- getIdeOptionsIO se @@ -594,8 +602,8 @@ (prepd_binds', _) #endif <- corePrep unprep_binds' data_tycons - let binds = noUnfoldings $ (map flattenBinds . (:[])) $ prepd_binds - binds' = noUnfoldings $ (map flattenBinds . (:[])) $ prepd_binds' + let binds = noUnfoldings $ (map flattenBinds . (:[])) prepd_binds + binds' = noUnfoldings $ (map flattenBinds . (:[])) prepd_binds' -- diffBinds is unreliable, sometimes it goes down the wrong track. -- This fixes the order of the bindings so that it is less likely to do so. @@ -849,9 +857,9 @@ where dflags = hsc_dflags hscEnv #if MIN_VERSION_ghc(9,0,0) - run ts = + run _ts = -- ts is only used in GHC 9.2 #if MIN_VERSION_ghc(9,2,0) && !MIN_VERSION_ghc(9,3,0) - fmap (join . snd) . liftIO . initDs hscEnv ts + fmap (join . snd) . liftIO . initDs hscEnv _ts #else id #endif @@ -910,8 +918,8 @@ -- We are now in the worker thread -- Check if a newer index of this file has been scheduled, and if so skip this one newerScheduled <- atomically $ do - pending <- readTVar indexPending - pure $ case HashMap.lookup srcPath pending of + pendingOps <- readTVar indexPending + pure $ case HashMap.lookup srcPath pendingOps of Nothing -> False -- If the hash in the pending list doesn't match the current hash, then skip Just pendingHash -> pendingHash /= hash @@ -957,8 +965,8 @@ progressPct :: LSP.UInt progressPct = floor $ 100 * progressFrac - whenJust (lspEnv se) $ \env -> whenJust tok $ \tok -> LSP.runLspT env $ - LSP.sendNotification LSP.SMethod_Progress $ LSP.ProgressParams tok $ + whenJust (lspEnv se) $ \env -> whenJust tok $ \token -> LSP.runLspT env $ + LSP.sendNotification LSP.SMethod_Progress $ LSP.ProgressParams token $ toJSON $ case style of Percentage -> LSP.WorkDoneProgressReport @@ -998,8 +1006,8 @@ whenJust mdone $ \done -> modifyVar_ indexProgressToken $ \tok -> do whenJust (lspEnv se) $ \env -> LSP.runLspT env $ - whenJust tok $ \tok -> - LSP.sendNotification LSP.SMethod_Progress $ LSP.ProgressParams tok $ + whenJust tok $ \token -> + LSP.sendNotification LSP.SMethod_Progress $ LSP.ProgressParams token $ toJSON $ LSP.WorkDoneProgressEnd { _kind = LSP.AString @"end" @@ -1079,7 +1087,7 @@ -- Prefer non-boot files over non-boot files -- otherwise we can get errors like https://gitlab.haskell.org/ghc/ghc/-/issues/19816 -- if a boot file shadows over a non-boot file - combineModuleLocations a@(InstalledFound ml m) b | Just fp <- ml_hs_file ml, not ("boot" `isSuffixOf` fp) = a + combineModuleLocations a@(InstalledFound ml _) _ | Just fp <- ml_hs_file ml, not ("boot" `isSuffixOf` fp) = a combineModuleLocations _ b = b concatFC :: FinderCacheState -> [FinderCache] -> IO FinderCache @@ -1128,11 +1136,12 @@ -> UTCTime -> Maybe Util.StringBuffer -> ExceptT [FileDiagnostic] IO ModSummaryResult -getModSummaryFromImports env fp modTime contents = do - - (contents, opts, env, src_hash) <- preprocessor env fp contents +-- modTime is only used in GHC < 9.4 +getModSummaryFromImports env fp _modTime mContents = do +-- src_hash is only used in GHC >= 9.4 + (contents, opts, ppEnv, _src_hash) <- preprocessor env fp mContents - let dflags = hsc_dflags env + let dflags = hsc_dflags ppEnv -- The warns will hopefully be reported when we actually parse the module (_warns, L main_loc hsmod) <- parseHeader dflags fp contents @@ -1146,7 +1155,8 @@ (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource.unLoc) imps -- GHC.Prim doesn't exist physically, so don't go looking for it. - (ordinary_imps, ghc_prim_imports) + -- ghc_prim_imports is only used in GHC >= 9.4 + (ordinary_imps, _ghc_prim_imports) = partition ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc) ord_idecls @@ -1166,11 +1176,11 @@ msrImports = implicit_imports ++ imps #if MIN_VERSION_ghc (9,3,0) - rn_pkg_qual = renameRawPkgQual (hsc_unit_env env) + rn_pkg_qual = renameRawPkgQual (hsc_unit_env ppEnv) rn_imps = fmap (\(pk, lmn@(L _ mn)) -> (rn_pkg_qual mn pk, lmn)) srcImports = rn_imps $ map convImport src_idecls textualImports = rn_imps $ map convImport (implicit_imports ++ ordinary_imps) - ghc_prim_import = not (null ghc_prim_imports) + ghc_prim_import = not (null _ghc_prim_imports) #else srcImports = map convImport src_idecls textualImports = map convImport (implicit_imports ++ ordinary_imps) @@ -1188,7 +1198,7 @@ then mkHomeModLocation dflags (pathToModuleName fp) fp else mkHomeModLocation dflags mod fp - let modl = mkHomeModule (hscHomeUnit env) mod + let modl = mkHomeModule (hscHomeUnit ppEnv) mod sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile msrModSummary2 = ModSummary @@ -1197,10 +1207,10 @@ #if MIN_VERSION_ghc(9,3,0) , ms_dyn_obj_date = Nothing , ms_ghc_prim_import = ghc_prim_import - , ms_hs_hash = src_hash + , ms_hs_hash = _src_hash #else - , ms_hs_date = modTime + , ms_hs_date = _modTime #endif , ms_hsc_src = sourceType -- The contents are used by the GetModSummary rule @@ -1216,7 +1226,7 @@ } msrFingerprint <- liftIO $ computeFingerprint opts msrModSummary2 - (msrModSummary, msrHscEnv) <- liftIO $ initPlugins env msrModSummary2 + (msrModSummary, msrHscEnv) <- liftIO $ initPlugins ppEnv msrModSummary2 return ModSummaryResult{..} where -- Compute a fingerprint from the contents of `ModSummary`, @@ -1304,7 +1314,7 @@ let preproc_warnings = diagFromStrings sourceParser DiagnosticSeverity_Warning preproc_warns (parsed', msgs) <- liftIO $ applyPluginsParsedResultAction env dflags ms hpm_annotations parsed psMessages - let (warns, errs) = renderMessages msgs + let (warns, errors) = renderMessages msgs -- Just because we got a `POk`, it doesn't mean there -- weren't errors! To clarify, the GHC parser @@ -1315,8 +1325,8 @@ -- further errors/warnings can be collected). Fatal -- errors are those from which a parse tree just can't -- be produced. - unless (null errs) $ - throwE $ diagFromErrMsgs sourceParser dflags errs + unless (null errors) $ + throwE $ diagFromErrMsgs sourceParser dflags errors -- To get the list of extra source files, we take the list @@ -1468,19 +1478,21 @@ -- The source is modified if it is newer than the destination (iface file) -- A more precise check for the core file is performed later - let sourceMod = case mb_dest_version of + let _sourceMod = case mb_dest_version of -- sourceMod is only used in GHC < 9.4 Nothing -> SourceModified -- destination file doesn't exist, assume modified source Just dest_version | source_version <= dest_version -> SourceUnmodified | otherwise -> SourceModified - old_iface <- case mb_old_iface of + -- old_iface is only used in GHC >= 9.4 + _old_iface <- case mb_old_iface of Just iface -> pure (Just iface) Nothing -> do - let ncu = hsc_NC sessionWithMsDynFlags - read_dflags = hsc_dflags sessionWithMsDynFlags + -- ncu and read_dflags are only used in GHC >= 9.4 + let _ncu = hsc_NC sessionWithMsDynFlags + _read_dflags = hsc_dflags sessionWithMsDynFlags #if MIN_VERSION_ghc(9,3,0) - read_result <- liftIO $ readIface read_dflags ncu mod iface_file + read_result <- liftIO $ readIface _read_dflags _ncu mod iface_file #else read_result <- liftIO $ initIfaceCheck (text "readIface") sessionWithMsDynFlags $ readIface mod iface_file @@ -1495,11 +1507,11 @@ -- given that the source is unmodified (recomp_iface_reqd, mb_checked_iface) #if MIN_VERSION_ghc(9,3,0) - <- liftIO $ checkOldIface sessionWithMsDynFlags ms old_iface >>= \case + <- liftIO $ checkOldIface sessionWithMsDynFlags ms _old_iface >>= \case UpToDateItem x -> pure (UpToDate, Just x) OutOfDateItem reason x -> pure (NeedsRecompile reason, x) #else - <- liftIO $ checkOldIface sessionWithMsDynFlags ms sourceMod mb_old_iface + <- liftIO $ checkOldIface sessionWithMsDynFlags ms _sourceMod mb_old_iface #endif let do_regenerate _reason = withTrace "regenerate interface" $ \setTag -> do @@ -1521,10 +1533,10 @@ Just msg -> do_regenerate msg Nothing | isJust linkableNeeded -> handleErrs $ do - (core_file@CoreFile{cf_iface_hash}, core_hash) <- liftIO $ + (coreFile@CoreFile{cf_iface_hash}, core_hash) <- liftIO $ readBinCoreFile (mkUpdater $ hsc_NC session) core_file if cf_iface_hash == getModuleHash iface - then return ([], Just $ mkHiFileResult ms iface details runtime_deps (Just (core_file, fingerprintToBS core_hash))) + then return ([], Just $ mkHiFileResult ms iface details runtime_deps (Just (coreFile, fingerprintToBS core_hash))) else do_regenerate (recompBecause "Core file out of date (doesn't match iface hash)") | otherwise -> return ([], Just $ mkHiFileResult ms iface details runtime_deps Nothing) where handleErrs = flip catches @@ -1578,6 +1590,7 @@ _ -> pure $ Just $ recompBecause $ "out of date runtime dependencies: " ++ intercalate ", " (map show out_of_date) +recompBecause :: String -> RecompileRequired recompBecause = #if MIN_VERSION_ghc(9,3,0) NeedsRecompile . @@ -1622,15 +1635,15 @@ }) core_binds <- initIfaceCheck (text "l") hsc_env' $ typecheckCoreFile this_mod types_var core_file -- Implicit binds aren't saved, so we need to regenerate them ourselves. - let implicit_binds = concatMap getImplicitBinds tyCons + let _implicit_binds = concatMap getImplicitBinds tyCons -- only used if GHC < 9.6 tyCons = typeEnvTyCons (md_types details) #if MIN_VERSION_ghc(9,5,0) -- In GHC 9.6, the implicit binds are tidied and part of core_binds pure $ CgGuts this_mod tyCons core_binds [] NoStubs [] mempty (emptyHpcInfo False) Nothing [] #elif MIN_VERSION_ghc(9,3,0) - pure $ CgGuts this_mod tyCons (implicit_binds ++ core_binds) [] NoStubs [] mempty (emptyHpcInfo False) Nothing [] + pure $ CgGuts this_mod tyCons (_implicit_binds ++ core_binds) [] NoStubs [] mempty (emptyHpcInfo False) Nothing [] #else - pure $ CgGuts this_mod tyCons (implicit_binds ++ core_binds) NoStubs [] [] (emptyHpcInfo False) Nothing [] + pure $ CgGuts this_mod tyCons (_implicit_binds ++ core_binds) NoStubs [] [] (emptyHpcInfo False) Nothing [] #endif coreFileToLinkable :: LinkableType -> HscEnv -> ModSummary -> ModIface -> ModDetails -> CoreFile -> UTCTime -> IO ([FileDiagnostic], Maybe HomeModInfo) @@ -1689,8 +1702,7 @@ #else Map.findWithDefault mempty name amap)) #endif - return $ map (first $ T.unpack . printOutputable) - $ res + return $ map (first $ T.unpack . printOutputable) res where compiled n = -- TODO: Find a more direct indicator. @@ -1706,7 +1718,7 @@ -> IO (Maybe TyThing) lookupName _ name | Nothing <- nameModule_maybe name = pure Nothing -lookupName hsc_env name = handle $ do +lookupName hsc_env name = exceptionHandle $ do #if MIN_VERSION_ghc(9,2,0) mb_thing <- liftIO $ lookupType hsc_env name #else @@ -1726,7 +1738,7 @@ Util.Succeeded x -> return (Just x) _ -> return Nothing where - handle x = x `catch` \(_ :: IOEnvFailure) -> pure Nothing + exceptionHandle x = x `catch` \(_ :: IOEnvFailure) -> pure Nothing pathToModuleName :: FilePath -> ModuleName pathToModuleName = mkModuleName . map rep @@ -1734,3 +1746,32 @@ rep c | isPathSeparator c = '_' rep ':' = '_' rep c = c + +{- Note [Guidelines For Using CPP In GHCIDE Import Statements] + GHCIDE's interface with GHC is extensive, and unfortunately, because we have + to work with multiple versions of GHC, we have several files that need to use + a lot of CPP. In order to simplify the CPP in the import section of every file + we have a few specific guidelines for using CPP in these sections. + + - We don't want to nest CPP clauses, nor do we want to use else clauses. Both + nesting and else clauses end up drastically complicating the code, and require + significant mental stack to unwind. + + - CPP clauses should be placed at the end of the imports section. The clauses + should be ordered by the GHC version they target from earlier to later versions, + with negative if clauses coming before positive if clauses of the same + version. (If you think about which GHC version a clause activates for this + should make sense `!MIN_VERSION_GHC(9,0,0)` refers to 8.10 and lower which is + a earlier version than `MIN_VERSION_GHC(9,0,0)` which refers to versions 9.0 + and later). In addition there should be a space before and after each CPP + clause. + + - In if clauses that use `&&` and depend on more than one statement, the + positive statement should come before the negative statement. In addition the + clause should come after the single positive clause for that GHC version. + + - There shouldn't be multiple identical CPP statements. The use of odd or even + GHC numbers is identical, with the only preference being to use what is + already there. (i.e. (`MIN_VERSION_GHC(9,2,0)` and `MIN_VERSION_GHC(9,1,0)` + are functionally equivalent) +-} diff --git a/src/Development/IDE/Core/FileExists.hs b/src/Development/IDE/Core/FileExists.hs --- a/src/Development/IDE/Core/FileExists.hs +++ b/src/Development/IDE/Core/FileExists.hs @@ -95,8 +95,8 @@ instance Pretty Log where pretty = \case - LogFileStore log -> pretty log - LogShake log -> pretty log + LogFileStore msg -> pretty msg + LogShake msg -> pretty msg -- | Grab the current global value of 'FileExistsMap' without acquiring a dependency getFileExistsMapUntracked :: Action FileExistsMap diff --git a/src/Development/IDE/Core/FileStore.hs b/src/Development/IDE/Core/FileStore.hs --- a/src/Development/IDE/Core/FileStore.hs +++ b/src/Development/IDE/Core/FileStore.hs @@ -1,6 +1,5 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} module Development.IDE.Core.FileStore( @@ -28,16 +27,22 @@ import Control.Exception import Control.Monad.Extra import Control.Monad.IO.Class +import qualified Data.Binary as B import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS import qualified Data.HashMap.Strict as HashMap import Data.IORef +import Data.List (foldl') import qualified Data.Text as T +import qualified Data.Text as Text import qualified Data.Text.Utf16.Rope as Rope import Data.Time import Data.Time.Clock.POSIX import Development.IDE.Core.FileUtils +import Development.IDE.Core.IdeConfiguration (isWorkspaceFile) import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake hiding (Log) +import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Orphans () import Development.IDE.Graph import Development.IDE.Import.DependencyInformation @@ -45,24 +50,6 @@ import Development.IDE.Types.Location import Development.IDE.Types.Options import HieDb.Create (deleteMissingRealFiles) -import Ide.Plugin.Config (CheckParents (..), - Config) -import System.IO.Error - -#ifdef mingw32_HOST_OS -import qualified System.Directory as Dir -#else -#endif - -import qualified Ide.Logger as L - -import Data.Aeson (ToJSON (toJSON)) -import qualified Data.Binary as B -import qualified Data.ByteString.Lazy as LBS -import Data.List (foldl') -import qualified Data.Text as Text -import Development.IDE.Core.IdeConfiguration (isWorkspaceFile) -import qualified Development.IDE.Core.Shake as Shake import Ide.Logger (Pretty (pretty), Priority (Info), Recorder, @@ -70,6 +57,9 @@ cmapWithPrio, logWith, viaShow, (<+>)) +import qualified Ide.Logger as L +import Ide.Plugin.Config (CheckParents (..), + Config) import Language.LSP.Protocol.Message (toUntypedRegistration) import qualified Language.LSP.Protocol.Message as LSP import Language.LSP.Protocol.Types (DidChangeWatchedFilesRegistrationOptions (DidChangeWatchedFilesRegistrationOptions), @@ -79,8 +69,10 @@ import qualified Language.LSP.Server as LSP import Language.LSP.VFS import System.FilePath +import System.IO.Error import System.IO.Unsafe + data Log = LogCouldNotIdentifyReverseDeps !NormalizedFilePath | LogTypeCheckingReverseDeps !NormalizedFilePath !(Maybe [NormalizedFilePath]) @@ -96,7 +88,7 @@ <+> viaShow path <> ":" <+> pretty (fmap (fmap show) reverseDepPaths) - LogShake log -> pretty log + LogShake msg -> pretty msg addWatchedFileRule :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> Rules () addWatchedFileRule recorder isWatched = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \AddWatchedFile f -> do @@ -243,11 +235,10 @@ typecheckParentsAction :: Recorder (WithPriority Log) -> NormalizedFilePath -> Action () typecheckParentsAction recorder nfp = do revs <- transitiveReverseDependencies nfp <$> useNoFile_ GetModuleGraph - let log = logWith recorder case revs of - Nothing -> log Info $ LogCouldNotIdentifyReverseDeps nfp + Nothing -> logWith recorder Info $ LogCouldNotIdentifyReverseDeps nfp Just rs -> do - log Info $ LogTypeCheckingReverseDeps nfp revs + logWith recorder Info $ LogTypeCheckingReverseDeps nfp revs void $ uses GetModIface rs -- | Note that some keys have been modified and restart the session diff --git a/src/Development/IDE/Core/FileUtils.hs b/src/Development/IDE/Core/FileUtils.hs --- a/src/Development/IDE/Core/FileUtils.hs +++ b/src/Development/IDE/Core/FileUtils.hs @@ -6,6 +6,7 @@ import Data.Time.Clock.POSIX + #ifdef mingw32_HOST_OS import qualified System.Directory as Dir #else diff --git a/src/Development/IDE/Core/IdeConfiguration.hs b/src/Development/IDE/Core/IdeConfiguration.hs --- a/src/Development/IDE/Core/IdeConfiguration.hs +++ b/src/Development/IDE/Core/IdeConfiguration.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DuplicateRecordFields #-} module Development.IDE.Core.IdeConfiguration ( IdeConfiguration(..) , registerIdeConfiguration @@ -13,13 +12,13 @@ where import Control.Concurrent.Strict -import Control.Lens ((^.)) + import Control.Monad import Control.Monad.IO.Class import Data.Aeson.Types (Value) import Data.Hashable (Hashed, hashed, unhashed) import Data.HashSet (HashSet, singleton) -import Data.Text (Text, isPrefixOf) +import Data.Text (isPrefixOf) import Development.IDE.Core.Shake import Development.IDE.Graph import Development.IDE.Types.Location diff --git a/src/Development/IDE/Core/OfInterest.hs b/src/Development/IDE/Core/OfInterest.hs --- a/src/Development/IDE/Core/OfInterest.hs +++ b/src/Development/IDE/Core/OfInterest.hs @@ -55,7 +55,7 @@ instance Pretty Log where pretty = \case - LogShake log -> pretty log + LogShake msg -> pretty msg newtype OfInterestVar = OfInterestVar (Var (HashMap NormalizedFilePath FileOfInterestStatus)) diff --git a/src/Development/IDE/Core/PluginUtils.hs b/src/Development/IDE/Core/PluginUtils.hs --- a/src/Development/IDE/Core/PluginUtils.hs +++ b/src/Development/IDE/Core/PluginUtils.hs @@ -1,5 +1,29 @@ {-# LANGUAGE GADTs #-} -module Development.IDE.Core.PluginUtils where +module Development.IDE.Core.PluginUtils +(-- Wrapped Action functions + runActionE +, runActionMT +, useE +, useMT +, usesE +, usesMT +, useWithStaleE +, useWithStaleMT +-- Wrapped IdeAction functions +, runIdeActionE +, runIdeActionMT +, useWithStaleFastE +, useWithStaleFastMT +, uriToFilePathE +-- Wrapped PositionMapping functions +, toCurrentPositionE +, toCurrentPositionMT +, fromCurrentPositionE +, fromCurrentPositionMT +, toCurrentRangeE +, toCurrentRangeMT +, fromCurrentRangeE +, fromCurrentRangeMT) where import Control.Monad.Extra import Control.Monad.IO.Class diff --git a/src/Development/IDE/Core/PositionMapping.hs b/src/Development/IDE/Core/PositionMapping.hs --- a/src/Development/IDE/Core/PositionMapping.hs +++ b/src/Development/IDE/Core/PositionMapping.hs @@ -104,7 +104,7 @@ zeroMapping = PositionMapping idDelta -- | Compose two position mappings. Composes in the same way as function --- composition (ie the second argument is applyed to the position first). +-- composition (ie the second argument is applied to the position first). composeDelta :: PositionDelta -> PositionDelta -> PositionDelta @@ -219,9 +219,9 @@ line' -> PositionExact (Position (fromIntegral line') col) -- Construct a mapping between lines in the diff - -- -1 for unsucessful mapping + -- -1 for unsuccessful mapping go :: [Diff T.Text] -> Int -> Int -> ([Int], [Int]) go [] _ _ = ([],[]) - go (Both _ _ : xs) !lold !lnew = bimap (lnew :) (lold :) $ go xs (lold+1) (lnew+1) - go (First _ : xs) !lold !lnew = first (-1 :) $ go xs (lold+1) lnew - go (Second _ : xs) !lold !lnew = second (-1 :) $ go xs lold (lnew+1) + go (Both _ _ : xs) !glold !glnew = bimap (glnew :) (glold :) $ go xs (glold+1) (glnew+1) + go (First _ : xs) !glold !glnew = first (-1 :) $ go xs (glold+1) glnew + go (Second _ : xs) !glold !glnew = second (-1 :) $ go xs glold (glnew+1) 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 @@ -30,9 +30,11 @@ import qualified GHC.LanguageExtensions as LangExt import System.FilePath import System.IO.Extra + +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] + #if MIN_VERSION_ghc(9,3,0) import GHC.Utils.Logger (LogFlags (..)) -import GHC.Utils.Outputable (renderWithContext) #endif -- | Given a file and some contents, apply any necessary preprocessors, @@ -54,17 +56,17 @@ !src_hash <- liftIO $ Util.fingerprintFromStringBuffer contents -- Perform cpp - (opts, env) <- ExceptT $ parsePragmasIntoHscEnv env filename contents - let dflags = hsc_dflags env - let logger = hsc_logger env - (isOnDisk, contents, opts, env) <- + (opts, pEnv) <- ExceptT $ parsePragmasIntoHscEnv env filename contents + let dflags = hsc_dflags pEnv + let logger = hsc_logger pEnv + (newIsOnDisk, newContents, newOpts, newEnv) <- if not $ xopt LangExt.Cpp dflags then - return (isOnDisk, contents, opts, env) + return (isOnDisk, contents, opts, pEnv) else do cppLogs <- liftIO $ newIORef [] let newLogger = pushLogHook (const (logActionCompat $ logAction cppLogs)) logger - contents <- ExceptT - $ (Right <$> (runCpp (putLogHook newLogger env) filename + con <- ExceptT + $ (Right <$> (runCpp (putLogHook newLogger pEnv) filename $ if isOnDisk then Nothing else Just contents)) `catch` ( \(e :: Util.GhcException) -> do @@ -73,25 +75,25 @@ [] -> throw e diags -> return $ Left diags ) - (opts, env) <- ExceptT $ parsePragmasIntoHscEnv env filename contents - return (False, contents, opts, env) + (options, hscEnv) <- ExceptT $ parsePragmasIntoHscEnv pEnv filename con + return (False, con, options, hscEnv) -- Perform preprocessor if not $ gopt Opt_Pp dflags then - return (contents, opts, env, src_hash) + return (newContents, newOpts, newEnv, src_hash) else do - contents <- liftIO $ runPreprocessor env filename $ if isOnDisk then Nothing else Just contents - (opts, env) <- ExceptT $ parsePragmasIntoHscEnv env filename contents - return (contents, opts, env, src_hash) + con <- liftIO $ runPreprocessor newEnv filename $ if newIsOnDisk then Nothing else Just newContents + (options, hscEnv) <- ExceptT $ parsePragmasIntoHscEnv newEnv filename con + return (con, options, hscEnv, src_hash) where logAction :: IORef [CPPLog] -> LogActionCompat logAction cppLogs dflags _reason severity srcSpan _style msg = do #if MIN_VERSION_ghc(9,3,0) - let log = CPPLog (fromMaybe SevWarning severity) srcSpan $ T.pack $ renderWithContext (log_default_user_context dflags) msg + let cppLog = CPPLog (fromMaybe SevWarning severity) srcSpan $ T.pack $ renderWithContext (log_default_user_context dflags) msg #else - let log = CPPLog severity srcSpan $ T.pack $ showSDoc dflags msg + let cppLog = CPPLog severity srcSpan $ T.pack $ showSDoc dflags msg #endif - modifyIORef cppLogs (log :) + modifyIORef cppLogs (cppLog :) @@ -118,12 +120,12 @@ -- 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) = - let diag = CPPDiag (realSrcSpanToRange span) (toDSeverity sev) [msg] - in go (diag : acc) logs - go (diag : diags) (CPPLog _sev (UnhelpfulSpan _) msg : logs) = - go (diag {cdMessage = msg : cdMessage diag} : diags) logs - go [] (CPPLog _sev (UnhelpfulSpan _) _msg : logs) = go [] logs + go acc (CPPLog sev (RealSrcSpan rSpan _) msg : gLogs) = + let diag = CPPDiag (realSrcSpanToRange rSpan) (toDSeverity sev) [msg] + in go (diag : acc) gLogs + go (diag : diags) (CPPLog _sev (UnhelpfulSpan _) msg : gLogs) = + go (diag {cdMessage = msg : cdMessage diag} : diags) gLogs + go [] (CPPLog _sev (UnhelpfulSpan _) _msg : gLogs) = go [] gLogs cppDiagToDiagnostic :: CPPDiag -> Diagnostic cppDiagToDiagnostic d = Diagnostic @@ -196,12 +198,12 @@ -- | Run CPP on a file runCpp :: HscEnv -> FilePath -> Maybe Util.StringBuffer -> IO Util.StringBuffer -runCpp env0 filename contents = withTempDir $ \dir -> do +runCpp env0 filename mbContents = withTempDir $ \dir -> do let out = dir takeFileName filename <.> "out" let dflags1 = addOptP "-D__GHCIDE__" (hsc_dflags env0) let env1 = hscSetFlags dflags1 env0 - case contents of + case mbContents 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 @@ -225,21 +227,21 @@ -- Fix up the filename in lines like: -- # 1 "C:/Temp/extra-dir-914611385186/___GHCIDE_MAGIC___" let tweak x - | Just x <- stripPrefix "# " x - , "___GHCIDE_MAGIC___" `isInfixOf` x - , let num = takeWhile (not . isSpace) x + | Just y <- stripPrefix "# " x + , "___GHCIDE_MAGIC___" `isInfixOf` y + , let num = takeWhile (not . isSpace) y -- important to use /, and never \ for paths, even on Windows, since then C escapes them -- and GHC gets all confused - = "# " <> num <> " \"" <> map (\x -> if isPathSeparator x then '/' else x) filename <> "\"" + = "# " <> num <> " \"" <> map (\z -> if isPathSeparator z then '/' else z) filename <> "\"" | otherwise = x Util.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 env filename mbContents = withTempDir $ \dir -> do let out = dir takeFileName filename <.> "out" - inp <- case contents of + inp <- case mbContents of Nothing -> return filename Just contents -> do let inp = dir takeFileName filename <.> "hs" diff --git a/src/Development/IDE/Core/ProgressReporting.hs b/src/Development/IDE/Core/ProgressReporting.hs --- a/src/Development/IDE/Core/ProgressReporting.hs +++ b/src/Development/IDE/Core/ProgressReporting.hs @@ -18,7 +18,7 @@ modifyTVar', newTVarIO, readTVarIO) import Control.Concurrent.Strict -import Control.Monad.Extra +import Control.Monad.Extra hiding (loop) import Control.Monad.IO.Class import Control.Monad.Trans.Class (lift) import Data.Aeson (ToJSON (toJSON)) @@ -112,7 +112,7 @@ -> Maybe (LSP.LanguageContextEnv c) -> ProgressReportingStyle -> IO ProgressReporting -delayedProgressReporting before after Nothing optProgressStyle = noProgressReporting +delayedProgressReporting _before _after Nothing _optProgressStyle = noProgressReporting delayedProgressReporting before after (Just lspEnv) optProgressStyle = do inProgressState <- newInProgress progressState <- newVar NotStarted @@ -136,9 +136,9 @@ ready <- waitBarrier b LSP.runLspT lspEnv $ for_ ready $ const $ bracket_ (start u) (stop u) (loop u 0) where - start id = LSP.sendNotification SMethod_Progress $ + start token = LSP.sendNotification SMethod_Progress $ LSP.ProgressParams - { _token = id + { _token = token , _value = toJSON $ WorkDoneProgressBegin { _kind = AString @"begin" , _title = "Processing" @@ -147,9 +147,9 @@ , _percentage = Nothing } } - stop id = LSP.sendNotification SMethod_Progress + stop token = LSP.sendNotification SMethod_Progress LSP.ProgressParams - { _token = id + { _token = token , _value = toJSON $ WorkDoneProgressEnd { _kind = AString @"end" , _message = Nothing @@ -157,11 +157,11 @@ } loop _ _ | optProgressStyle == NoProgress = forever $ liftIO $ threadDelay maxBound - loop id prevPct = do + loop token prevPct = do done <- liftIO $ readTVarIO doneVar todo <- liftIO $ readTVarIO todoVar liftIO $ sleep after - if todo == 0 then loop id 0 else do + if todo == 0 then loop token 0 else do let nextFrac :: Double nextFrac = fromIntegral done / fromIntegral todo @@ -170,7 +170,7 @@ when (nextPct /= prevPct) $ LSP.sendNotification SMethod_Progress $ LSP.ProgressParams - { _token = id + { _token = token , _value = case optProgressStyle of Explicit -> toJSON $ WorkDoneProgressReport { _kind = AString @"report" @@ -186,7 +186,7 @@ } NoProgress -> error "unreachable" } - loop id nextPct + loop token nextPct updateStateForFile inProgress file = actionBracket (f succ) (const $ f pred) . const -- This functions are deliberately eta-expanded to avoid space leaks. 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 @@ -475,7 +475,8 @@ instance Hashable GetModSummary instance NFData GetModSummary --- | Get the vscode client settings stored in the ide state +-- See Note [Client configuration in Rules] +-- | Get the client config stored in the ide state data GetClientSettings = GetClientSettings deriving (Eq, Show, Typeable, Generic) instance Hashable GetClientSettings @@ -510,3 +511,33 @@ makeLensesWith (lensRules & lensField .~ mappingNamer (pure . (++ "L"))) ''Splices + +{- Note [Client configuration in Rules] +The LSP client configuration is stored by `lsp` for us, and is accesible in +handlers through the LspT monad. + +This is all well and good, but what if we want to write a Rule that depends +on the configuration? For example, we might have a plugin that provides +diagnostics - if the configuration changes to turn off that plugin, then +we need to invalidate the Rule producing the diagnostics so that they go +away. More broadly, any time we define a Rule that really depends on the +configuration, such that the dependency needs to be tracked and the Rule +invalidated when the configuration changes, we have a problem. + +The solution is that we have to mirror the configuration into the state +that our build system knows about. That means that: +- We have a parallel record of the state in 'IdeConfiguration' +- We install a callback so that when the config changes we can update the +'IdeConfiguration' and mark the rule as dirty. + +Then we can define a Rule that gets the configuration, and build Actions +on top of that that behave properly. However, these should really only +be used if you need the dependency tracking - for normal usage in handlers +the config can simply be accessed directly from LspT. + +TODO(michaelpj): this is me writing down what I think the logic is, but +it doesn't make much sense to me. In particular, we *can* get the LspT +in an Action. So I don't know why we need to store it twice. We would +still need to invalidate the Rule otherwise we won't know it's changed, +though. See https://github.com/haskell/ghcide/pull/731 for some context. +-} 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 @@ -61,26 +61,25 @@ DisplayTHWarning(..), ) where +import Prelude hiding (mod) import Control.Applicative import Control.Concurrent.Async (concurrently) import Control.Concurrent.Strict import Control.DeepSeq import Control.Exception.Safe import Control.Exception (evaluate) -import Control.Monad.Extra -import Control.Monad.Reader -import Control.Monad.State +import Control.Monad.Extra hiding (msum) +import Control.Monad.Reader hiding (msum) +import Control.Monad.State hiding (msum) import Control.Monad.Trans.Except (ExceptT, except, runExceptT) import Control.Monad.Trans.Maybe -import Data.Aeson (Result (Success), - toJSON) -import qualified Data.Aeson.Types as A +import Data.Aeson (toJSON) import qualified Data.Binary as B import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import Data.Coerce -import Data.Foldable +import Data.Foldable hiding (msum) import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HashSet import Data.Hashable @@ -116,7 +115,7 @@ TargetId(..), loadInterface, Var, - (<+>)) + (<+>), settings) import qualified Development.IDE.GHC.Compat as Compat hiding (vcat, nest) import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.GHC.Error @@ -146,9 +145,8 @@ Properties, ToHsType, useProperty) -import Ide.PluginUtils (configForPlugin) import Ide.Types (DynFlagsModifications (dynFlagsModifyGlobal, dynFlagsModifyParser), - PluginId, PluginDescriptor (pluginId), IdePlugins (IdePlugins)) + PluginId) import Control.Concurrent.STM.Stats (atomically) import Language.LSP.Server (LspT) import System.Info.Extra (isWindows) @@ -157,20 +155,24 @@ import qualified Development.IDE.Core.Shake as Shake import qualified Ide.Logger as Logger import qualified Development.IDE.Types.Shake as Shake -import Development.IDE.GHC.CoreFile import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Control.Monad.IO.Unlift -import qualified Data.IntMap as IM -#if MIN_VERSION_ghc(9,3,0) -import GHC.Unit.Module.Graph -import GHC.Unit.Env + + +import GHC.Fingerprint + +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] + +#if !MIN_VERSION_ghc(9,3,0) +import GHC (mgModSummaries) #endif -#if MIN_VERSION_ghc(9,5,0) -import GHC.Unit.Home.ModInfo + +#if MIN_VERSION_ghc(9,3,0) +import qualified Data.IntMap as IM #endif -import GHC (mgModSummaries) -import GHC.Fingerprint + + data Log = LogShake Shake.Log | LogReindexingHieFile !NormalizedFilePath @@ -182,7 +184,7 @@ instance Pretty Log where pretty = \case - LogShake log -> pretty log + LogShake msg -> pretty msg LogReindexingHieFile path -> "Re-indexing hie file for" <+> pretty (fromNormalizedFilePath path) LogLoadingHieFile path -> @@ -334,10 +336,10 @@ let ms' = withoutOption Opt_Haddock $ withOption Opt_KeepRawTokenStream ms modify_dflags <- getModifyDynFlags dynFlagsModifyParser - let ms = ms' { ms_hspp_opts = modify_dflags $ ms_hspp_opts ms' } + let ms'' = ms' { ms_hspp_opts = modify_dflags $ ms_hspp_opts ms' } reset_ms pm = pm { pm_mod_summary = ms' } - liftIO $ fmap (fmap reset_ms) $ snd <$> getParsedModuleDefinition hsc opt file ms + liftIO $ fmap (fmap reset_ms) $ snd <$> getParsedModuleDefinition hsc opt file ms'' getModifyDynFlags :: (DynFlagsModifications -> a) -> Action a getModifyDynFlags f = do @@ -370,7 +372,7 @@ let import_dirs = deps env_eq let dflags = hsc_dflags env isImplicitCradle = isNothing $ envImportPaths env_eq - dflags <- return $ if isImplicitCradle + dflags' <- return $ if isImplicitCradle then addRelativeImport file (moduleName $ ms_mod ms) dflags else dflags opt <- getIdeOptions @@ -391,7 +393,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 (hscSetFlags dflags' env) import_dirs (optExtensions opt) getTargetFor modName mbPkgName isSource case diagOrImp of Left diags -> pure (diags, Just (modName, Nothing)) Right (FileImport path) -> pure ([], Just (modName, Just path)) @@ -405,7 +407,7 @@ bootArtifact <- if boot == Just True then do let modName = ms_mod_name ms - loc <- liftIO $ mkHomeModLocation dflags modName (fromNormalizedFilePath bootPath) + loc <- liftIO $ mkHomeModLocation dflags' modName (fromNormalizedFilePath bootPath) return $ Just (noLoc modName, Just (ArtifactsLocation bootPath (Just loc) True)) else pure Nothing -} @@ -536,9 +538,8 @@ let cycles = mapMaybe (cycleErrorInFile fileId) (toList errs) -- Convert cycles of files into cycles of module names forM cycles $ \(imp, files) -> do - modNames <- forM files $ \fileId -> do - let file = idToPath depPathIdMap fileId - getModuleName file + modNames <- forM files $ + getModuleName . idToPath depPathIdMap pure $ toDiag imp $ sort modNames where cycleErrorInFile f (PartOfCycle imp fs) | f `elem` fs = Just (imp, fs) @@ -649,10 +650,9 @@ readHieFileFromDisk recorder hie_loc = do nc <- asks ideNc res <- liftIO $ tryAny $ loadHieFile (mkUpdater nc) hie_loc - let log = (liftIO .) . logWith recorder case res of - Left e -> log Logger.Debug $ LogLoadingHieFileFail hie_loc e - Right _ -> log Logger.Debug $ LogLoadingHieFileSuccess hie_loc + Left e -> liftIO $ logWith recorder Logger.Debug $ LogLoadingHieFileFail hie_loc e + Right _ -> liftIO $ logWith recorder Logger.Debug $ LogLoadingHieFileSuccess hie_loc except res -- | Typechecks a module. @@ -852,7 +852,6 @@ Just session -> do linkableType <- getLinkableType f ver <- use_ GetModificationTime f - ShakeExtras{ideNc} <- getShakeExtras let m_old = case old of Shake.Succeeded (Just old_version) v -> Just (v, old_version) Shake.Stale _ (Just old_version) v -> Just (v, old_version) @@ -889,12 +888,12 @@ -- 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 + fileHash <- liftIO $ Util.getFileHash hie_loc mrow <- liftIO $ withHieDb (\hieDb -> HieDb.lookupHieFileFromSource hieDb (fromNormalizedFilePath f)) hie_loc' <- liftIO $ traverse (makeAbsolute . HieDb.hieModuleHieFile) mrow case mrow of Just row - | hash == HieDb.modInfoHash (HieDb.hieModInfo row) + | fileHash == HieDb.modInfoHash (HieDb.hieModInfo row) && Just hie_loc == hie_loc' -> do -- All good, the db has indexed the file @@ -911,7 +910,7 @@ -- can just re-index the file we read from disk Right hf -> liftIO $ do logWith recorder Logger.Debug $ LogReindexingHieFile f - indexHieFile se ms f hash hf + indexHieFile se ms f fileHash hf return (Just x) @@ -955,8 +954,8 @@ Left diags -> return (Nothing, (diags, Nothing)) defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetModSummaryWithoutTimestamps f -> do - ms <- use GetModSummary f - case ms of + mbMs <- use GetModSummary f + case mbMs of Just res@ModSummaryResult{..} -> do let ms = msrModSummary { #if !MIN_VERSION_ghc(9,3,0) @@ -982,7 +981,7 @@ getModIfaceRule :: Recorder (WithPriority Log) -> Rules () getModIfaceRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModIface f -> do fileOfInterest <- use_ IsFileOfInterest f - res@(_,(_,mhmi)) <- case fileOfInterest of + res <- case fileOfInterest of IsFOI status -> do -- Never load from disk for files of interest tmr <- use_ TypeCheck f @@ -990,14 +989,14 @@ hsc <- hscEnv <$> use_ GhcSessionDeps f let compile = fmap ([],) $ use GenerateCore f se <- getShakeExtras - (diags, !hiFile) <- writeCoreFileIfNeeded se hsc linkableType compile tmr - let fp = hiFileFingerPrint <$> hiFile - hiDiags <- case hiFile of + (diags, !mbHiFile) <- writeCoreFileIfNeeded se hsc linkableType compile tmr + let fp = hiFileFingerPrint <$> mbHiFile + hiDiags <- case mbHiFile of Just hiFile | OnDisk <- status , not (tmrDeferredError tmr) -> liftIO $ writeHiFile se hsc hiFile _ -> pure [] - return (fp, (diags++hiDiags, hiFile)) + return (fp, (diags++hiDiags, mbHiFile)) NotFOI -> do hiFile <- use GetModIfaceFromDiskAndIndex f let fp = hiFileFingerPrint <$> hiFile @@ -1029,22 +1028,22 @@ -- Embed haddocks in the interface file (diags, mb_pm) <- liftIO $ getParsedModuleDefinition hsc opt f (withOptHaddock ms) - (diags, mb_pm) <- + (diags', mb_pm') <- -- We no longer need to parse again if GHC version is above 9.0. https://github.com/haskell/haskell-language-server/issues/1892 if Compat.ghcVersion >= Compat.GHC90 || isJust mb_pm then do return (diags, mb_pm) else do -- if parsing fails, try parsing again with Haddock turned off - (diagsNoHaddock, mb_pm) <- liftIO $ getParsedModuleDefinition hsc opt f ms - return (mergeParseErrorsHaddock diagsNoHaddock diags, mb_pm) - case mb_pm of - Nothing -> return (diags, Nothing) + (diagsNoHaddock, mb_pm') <- liftIO $ getParsedModuleDefinition hsc opt f ms + return (mergeParseErrorsHaddock diagsNoHaddock diags, mb_pm') + case mb_pm' of + Nothing -> return (diags', Nothing) Just pm -> do -- Invoke typechecking directly to update it without incurring a dependency -- on the parsed module and the typecheck rules - (diags', mtmr) <- typeCheckRuleDefinition hsc pm + (diags'', mtmr) <- typeCheckRuleDefinition hsc pm case mtmr of - Nothing -> pure (diags', Nothing) + Nothing -> pure (diags'', Nothing) Just tmr -> do let compile = liftIO $ compileModule (RunSimplifier True) hsc (pm_mod_summary pm) $ tmrTypechecked tmr @@ -1052,7 +1051,7 @@ se <- getShakeExtras -- Bang pattern is important to avoid leaking 'tmr' - (diags'', !res) <- writeCoreFileIfNeeded se hsc compNeeded compile tmr + (diags''', !res) <- writeCoreFileIfNeeded se hsc compNeeded compile tmr -- Write hi file hiDiags <- case res of @@ -1061,22 +1060,22 @@ -- Write hie file. Do this before writing the .hi file to -- ensure that we always have a up2date .hie file if we have -- a .hi file - se <- getShakeExtras + se' <- getShakeExtras (gDiags, masts) <- liftIO $ generateHieAsts hsc tmr source <- getSourceFileSource f wDiags <- forM masts $ \asts -> - liftIO $ writeAndIndexHieFile hsc se (tmrModSummary tmr) f (tcg_exports $ tmrTypechecked tmr) asts source + liftIO $ writeAndIndexHieFile hsc se' (tmrModSummary tmr) f (tcg_exports $ tmrTypechecked tmr) asts source -- We don't write the `.hi` file if there are deferred errors, since we won't get -- accurate diagnostics next time if we do hiDiags <- if not $ tmrDeferredError tmr - then liftIO $ writeHiFile se hsc hiFile + then liftIO $ writeHiFile se' hsc hiFile else pure [] pure (hiDiags <> gDiags <> concat wDiags) Nothing -> pure [] - return (diags <> diags' <> diags'' <> hiDiags, res) + return (diags' <> diags'' <> diags''' <> hiDiags, res) -- | HscEnv should have deps included already @@ -1096,6 +1095,7 @@ (diags', !res) <- liftIO $ mkHiFileResultCompile se hsc tmr guts pure (diags++diags', res) +-- See Note [Client configuration in Rules] getClientSettingsRule :: Recorder (WithPriority Log) -> Rules () getClientSettingsRule recorder = defineEarlyCutOffNoFile (cmapWithPrio LogShake recorder) $ \GetClientSettings -> do alwaysRerun @@ -1126,10 +1126,8 @@ core_t <- liftIO $ getModTime core_file case hirCoreFp of Nothing -> error "called GetLinkable for a file without a linkable" - Just (bin_core, hash) -> do + Just (bin_core, fileHash) -> do session <- use_ GhcSessionDeps f - ShakeExtras{ideNc} <- getShakeExtras - let namecache_updater = mkUpdater ideNc linkableType <- getLinkableType f >>= \case Nothing -> error "called GetLinkable for a file which doesn't need compilation" Just t -> pure t @@ -1165,9 +1163,9 @@ --just before returning it to be loaded. This has a substantial effect on recompile --times as the number of loaded modules and splices increases. -- - unload (hscEnv session) (map (\(mod, time) -> LM time mod []) $ moduleEnvToList to_keep) + unload (hscEnv session) (map (\(mod', time') -> LM time' mod' []) $ moduleEnvToList to_keep) return (to_keep, ()) - return (hash <$ hmi, (warns, LinkableResult <$> hmi <*> pure hash)) + return (fileHash <$ hmi, (warns, LinkableResult <$> hmi <*> pure fileHash)) -- | For now we always use bytecode unless something uses unboxed sums and tuples along with TH getLinkableType :: NormalizedFilePath -> Action (Maybe LinkableType) @@ -1224,11 +1222,11 @@ #if defined(GHC_PATCHED_UNBOXED_BYTECODE) || MIN_VERSION_ghc(9,2,0) = BCOLinkable #else - | unboxed_tuples_or_sums = ObjectLinkable + | _unboxed_tuples_or_sums = ObjectLinkable | otherwise = BCOLinkable #endif - where - unboxed_tuples_or_sums = + where -- unboxed_tuples_or_sums is only used in GHC < 9.2 + _unboxed_tuples_or_sums = xopt LangExt.UnboxedTuples d || xopt LangExt.UnboxedSums d -- | Tracks which linkables are current, so we don't need to unload them diff --git a/src/Development/IDE/Core/Service.hs b/src/Development/IDE/Core/Service.hs --- a/src/Development/IDE/Core/Service.hs +++ b/src/Development/IDE/Core/Service.hs @@ -52,9 +52,9 @@ instance Pretty Log where pretty = \case - LogShake log -> pretty log - LogOfInterest log -> pretty log - LogFileExists log -> pretty log + LogShake msg -> pretty msg + LogOfInterest msg -> pretty msg + LogFileExists msg -> pretty msg ------------------------------------------------------------ -- Exposed API 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 @@ -86,12 +86,14 @@ import Control.Concurrent.Strict import Control.DeepSeq import Control.Exception.Extra hiding (bracket_) +import Control.Lens ((&), (?~)) import Control.Monad.Extra import Control.Monad.IO.Class import Control.Monad.Reader import Control.Monad.Trans.Maybe import Data.Aeson (Result (Success), toJSON) +import qualified Data.Aeson.Types as A import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Char8 as BS8 import Data.Coerce (coerce) @@ -99,14 +101,13 @@ import Data.Dynamic import Data.EnumMap.Strict (EnumMap) import qualified Data.EnumMap.Strict as EM -import Data.Foldable (find, for_, toList) +import Data.Foldable (find, for_) import Data.Functor ((<&>)) import Data.Functor.Identity import Data.Hashable import qualified Data.HashMap.Strict as HMap import Data.HashSet (HashSet) import qualified Data.HashSet as HSet -import Data.IORef import Data.List.Extra (foldl', partition, takeEnd) import qualified Data.Map.Strict as Map @@ -130,14 +131,10 @@ import Development.IDE.GHC.Compat (NameCache, NameCacheUpdater (..), initNameCache, - knownKeyNames, - mkSplitUniqSupply) -#if !MIN_VERSION_ghc(9,3,0) -import Development.IDE.GHC.Compat (upNameCache) -#endif -import qualified Data.Aeson.Types as A + knownKeyNames) import Development.IDE.GHC.Orphans () -import Development.IDE.Graph hiding (ShakeValue) +import Development.IDE.Graph hiding (ShakeValue, + action) import qualified Development.IDE.Graph as Shake import Development.IDE.Graph.Database (ShakeDatabase, shakeGetBuildStep, @@ -148,7 +145,7 @@ import Development.IDE.Graph.Rule import Development.IDE.Types.Action import Development.IDE.Types.Diagnostics -import Development.IDE.Types.Exports +import Development.IDE.Types.Exports hiding (exportsMapSize) import qualified Development.IDE.Types.Exports as ExportsMap import Development.IDE.Types.KnownTargets import Development.IDE.Types.Location @@ -167,18 +164,27 @@ PluginDescriptor (pluginId), PluginId) import Language.LSP.Diagnostics +import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP import Language.LSP.VFS hiding (start) import qualified "list-t" ListT -import OpenTelemetry.Eventlog +import OpenTelemetry.Eventlog hiding (addEvent) import qualified StmContainers.Map as STM import System.FilePath hiding (makeRelative) import System.IO.Unsafe (unsafePerformIO) import System.Time.Extra +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] + +#if !MIN_VERSION_ghc(9,3,0) +import Data.IORef +import Development.IDE.GHC.Compat (mkSplitUniqSupply, + upNameCache) +#endif + data Log = LogCreateHieDbExportsMapStart | LogCreateHieDbExportsMapFinish !Int @@ -205,10 +211,10 @@ , "Aborting previous build session took" <+> pretty (showDuration abortDuration) <+> pretty shakeProfilePath ] LogBuildSessionRestartTakingTooLong seconds -> "Build restart is taking too long (" <> pretty seconds <> " seconds)" - LogDelayedAction delayedAction duration -> + LogDelayedAction delayedAct seconds -> hsep - [ "Finished:" <+> pretty (actionName delayedAction) - , "Took:" <+> pretty (showDuration duration) ] + [ "Finished:" <+> pretty (actionName delayedAct) + , "Took:" <+> pretty (showDuration seconds) ] LogBuildSessionFinish e -> vcat [ "Finished build session" @@ -319,6 +325,7 @@ -- This will actually crash HLS Nothing -> liftIO $ fail "missing ShakeExtras" +-- See Note [Client configuration in Rules] -- | Returns the client configuration, creating a build dependency. -- You should always use this function when accessing client configuration -- from build rules. @@ -379,9 +386,9 @@ let typ = typeRep (Proxy :: Proxy a) x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readTVarIO globals case x of - Just x - | Just x <- fromDynamic x -> pure x - | otherwise -> errorIO $ "Internal error, getIdeGlobalExtras, wrong type for " ++ show typ ++ " (got " ++ show (dynTypeRep x) ++ ")" + Just y + | Just z <- fromDynamic y -> pure z + | otherwise -> errorIO $ "Internal error, getIdeGlobalExtras, wrong type for " ++ show typ ++ " (got " ++ show (dynTypeRep y) ++ ")" Nothing -> errorIO $ "Internal error, getIdeGlobalExtras, no entry for " ++ show typ getIdeGlobalAction :: forall a . (HasCallStack, IsIdeGlobal a) => Action a @@ -396,8 +403,8 @@ getIdeOptions :: Action IdeOptions getIdeOptions = do GlobalIdeOptions x <- getIdeGlobalAction - env <- lspEnv <$> getShakeExtras - case env of + mbEnv <- lspEnv <$> getShakeExtras + case mbEnv of Nothing -> return x Just env -> do config <- liftIO $ LSP.runLspT env HLS.getClientConfig @@ -429,8 +436,8 @@ Nothing -> atomicallyNamed "lastValueIO 1" $ do STM.focus (Focus.alter (alterValue $ Failed True)) (toKey k file) state return Nothing - Just (v,del,ver) -> do - actual_version <- case ver of + Just (v,del,mbVer) -> do + actual_version <- case mbVer of Just ver -> pure (Just $ VFSVersion ver) Nothing -> (Just . ModificationTime <$> getModTime (fromNormalizedFilePath file)) `catch` (\(_ :: IOException) -> pure Nothing) @@ -448,7 +455,7 @@ atomicallyNamed "lastValueIO 4" (STM.lookup (toKey k file) state) >>= \case Nothing -> readPersistent - Just (ValueWithDiagnostics v _) -> case v of + Just (ValueWithDiagnostics value _) -> case value of Succeeded ver (fromDynamic -> Just v) -> atomicallyNamed "lastValueIO 5" $ Just . (v,) <$> mappingForVersion positionMapping file ver Stale del ver (fromDynamic -> Just v) -> @@ -599,8 +606,6 @@ shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) withHieDb indexQueue opts monitoring rules = mdo - let log :: Logger.Priority -> Log -> IO () - log = logWith recorder #if MIN_VERSION_ghc(9,3,0) ideNc <- initNameCache 'r' knownKeyNames @@ -626,10 +631,10 @@ -- lazily initialize the exports map with the contents of the hiedb -- TODO: exceptions can be swallowed here? _ <- async $ do - log Debug LogCreateHieDbExportsMapStart + logWith recorder Debug LogCreateHieDbExportsMapStart em <- createExportsMapHieDb withHieDb atomically $ modifyTVar' exportsMap (<> em) - log Debug $ LogCreateHieDbExportsMapFinish (ExportsMap.size em) + logWith recorder Debug $ LogCreateHieDbExportsMapFinish (ExportsMap.size em) progress <- do let (before, after) = if testing then (0,0.1) else (0.1,0.1) @@ -732,14 +737,13 @@ withMVar' shakeSession (\runner -> do - let log = logWith recorder - (stopTime,()) <- duration $ logErrorAfter 10 recorder $ cancelShakeSession runner + (stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner res <- shakeDatabaseProfile shakeDb backlog <- readTVarIO $ dirtyKeys shakeExtras queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras -- this log is required by tests - log Debug $ LogBuildSessionRestart reason queue backlog stopTime res + logWith recorder Debug $ LogBuildSessionRestart reason queue backlog stopTime res ) -- It is crucial to be masked here, otherwise we can get killed -- between spawning the new thread and updating shakeSession. @@ -747,8 +751,8 @@ (\() -> do (,()) <$> newSession recorder shakeExtras vfs shakeDb acts reason) where - logErrorAfter :: Seconds -> Recorder (WithPriority Log) -> IO () -> IO () - logErrorAfter seconds recorder action = flip withAsync (const action) $ do + logErrorAfter :: Seconds -> IO () -> IO () + logErrorAfter seconds action = flip withAsync (const action) $ do sleep seconds logWith recorder Error (LogBuildSessionRestartTakingTooLong seconds) @@ -761,8 +765,8 @@ shakeEnqueue ShakeExtras{actionQueue, logger} act = do (b, dai) <- instantiateDelayedAction act atomicallyNamed "actionQueue - push" $ pushQueue dai actionQueue - let wait' b = - waitBarrier b `catches` + let wait' barrier = + waitBarrier barrier `catches` [ Handler(\BlockedIndefinitelyOnMVar -> fail $ "internal bug: forever blocked on MVar for " <> actionName act) @@ -993,9 +997,6 @@ newtype IdeAction a = IdeAction { runIdeActionT :: (ReaderT ShakeExtras IO) a } deriving newtype (MonadReader ShakeExtras, MonadIO, Functor, Applicative, Monad, Semigroup) --- https://hub.darcs.net/ross/transformers/issue/86 -deriving instance (Semigroup (m a)) => Semigroup (ReaderT r m a) - runIdeAction :: String -> ShakeExtras -> IdeAction a -> IO a runIdeAction _herald s i = runReaderT (runIdeActionT i) s @@ -1029,7 +1030,7 @@ -- Async trigger the key to be built anyway because we want to -- keep updating the value in the key. - wait <- delayedAction $ mkDelayedAction ("C:" ++ show key ++ ":" ++ fromNormalizedFilePath file) Debug $ use key file + waitValue <- delayedAction $ mkDelayedAction ("C:" ++ show key ++ ":" ++ fromNormalizedFilePath file) Debug $ use key file s@ShakeExtras{state} <- askShake r <- liftIO $ atomicallyNamed "useStateFast" $ getValues state key file @@ -1040,13 +1041,13 @@ res <- lastValueIO s key file case res of Nothing -> do - a <- wait + a <- waitValue pure $ FastResult ((,zeroMapping) <$> a) (pure a) - Just _ -> pure $ FastResult res wait + Just _ -> pure $ FastResult res waitValue -- Otherwise, use the computed value even if it's out of date. Just _ -> do res <- lastValueIO s key file - pure $ FastResult res wait + pure $ FastResult res waitValue useNoFile :: IdeRule k v => k -> Action (Maybe v) useNoFile key = use key emptyFilePath @@ -1144,7 +1145,7 @@ defineEarlyCutOffNoFile :: IdeRule k v => Recorder (WithPriority Log) -> (k -> Action (BS.ByteString, v)) -> Rules () defineEarlyCutOffNoFile recorder f = defineEarlyCutoff recorder $ RuleNoDiagnostics $ \k file -> do - if file == emptyFilePath then do (hash, res) <- f k; return (Just hash, Just res) else + if file == emptyFilePath then do (hashString, res) <- f k; return (Just hashString, Just res) else fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file" defineEarlyCutoff' @@ -1158,14 +1159,14 @@ -> RunMode -> (Value v -> Action (Maybe BS.ByteString, IdeResult v)) -> Action (RunResult (A (RuleResult k))) -defineEarlyCutoff' doDiagnostics cmp key file old mode action = do +defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do ShakeExtras{state, progress, dirtyKeys} <- getShakeExtras options <- getIdeOptions (if optSkipProgress options key then id else inProgress progress file) $ do - val <- case old of + val <- case mbOld of Just old | mode == RunDependenciesSame -> do - v <- liftIO $ atomicallyNamed "define - read 1" $ getValues state key file - case v of + mbValue <- liftIO $ atomicallyNamed "define - read 1" $ getValues state key file + case mbValue of -- No changes in the dependencies and we have -- an existing successful result. Just (v@(Succeeded _ x), diags) -> do @@ -1185,19 +1186,19 @@ Just (Succeeded ver v, _) -> Stale Nothing ver v Just (Stale d ver v, _) -> Stale d ver v Just (Failed b, _) -> Failed b - (bs, (diags, res)) <- actionCatch + (mbBs, (diags, mbRes)) <- actionCatch (do v <- action staleV; liftIO $ evaluate $ force v) $ \(e :: SomeException) -> do pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing)) - ver <- estimateFileVersionUnsafely key res file - (bs, res) <- case res of + ver <- estimateFileVersionUnsafely key mbRes file + (bs, res) <- case mbRes of Nothing -> do - pure (toShakeValue ShakeStale bs, staleV) - Just v -> pure (maybe ShakeNoCutoff ShakeResult bs, Succeeded ver v) + pure (toShakeValue ShakeStale mbBs, staleV) + Just v -> pure (maybe ShakeNoCutoff ShakeResult mbBs, Succeeded ver v) liftIO $ atomicallyNamed "define - write" $ setValues state key file res (Vector.fromList diags) doDiagnostics (vfsVersion =<< ver) diags - let eq = case (bs, fmap decodeShakeValue old) of + let eq = case (bs, fmap decodeShakeValue mbOld) of (ShakeResult a, Just (ShakeResult b)) -> cmp a b (ShakeStale a, Just (ShakeStale b)) -> cmp a b -- If we do not have a previous result @@ -1214,9 +1215,7 @@ -- without creating a dependency on the GetModificationTime rule -- (and without creating cycles in the build graph). estimateFileVersionUnsafely - :: forall k v - . IdeRule k v - => k + :: k -> Maybe v -> NormalizedFilePath -> Action (Maybe FileVersion) @@ -1254,7 +1253,7 @@ addTagUnsafe :: String -> String -> String -> a -> a addTagUnsafe msg t x v = unsafePerformIO(addTag (msg <> t) x) `seq` v update :: (forall a. String -> String -> a -> a) -> [Diagnostic] -> STMDiagnosticStore -> STM [Diagnostic] - update addTagUnsafe new store = addTagUnsafe "count" (show $ Prelude.length new) $ setStageDiagnostics addTagUnsafe uri ver (renderKey k) new store + update addTagUnsafeMethod new store = addTagUnsafeMethod "count" (show $ Prelude.length new) $ setStageDiagnostics addTagUnsafeMethod uri ver (renderKey k) new store current = second diagsFromRule <$> current0 addTag "version" (show ver) mask_ $ do @@ -1264,11 +1263,11 @@ -- publishDiagnosticsNotification. newDiags <- liftIO $ atomicallyNamed "diagnostics - update" $ update (addTagUnsafe "shown ") (map snd currentShown) diagnostics _ <- liftIO $ atomicallyNamed "diagnostics - hidden" $ update (addTagUnsafe "hidden ") (map snd currentHidden) hiddenDiagnostics - let uri = filePathToUri' fp + let uri' = filePathToUri' fp let delay = if null newDiags then 0.1 else 0 - registerEvent debouncer delay uri $ withTrace ("report diagnostics " <> fromString (fromNormalizedFilePath fp)) $ \tag -> do + registerEvent debouncer delay uri' $ withTrace ("report diagnostics " <> fromString (fromNormalizedFilePath fp)) $ \tag -> do join $ mask_ $ do - lastPublish <- atomicallyNamed "diagnostics - publish" $ STM.focus (Focus.lookupWithDefault [] <* Focus.insert newDiags) uri publishedDiagnostics + lastPublish <- atomicallyNamed "diagnostics - publish" $ STM.focus (Focus.lookupWithDefault [] <* Focus.insert newDiags) uri' publishedDiagnostics let action = when (lastPublish /= newDiags) $ case lspEnv of Nothing -> -- Print an LSP event. logWith recorder Info $ LogDiagsDiffButNoLspEnv (map (fp, ShowDiag,) newDiags) @@ -1276,14 +1275,13 @@ liftIO $ tag "count" (show $ Prelude.length newDiags) liftIO $ tag "key" (show k) LSP.sendNotification SMethod_TextDocumentPublishDiagnostics $ - LSP.PublishDiagnosticsParams (fromNormalizedUri uri) (fmap fromIntegral ver) ( newDiags) + LSP.PublishDiagnosticsParams (fromNormalizedUri uri') (fmap fromIntegral ver) ( newDiags) return action where diagsFromRule :: Diagnostic -> Diagnostic diagsFromRule c@Diagnostic{_range} - | coerce ideTesting = c - {_relatedInformation = - Just $ [ + | coerce ideTesting = c & L.relatedInformation ?~ + [ DiagnosticRelatedInformation (Location (filePathToUri $ fromNormalizedFilePath fp) @@ -1291,7 +1289,6 @@ ) (T.pack $ show k) ] - } | otherwise = c 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 @@ -1,7 +1,3 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE PatternSynonyms #-} -{-# HLINT ignore #-} module Development.IDE.Core.Tracing ( otTracedHandler 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 @@ -15,27 +15,33 @@ module Development.IDE.GHC.CPP(doCpp, addOptP) where -import Control.Monad import Development.IDE.GHC.Compat as Compat import Development.IDE.GHC.Compat.Util import GHC -#if MIN_VERSION_ghc(9,0,0) -import qualified GHC.Driver.Pipeline as Pipeline -import GHC.Settings -#elif MIN_VERSION_ghc (8,10,0) +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] + +#if MIN_VERSION_ghc (8,10,0) && !MIN_VERSION_ghc(9,0,0) import qualified DriverPipeline as Pipeline import ToolSettings #endif -#if MIN_VERSION_ghc(9,5,0) -import qualified GHC.SysTools.Cpp as Pipeline +#if MIN_VERSION_ghc(9,0,0) +import GHC.Settings #endif -#if MIN_VERSION_ghc(9,3,0) +#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,3,0) +import qualified GHC.Driver.Pipeline as Pipeline +#endif + +#if MIN_VERSION_ghc(9,3,0) && !MIN_VERSION_ghc(9,5,0) import qualified GHC.Driver.Pipeline.Execute as Pipeline #endif +#if MIN_VERSION_ghc(9,5,0) +import qualified GHC.SysTools.Cpp as Pipeline +#endif + addOptP :: String -> DynFlags -> DynFlags addOptP f = alterToolSettings $ \s -> s { toolSettings_opt_P = f : toolSettings_opt_P s @@ -43,7 +49,7 @@ } where fingerprintStrings ss = fingerprintFingerprints $ map fingerprintString ss - alterToolSettings f dynFlags = dynFlags { toolSettings = f (toolSettings dynFlags) } + alterToolSettings g dynFlags = dynFlags { toolSettings = g (toolSettings dynFlags) } doCpp :: HscEnv -> FilePath -> FilePath -> IO () doCpp env input_fn output_fn = 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 @@ -142,7 +142,7 @@ #endif ) where -import Data.Bifunctor +import Prelude hiding (mod) import Development.IDE.GHC.Compat.Core hiding (moduleUnitId) import Development.IDE.GHC.Compat.Env import Development.IDE.GHC.Compat.Iface @@ -156,53 +156,21 @@ ModLocation, RealSrcSpan, exprType, getLoc, lookupName) - import Data.Coerce (coerce) import Data.String (IsString (fromString)) +import Compat.HieAst (enrichHie) +import Compat.HieBin +import Compat.HieTypes hiding (nodeAnnotations) +import qualified Compat.HieTypes as GHC (nodeAnnotations) +import Compat.HieUtils +import qualified Data.ByteString as BS +import Data.List (foldl') +import qualified Data.Map as Map +import qualified Data.Set as S +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if MIN_VERSION_ghc(9,0,0) -#if MIN_VERSION_ghc(9,5,0) -import GHC.Core.Lint.Interactive (interactiveInScope) -import GHC.Driver.Config.Core.Lint.Interactive (lintInteractiveExpr) -import GHC.Driver.Config.Core.Opt.Simplify (initSimplifyExprOpts) -import GHC.Driver.Config.CoreToStg (initCoreToStgOpts) -import GHC.Driver.Config.CoreToStg.Prep (initCorePrepConfig) -#else -import GHC.Core.Lint (lintInteractiveExpr) -#endif -import qualified GHC.Core.Opt.Pipeline as GHC -import GHC.Core.Tidy (tidyExpr) -import GHC.CoreToStg.Prep (corePrepPgm) -import qualified GHC.CoreToStg.Prep as GHC -import GHC.Driver.Hooks (hscCompileCoreExprHook) -#if MIN_VERSION_ghc(9,2,0) -import GHC.Linker.Loader (loadExpr) -import GHC.Linker.Types (isObjectLinkable) -import GHC.Runtime.Context (icInteractiveModule) -import GHC.Unit.Home.ModInfo (HomePackageTable, - lookupHpt) -#if MIN_VERSION_ghc(9,3,0) -import GHC.Unit.Module.Deps (Dependencies(dep_direct_mods), Usage(..)) -#else -import GHC.Unit.Module.Deps (Dependencies(dep_mods), Usage(..)) -#endif -#else -import GHC.CoreToByteCode (coreExprToBCOs) -import GHC.Driver.Types (Dependencies (dep_mods), - HomePackageTable, - icInteractiveModule, - lookupHpt) -import GHC.Runtime.Linker (linkExpr) -#endif -import GHC.ByteCode.Asm (bcoFreeNames) -import GHC.Types.Annotations (AnnTarget (ModuleTarget), - Annotation (..), - extendAnnEnvList) -import GHC.Types.Unique.DFM as UniqDFM -import GHC.Types.Unique.DSet as UniqDSet -import GHC.Types.Unique.Set as UniqSet -#else +#if !MIN_VERSION_ghc(9,0,0) import Annotations (AnnTarget (ModuleTarget), Annotation (..), extendAnnEnvList) @@ -224,70 +192,101 @@ import UniqSet import VarEnv (emptyInScopeSet, emptyTidyEnv, mkRnEnv2) +import FastString +import qualified Avail +import DynFlags hiding (ExposePackage) +import HscTypes +import MkIface hiding (writeIfaceFile) + +import StringBuffer (hPutStringBuffer) +import qualified SysTools #endif #if MIN_VERSION_ghc(9,0,0) +import qualified GHC.Core.Opt.Pipeline as GHC +import GHC.Core.Tidy (tidyExpr) +import GHC.CoreToStg.Prep (corePrepPgm) +import qualified GHC.CoreToStg.Prep as GHC +import GHC.Driver.Hooks (hscCompileCoreExprHook) + +import GHC.ByteCode.Asm (bcoFreeNames) +import GHC.Types.Annotations (AnnTarget (ModuleTarget), + Annotation (..), + extendAnnEnvList) +import GHC.Types.Unique.DFM as UniqDFM +import GHC.Types.Unique.DSet as UniqDSet +import GHC.Types.Unique.Set as UniqSet import GHC.Data.FastString import GHC.Core import GHC.Data.StringBuffer import GHC.Driver.Session hiding (ExposePackage) -import qualified GHC.Types.SrcLoc as SrcLoc import GHC.Types.Var.Env -import GHC.Utils.Error -#if MIN_VERSION_ghc(9,2,0) -import GHC.Driver.Env as Env -import GHC.Unit.Module.ModIface -import GHC.Unit.Module.ModSummary -#else -import GHC.Driver.Types -#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 FastString -import qualified Avail -import DynFlags hiding (ExposePackage) -import HscTypes -import MkIface hiding (writeIfaceFile) +#endif -import StringBuffer (hPutStringBuffer) -import qualified SysTools +#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0) +import GHC.Utils.Error +import GHC.CoreToByteCode (coreExprToBCOs) +import GHC.Runtime.Linker (linkExpr) +import GHC.Driver.Types #endif -import Compat.HieAst (enrichHie) -import Compat.HieBin -import Compat.HieTypes hiding (nodeAnnotations) -import qualified Compat.HieTypes as GHC (nodeAnnotations) -import Compat.HieUtils -import qualified Data.ByteString as BS -import Data.IORef +#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,5,0) +import GHC.Core.Lint (lintInteractiveExpr) +#endif -import Data.List (foldl') -import qualified Data.Map as Map -import qualified Data.Set as S +#if !MIN_VERSION_ghc(9,2,0) +import Data.Bifunctor +#endif #if MIN_VERSION_ghc(9,2,0) +import GHC.Iface.Env +import qualified GHC.Types.SrcLoc as SrcLoc +import GHC.Linker.Loader (loadExpr) +import GHC.Runtime.Context (icInteractiveModule) +import GHC.Unit.Home.ModInfo (HomePackageTable, + lookupHpt) +import GHC.Driver.Env as Env +import GHC.Unit.Module.ModIface import GHC.Builtin.Uniques import GHC.ByteCode.Types import GHC.CoreToStg import GHC.Data.Maybe import GHC.Linker.Loader (loadDecls) -import GHC.Runtime.Interpreter import GHC.Stg.Pipeline import GHC.Stg.Syntax import GHC.StgToByteCode import GHC.Types.CostCentre import GHC.Types.IPE +#endif + +#if MIN_VERSION_ghc(9,2,0) && !MIN_VERSION_ghc(9,3,0) +import GHC.Unit.Module.Deps (Dependencies(dep_mods), Usage(..)) +import GHC.Linker.Types (isObjectLinkable) +import GHC.Unit.Module.ModSummary +import GHC.Runtime.Interpreter #endif +#if !MIN_VERSION_ghc(9,3,0) +import Data.IORef +#endif + #if MIN_VERSION_ghc(9,3,0) -import GHC.Types.Error +import GHC.Unit.Module.Deps (Dependencies(dep_direct_mods), Usage(..)) import GHC.Driver.Config.Stg.Pipeline -import GHC.Driver.Plugins (PsMessages (..)) #endif +#if MIN_VERSION_ghc(9,5,0) +import GHC.Core.Lint.Interactive (interactiveInScope) +import GHC.Driver.Config.Core.Lint.Interactive (lintInteractiveExpr) +import GHC.Driver.Config.Core.Opt.Simplify (initSimplifyExprOpts) +import GHC.Driver.Config.CoreToStg (initCoreToStgOpts) +import GHC.Driver.Config.CoreToStg.Prep (initCorePrepConfig) +#endif + + #if !MIN_VERSION_ghc(9,3,0) nonDetOccEnvElts :: OccEnv a -> [a] nonDetOccEnvElts = occEnvElts @@ -417,9 +416,9 @@ corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr #if MIN_VERSION_ghc(9,5,0) -corePrepExpr _ env exp = do +corePrepExpr _ env expr = do cfg <- initCorePrepConfig env - GHC.corePrepExpr (Development.IDE.GHC.Compat.Env.hsc_logger env) cfg exp + GHC.corePrepExpr (Development.IDE.GHC.Compat.Env.hsc_logger env) cfg expr #else corePrepExpr _ = GHC.corePrepExpr #endif @@ -573,12 +572,12 @@ NodeInfo (S.union as bs) (mergeSorted ai bi) (Map.unionWith (<>) ad bd) where mergeSorted :: Ord a => [a] -> [a] -> [a] - mergeSorted la@(a:as) lb@(b:bs) = case compare a b of - LT -> a : mergeSorted as lb - EQ -> a : mergeSorted as bs - GT -> b : mergeSorted la bs - mergeSorted as [] = as - mergeSorted [] bs = bs + mergeSorted la@(a:axs) lb@(b:bxs) = case compare a b of + LT -> a : mergeSorted axs lb + EQ -> a : mergeSorted axs bxs + GT -> b : mergeSorted la bxs + mergeSorted axs [] = axs + mergeSorted [] bxs = bxs #else diff --git a/src/Development/IDE/GHC/Compat/Core.hs b/src/Development/IDE/GHC/Compat/Core.hs --- a/src/Development/IDE/GHC/Compat/Core.hs +++ b/src/Development/IDE/GHC/Compat/Core.hs @@ -3,10 +3,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} --- TODO: remove -{-# OPTIONS -Wno-dodgy-imports -Wno-unused-imports #-} --- | Compat Core module that handles the GHC module hierarchy re-organisation +-- | Compat Core module that handles the GHC module hierarchy re-organization -- by re-exporting everything we care about. -- -- This module provides no other compat mechanisms, except for simple @@ -502,186 +500,16 @@ import qualified GHC -#if MIN_VERSION_ghc(9,3,0) -import GHC.Iface.Recomp (CompileReason(..)) -import GHC.Driver.Env.Types (hsc_type_env_vars) -import GHC.Driver.Env (hscUpdateHUG, hscUpdateHPT, hsc_HUG) -import GHC.Driver.Env.KnotVars -import GHC.Iface.Recomp -import GHC.Linker.Types -import GHC.Unit.Module.Graph -import GHC.Driver.Errors.Types -import GHC.Types.Unique.Map -import GHC.Types.Unique -import GHC.Utils.TmpFs -import GHC.Utils.Panic -import GHC.Unit.Finder.Types -import GHC.Unit.Env -import GHC.Driver.Phases -#endif +-- NOTE(ozkutuk): Cpp clashes Phase.Cpp, so we hide it. +-- Not the greatest solution, but gets the job done +-- (until the CPP extension is actually needed). +import GHC.LanguageExtensions.Type hiding (Cpp) -#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 hiding (pprFamInst) -import GHC.Core.InstEnv -import GHC.Types.Unique.FM hiding (UniqFM) -import qualified GHC.Types.Unique.FM as UniqFM -#if MIN_VERSION_ghc(9,3,0) -import qualified GHC.Driver.Config.Tidy as GHC -import qualified GHC.Data.Strict as Strict -#endif -#if MIN_VERSION_ghc(9,2,0) -import GHC.Data.Bag -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) -import GHC.Core.Unify -import GHC.Core.Utils +import GHC.Hs.Binds +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if MIN_VERSION_ghc(9,2,0) -import GHC.Driver.Env -#else -import GHC.Driver.Finder hiding (mkHomeModLocation) -import GHC.Driver.Types -import GHC.Driver.Ways -#endif -import GHC.Driver.CmdLine (Warn (..)) -import GHC.Driver.Hooks -import GHC.Driver.Main as GHC -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 (HsModule (..), SrcSpanAnn') -import GHC.Hs.Decls hiding (FunDep) -import GHC.Hs.Doc -import GHC.Hs.Expr -import GHC.Hs.Extension -import GHC.Hs.ImpExp -import GHC.Hs.Pat -import GHC.Hs.Type -import GHC.Hs.Utils hiding (collectHsBindsBinders) -import qualified GHC.Hs.Utils as GHC -#endif -#if !MIN_VERSION_ghc(9,2,0) -import GHC.Hs hiding (HsLet, LetStmt) -#endif -import GHC.HsToCore.Docs -import GHC.HsToCore.Expr -import GHC.HsToCore.Monad -import GHC.Iface.Load -import GHC.Iface.Make (mkFullIface, mkPartialIface) -import GHC.Iface.Make as GHC -import GHC.Iface.Recomp -import GHC.Iface.Syntax -import GHC.Iface.Tidy as GHC -import GHC.IfaceToCore -import GHC.Parser -import GHC.Parser.Header hiding (getImports) -#if MIN_VERSION_ghc(9,2,0) -import qualified GHC.Linker.Loader as Linker -import GHC.Linker.Types -import GHC.Parser.Lexer hiding (initParserState, getPsMessages) -import GHC.Parser.Annotation (EpAnn (..)) -import GHC.Platform.Ways -import GHC.Runtime.Context (InteractiveImport (..)) -#else -import GHC.Parser.Lexer -import qualified GHC.Runtime.Linker as Linker -#endif -import GHC.Rename.Fixity (lookupFixityRn) -import GHC.Rename.Names -import GHC.Rename.Splice -import qualified GHC.Runtime.Interpreter as GHCi -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.Avail (greNamePrintableName) -import GHC.Types.Fixity (LexicalFixity (..), Fixity (..), defaultFixity) -#endif -#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 hiding (GRE, gre_name, gre_imp, gre_lcl, gre_par) -import qualified GHC.Types.Name.Reader as RdrName -#if MIN_VERSION_ghc(9,2,0) -import GHC.Types.Name.Set -import GHC.Types.SourceFile (HscSource (..), -#if !MIN_VERSION_ghc(9,3,0) - SourceModified(..) -#endif - ) -import GHC.Types.SourceText -import GHC.Types.Target (Target (..), TargetId (..)) -import GHC.Types.TyThing -import GHC.Types.TyThing.Ppr -#else -import GHC.Types.Name.Set -#endif -import GHC.Types.SrcLoc (BufPos, BufSpan, - SrcLoc (UnhelpfulLoc), - 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 hiding (mkHomeModLocation) -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.Graph (mkModuleGraph) -import GHC.Unit.Module.Imported -import GHC.Unit.Module.ModDetails -import GHC.Unit.Module.ModGuts -import GHC.Unit.Module.ModIface (IfaceExport, ModIface (..), - ModIface_ (..), mi_fix) -import GHC.Unit.Module.ModSummary (ModSummary (..)) -#endif -import GHC.Unit.State (ModuleOrigin (..)) -import GHC.Utils.Error (Severity (..), emptyMessages) -import GHC.Utils.Panic hiding (try) -import qualified GHC.Utils.Panic.Plain as Plain -#else +#if !MIN_VERSION_ghc(9,0,0) import qualified Avail import BasicTypes hiding (Version) import Class @@ -711,7 +539,7 @@ import Id import IfaceSyn import InstEnv -import Lexer hiding (getSrcLoc) +import Lexer import qualified Linker import LoadIface import MkIface as GHC @@ -748,7 +576,6 @@ mapMaybeM, (<$>)) import TcRnTypes import TcType -import qualified TcType import TidyPgm as GHC import qualified TyCoRep import TyCon @@ -766,40 +593,167 @@ import Predicate import SrcLoc (Located, SrcLoc (UnhelpfulLoc), SrcSpan (UnhelpfulSpan)) +import qualified Finder as GHC #endif - -import Data.List (isSuffixOf) -import System.FilePath +#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 hiding (pprFamInst) +import GHC.Core.InstEnv +import GHC.Types.Unique.FM hiding (UniqFM) +import qualified GHC.Types.Unique.FM as UniqFM +import GHC.Core.PatSyn +import GHC.Core.Predicate +import GHC.Core.TyCo.Ppr +import qualified GHC.Core.TyCo.Rep as TyCoRep +import GHC.Core.TyCon +import GHC.Core.Type hiding (mkInfForAllTys) +import GHC.Core.Unify +import GHC.Core.Utils +import GHC.Driver.CmdLine (Warn (..)) +import GHC.Driver.Hooks +import GHC.Driver.Main as GHC +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 +import GHC.HsToCore.Docs +import GHC.HsToCore.Expr +import GHC.HsToCore.Monad +import GHC.Iface.Load +import GHC.Iface.Make as GHC +import GHC.Iface.Recomp +import GHC.Iface.Syntax +import GHC.Iface.Tidy as GHC +import GHC.IfaceToCore +import GHC.Parser +import GHC.Parser.Header hiding (getImports) +import GHC.Rename.Fixity (lookupFixityRn) +import GHC.Rename.Names +import GHC.Rename.Splice +import qualified GHC.Runtime.Interpreter as GHCi +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 +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 hiding (GRE, gre_name, gre_imp, gre_lcl, gre_par) +import qualified GHC.Types.Name.Reader as RdrName +import GHC.Types.SrcLoc (BufPos, BufSpan, + SrcLoc (UnhelpfulLoc), + SrcSpan (UnhelpfulSpan)) +import qualified GHC.Types.SrcLoc as SrcLoc +import GHC.Types.Unique.Supply +import GHC.Types.Var (Var (varName), setTyVarUnique, + setVarUnique) +import GHC.Unit.Info (PackageName (..)) +import GHC.Unit.Module hiding (ModLocation (..), UnitId, + addBootSuffixLocnOut, moduleUnit, + toUnitId) +import qualified GHC.Unit.Module as Module +import GHC.Unit.State (ModuleOrigin (..)) +import GHC.Utils.Error (Severity (..), emptyMessages) +import GHC.Utils.Panic hiding (try) +import qualified GHC.Utils.Panic.Plain as Plain +#endif +#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0) +import GHC.Core.Ppr.TyThing hiding (pprFamInst) +import GHC.Core.TyCo.Rep (scaledThing) +import GHC.Driver.Finder hiding (mkHomeModLocation) +import GHC.Driver.Types +import GHC.Driver.Ways +import GHC.Hs hiding (HsLet, LetStmt) +import GHC.Parser.Lexer +import qualified GHC.Runtime.Linker as Linker +import GHC.Types.Name.Set +import qualified GHC.Driver.Finder as GHC +#endif #if MIN_VERSION_ghc(9,2,0) +import Data.Foldable (toList) +import GHC.Data.Bag +import GHC.Core.Multiplicity (scaledThing) +import GHC.Driver.Env +import GHC.Hs (HsModule (..), SrcSpanAnn') +import GHC.Hs.Decls hiding (FunDep) +import GHC.Hs.Doc +import GHC.Hs.Expr +import GHC.Hs.Extension +import GHC.Hs.ImpExp +import GHC.Hs.Pat +import GHC.Hs.Type +import GHC.Hs.Utils hiding (collectHsBindsBinders) +import qualified GHC.Linker.Loader as Linker +import GHC.Linker.Types +import GHC.Parser.Lexer hiding (initParserState, getPsMessages) +import GHC.Parser.Annotation (EpAnn (..)) +import GHC.Platform.Ways +import GHC.Runtime.Context (InteractiveImport (..)) +import GHC.Types.Avail (greNamePrintableName) +import GHC.Types.Fixity (LexicalFixity (..), Fixity (..), defaultFixity) +import GHC.Types.Meta +import GHC.Types.Name.Set +import GHC.Types.SourceFile (HscSource (..)) +import GHC.Types.SourceText +import GHC.Types.Target (Target (..), TargetId (..)) +import GHC.Types.TyThing +import GHC.Types.TyThing.Ppr +import GHC.Unit.Finder hiding (mkHomeModLocation) +import GHC.Unit.Home.ModInfo +import GHC.Unit.Module.Imported +import GHC.Unit.Module.ModDetails +import GHC.Unit.Module.ModGuts +import GHC.Unit.Module.ModIface (IfaceExport, ModIface (..), + ModIface_ (..), mi_fix) +import GHC.Unit.Module.ModSummary (ModSummary (..)) import Language.Haskell.Syntax hiding (FunDep) #endif -#if MIN_VERSION_ghc(9,3,0) -import GHC.Driver.Env as GHCi -#endif -import Data.Foldable (toList) +#if MIN_VERSION_ghc(9,2,0) && !MIN_VERSION_ghc(9,3,0) +import GHC.Types.SourceFile (SourceModified(..)) +import GHC.Unit.Module.Graph (mkModuleGraph) +import qualified GHC.Unit.Finder as GHC +#endif #if MIN_VERSION_ghc(9,3,0) +import GHC.Driver.Env.KnotVars +import GHC.Unit.Module.Graph +import GHC.Driver.Errors.Types +import GHC.Types.Unique.Map +import GHC.Types.Unique +import GHC.Utils.TmpFs +import GHC.Utils.Panic +import GHC.Unit.Finder.Types +import GHC.Unit.Env +import qualified GHC.Driver.Config.Tidy as GHC +import qualified GHC.Data.Strict as Strict +import GHC.Driver.Env as GHCi import qualified GHC.Unit.Finder as GHC import qualified GHC.Driver.Config.Finder as GHC -#elif MIN_VERSION_ghc(9,2,0) -import qualified GHC.Unit.Finder as GHC -#elif MIN_VERSION_ghc(9,0,0) -import qualified GHC.Driver.Finder as GHC -#else -import qualified Finder as GHC #endif --- NOTE(ozkutuk): Cpp clashes Phase.Cpp, so we hide it. --- Not the greatest solution, but gets the job done --- (until the CPP extension is actually needed). -import GHC.LanguageExtensions.Type hiding (Cpp) - -import GHC.Hs.Binds - mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO Module.ModLocation #if MIN_VERSION_ghc(9,3,0) mkHomeModLocation df mn f = pure $ GHC.mkHomeModLocation (GHC.initFinderOpts df) mn f @@ -1132,10 +1086,10 @@ hsc_env #endif -mkIfaceTc hsc_env sf details ms tcGblEnv = +mkIfaceTc hsc_env sf details _ms tcGblEnv = -- ms is only used in GHC >= 9.4 GHC.mkIfaceTc hsc_env sf details #if MIN_VERSION_ghc(9,3,0) - ms + _ms #endif tcGblEnv @@ -1203,6 +1157,7 @@ #else mapLoc :: (a -> b) -> SrcLoc.GenLocated l a -> SrcLoc.GenLocated l b mapLoc = SrcLoc.mapLoc +groupOrigin :: MatchGroup p body -> Origin groupOrigin = mg_origin #endif diff --git a/src/Development/IDE/GHC/Compat/Env.hs b/src/Development/IDE/GHC/Compat/Env.hs --- a/src/Development/IDE/GHC/Compat/Env.hs +++ b/src/Development/IDE/GHC/Compat/Env.hs @@ -53,58 +53,70 @@ Development.IDE.GHC.Compat.Env.platformDefaultBackend, ) where -import GHC (setInteractiveDynFlags) +import GHC (setInteractiveDynFlags) -#if MIN_VERSION_ghc(9,0,0) -#if MIN_VERSION_ghc(9,2,0) -import GHC.Driver.Backend as Backend -#if MIN_VERSION_ghc(9,3,0) -import GHC.Driver.Env (HscEnv) -#else -import GHC.Driver.Env (HscEnv, hsc_EPS) -#endif -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) -#if __GLASGOW_HASKELL__ >= 905 -import Language.Haskell.Syntax.Module.Name -#else -import GHC.Unit.Module.Name -#endif -import GHC.Unit.Types (Module, Unit, UnitId, mkModule) -#else +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] + +#if !MIN_VERSION_ghc(9,0,0) import DynFlags import Hooks -import HscTypes as Env +import HscTypes as Env import Module #endif #if MIN_VERSION_ghc(9,0,0) -#if !MIN_VERSION_ghc(9,2,0) -import qualified Data.Set as Set +import GHC.Driver.Hooks (Hooks) +import GHC.Driver.Session hiding (mkHomeModule) +import GHC.Unit.Types (Module, UnitId) #endif + +#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0) +import qualified Data.Set as Set +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 +import GHC.Unit.Types (Unit, mkModule) #endif + +#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,5,0) +import GHC.Unit.Module.Name +#endif + #if !MIN_VERSION_ghc(9,2,0) import Data.IORef #endif +#if MIN_VERSION_ghc(9,2,0) +import GHC.Driver.Backend as Backend +import qualified GHC.Driver.Env as Env +import qualified GHC.Driver.Session as Session +import GHC.Platform.Ways hiding (hostFullWays) +import qualified GHC.Platform.Ways as Ways +import GHC.Runtime.Context +import GHC.Unit.Env (UnitEnv) +import GHC.Unit.Home as Home +import GHC.Utils.Logger +import GHC.Utils.TmpFs +#endif + +#if MIN_VERSION_ghc(9,2,0) && !MIN_VERSION_ghc(9,3,0) +import GHC.Driver.Env (HscEnv, hsc_EPS) +#endif + #if MIN_VERSION_ghc(9,3,0) +import GHC.Driver.Env (HscEnv) +#endif + +#if MIN_VERSION_ghc(9,5,0) +import Language.Haskell.Syntax.Module.Name +#endif + +#if MIN_VERSION_ghc(9,3,0) hsc_EPS :: HscEnv -> UnitEnv hsc_EPS = hsc_unit_env #endif @@ -276,13 +288,13 @@ #endif setWays :: Ways -> DynFlags -> DynFlags -setWays ways flags = +setWays newWays flags = #if MIN_VERSION_ghc(9,2,0) - flags { Session.targetWays_ = ways} + flags { Session.targetWays_ = newWays} #elif MIN_VERSION_ghc(9,0,0) - flags {ways = ways} + flags {ways = newWays} #else - updateWays $ flags {ways = ways} + updateWays $ flags {ways = newWays} #endif -- ------------------------------------------------------- diff --git a/src/Development/IDE/GHC/Compat/Iface.hs b/src/Development/IDE/GHC/Compat/Iface.hs --- a/src/Development/IDE/GHC/Compat/Iface.hs +++ b/src/Development/IDE/GHC/Compat/Iface.hs @@ -6,25 +6,32 @@ cannotFindModule, ) where +import Development.IDE.GHC.Compat.Env +import Development.IDE.GHC.Compat.Outputable import GHC -#if MIN_VERSION_ghc(9,3,0) -import GHC.Driver.Session (targetProfile) + +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] + +#if !MIN_VERSION_ghc(9,0,0) +import Finder (FindResult) +import qualified Finder +import qualified MkIface #endif -#if MIN_VERSION_ghc(9,2,0) -import qualified GHC.Iface.Load as Iface -import GHC.Unit.Finder.Types (FindResult) -#elif MIN_VERSION_ghc(9,0,0) + +#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0) import qualified GHC.Driver.Finder as Finder import GHC.Driver.Types (FindResult) import qualified GHC.Iface.Load as Iface -#else -import Finder (FindResult) -import qualified Finder -import qualified MkIface #endif -import Development.IDE.GHC.Compat.Env -import Development.IDE.GHC.Compat.Outputable +#if MIN_VERSION_ghc(9,2,0) +import qualified GHC.Iface.Load as Iface +import GHC.Unit.Finder.Types (FindResult) +#endif + +#if MIN_VERSION_ghc(9,3,0) +import GHC.Driver.Session (targetProfile) +#endif writeIfaceFile :: HscEnv -> FilePath -> ModIface -> IO () #if MIN_VERSION_ghc(9,3,0) diff --git a/src/Development/IDE/GHC/Compat/Logger.hs b/src/Development/IDE/GHC/Compat/Logger.hs --- a/src/Development/IDE/GHC/Compat/Logger.hs +++ b/src/Development/IDE/GHC/Compat/Logger.hs @@ -13,17 +13,26 @@ import Development.IDE.GHC.Compat.Env as Env import Development.IDE.GHC.Compat.Outputable +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] + +#if !MIN_VERSION_ghc(9,0,0) +import DynFlags +import Outputable (queryQual) +#endif + #if MIN_VERSION_ghc(9,0,0) -import GHC.Driver.Session as DynFlags import GHC.Utils.Outputable +#endif + +#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0) +import GHC.Driver.Session as DynFlags +#endif + #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 + #if MIN_VERSION_ghc(9,3,0) import GHC.Types.Error #endif diff --git a/src/Development/IDE/GHC/Compat/Outputable.hs b/src/Development/IDE/GHC/Compat/Outputable.hs --- a/src/Development/IDE/GHC/Compat/Outputable.hs +++ b/src/Development/IDE/GHC/Compat/Outputable.hs @@ -49,17 +49,36 @@ textDoc, ) where +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] +#if !MIN_VERSION_ghc(9,0,0) +import Development.IDE.GHC.Compat.Core (GlobalRdrEnv) +import DynFlags +import ErrUtils hiding (mkWarnMsg) +import qualified ErrUtils as Err +import HscTypes +import Outputable as Out hiding + (defaultUserStyle) +import qualified Outputable as Out +import SrcLoc +#endif + +#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0) +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 hiding + (defaultUserStyle) +import qualified GHC.Utils.Outputable as Out +#endif + #if MIN_VERSION_ghc(9,2,0) import GHC.Driver.Env import GHC.Driver.Ppr import GHC.Driver.Session -#if !MIN_VERSION_ghc(9,3,0) -import GHC.Parser.Errors -#else -import GHC.Parser.Errors.Types -#endif -import qualified GHC.Parser.Errors.Ppr as Ppr import qualified GHC.Types.Error as Error import GHC.Types.Name.Ppr import GHC.Types.Name.Reader @@ -71,37 +90,24 @@ (defaultUserStyle) import qualified GHC.Utils.Outputable as Out 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 hiding - (defaultUserStyle) -import qualified 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 hiding - (defaultUserStyle) -import qualified Outputable as Out -import SrcLoc #endif -#if MIN_VERSION_ghc(9,5,0) -import GHC.Driver.Errors.Types (GhcMessage) + +#if MIN_VERSION_ghc(9,2,0) && !MIN_VERSION_ghc(9,3,0) +import GHC.Parser.Errors +import qualified GHC.Parser.Errors.Ppr as Ppr #endif + #if MIN_VERSION_ghc(9,3,0) import Data.Maybe import GHC.Driver.Config.Diagnostic -import GHC.Utils.Logger +import GHC.Parser.Errors.Types #endif #if MIN_VERSION_ghc(9,5,0) +import GHC.Driver.Errors.Types (GhcMessage) +#endif + +#if MIN_VERSION_ghc(9,5,0) type PrintUnqualified = NamePprCtx #endif @@ -221,16 +227,18 @@ #endif mkPrintUnqualifiedDefault :: HscEnv -> GlobalRdrEnv -> PrintUnqualified -mkPrintUnqualifiedDefault env = #if MIN_VERSION_ghc(9,5,0) +mkPrintUnqualifiedDefault env = mkNamePprCtx ptc (hsc_unit_env env) where ptc = initPromotionTickContext (hsc_dflags env) #elif MIN_VERSION_ghc(9,2,0) +mkPrintUnqualifiedDefault env = -- GHC 9.2 version -- mkPrintUnqualified :: UnitEnv -> GlobalRdrEnv -> PrintUnqualified mkPrintUnqualified (hsc_unit_env env) #else +mkPrintUnqualifiedDefault env = HscTypes.mkPrintUnqualified (hsc_dflags env) #endif diff --git a/src/Development/IDE/GHC/Compat/Parser.hs b/src/Development/IDE/GHC/Compat/Parser.hs --- a/src/Development/IDE/GHC/Compat/Parser.hs +++ b/src/Development/IDE/GHC/Compat/Parser.hs @@ -45,46 +45,51 @@ pattern EpaBlockComment ) where -#if MIN_VERSION_ghc(9,0,0) -#if !MIN_VERSION_ghc(9,2,0) -import qualified GHC.Driver.Types as GHC +import Development.IDE.GHC.Compat.Core +import Development.IDE.GHC.Compat.Util + +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] + +#if !MIN_VERSION_ghc(9,0,0) +import qualified ApiAnnotation as Anno +import qualified HscTypes as GHC +import Lexer +import qualified SrcLoc #endif + +#if MIN_VERSION_ghc(9,0,0) import qualified GHC.Parser.Annotation as Anno import qualified GHC.Parser.Lexer as Lexer import GHC.Types.SrcLoc (PsSpan (..)) +#endif + +#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0) +import qualified GHC.Driver.Types as GHC +#endif + +#if !MIN_VERSION_ghc(9,2,0) +import qualified Data.Map as Map +import qualified GHC +#endif + #if MIN_VERSION_ghc(9,2,0) -import GHC (Anchor (anchor), - EpAnnComments (priorComments), - EpaComment (EpaComment), - EpaCommentTok (..), - epAnnComments, +import GHC (EpaCommentTok (..), pm_extra_src_files, pm_mod_summary, pm_parsed_source) import qualified GHC -#if MIN_VERSION_ghc(9,3,0) -import qualified GHC.Driver.Config.Parser as Config -#else -import qualified GHC.Driver.Config as Config -#endif -import GHC.Hs (LEpaComment, hpm_module, - hpm_src_files) -import GHC.Parser.Lexer hiding (initParserState) +import GHC.Hs (hpm_module, hpm_src_files) #endif -#else -import qualified ApiAnnotation as Anno -import qualified HscTypes as GHC -import Lexer -import qualified SrcLoc + +#if MIN_VERSION_ghc(9,2,0) && !MIN_VERSION_ghc(9,3,0) +import qualified GHC.Driver.Config as Config #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 -import qualified GHC +#if MIN_VERSION_ghc(9,3,0) +import qualified GHC.Driver.Config.Parser as Config #endif + #if !MIN_VERSION_ghc(9,0,0) type ParserOpts = DynFlags #elif !MIN_VERSION_ghc(9,2,0) @@ -131,7 +136,7 @@ , hpm_annotations } <- ( (,()) -> (GHC.HsParsedModule{..}, hpm_annotations)) where - HsParsedModule hpm_module hpm_src_files hpm_annotations = + HsParsedModule hpm_module hpm_src_files _hpm_annotations = GHC.HsParsedModule hpm_module hpm_src_files #endif diff --git a/src/Development/IDE/GHC/Compat/Plugins.hs b/src/Development/IDE/GHC/Compat/Plugins.hs --- a/src/Development/IDE/GHC/Compat/Plugins.hs +++ b/src/Development/IDE/GHC/Compat/Plugins.hs @@ -19,33 +19,48 @@ getPsMessages ) where -#if MIN_VERSION_ghc(9,0,0) -#if MIN_VERSION_ghc(9,2,0) -import qualified GHC.Driver.Env as Env +import Development.IDE.GHC.Compat.Core +import Development.IDE.GHC.Compat.Env (hscSetFlags, hsc_dflags) +import Development.IDE.GHC.Compat.Parser as Parser + +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] + +#if !MIN_VERSION_ghc(9,0,0) +import qualified DynamicLoading as Loader +import Plugins #endif + +#if MIN_VERSION_ghc(9,0,0) import GHC.Driver.Plugins (Plugin (..), PluginWithArgs (..), StaticPlugin (..), defaultPlugin, withPlugins) +import qualified GHC.Runtime.Loader as Loader +#endif + +#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,3,0) +import Development.IDE.GHC.Compat.Outputable as Out +#endif + +#if MIN_VERSION_ghc(9,2,0) +import qualified GHC.Driver.Env as Env +#endif + +#if MIN_VERSION_ghc(9,2,0) && !MIN_VERSION_ghc(9,3,0) +import Data.Bifunctor (bimap) +#endif + +#if !MIN_VERSION_ghc(9,3,0) +import Development.IDE.GHC.Compat.Util (Bag) +#endif + #if MIN_VERSION_ghc(9,3,0) import GHC.Driver.Plugins (ParsedResult (..), PsMessages (..), staticPlugins) import qualified GHC.Parser.Lexer as Lexer -#else -import Data.Bifunctor (bimap) #endif -import qualified GHC.Runtime.Loader as Loader -#else -import qualified DynamicLoading as Loader -import Plugins -#endif -import Development.IDE.GHC.Compat.Core -import Development.IDE.GHC.Compat.Env (hscSetFlags, hsc_dflags) -import Development.IDE.GHC.Compat.Outputable as Out -import Development.IDE.GHC.Compat.Parser as Parser -import Development.IDE.GHC.Compat.Util (Bag) #if !MIN_VERSION_ghc(9,3,0) @@ -53,7 +68,7 @@ #endif getPsMessages :: PState -> DynFlags -> PsMessages -getPsMessages pst dflags = +getPsMessages pst _dflags = --dfags is only used if GHC < 9.2 #if MIN_VERSION_ghc(9,3,0) uncurry PsMessages $ Lexer.getPsMessages pst #else @@ -62,12 +77,13 @@ #endif getMessages pst #if !MIN_VERSION_ghc(9,2,0) - dflags + _dflags #endif #endif applyPluginsParsedResultAction :: HscEnv -> DynFlags -> ModSummary -> Parser.ApiAnns -> ParsedSource -> PsMessages -> IO (ParsedSource, PsMessages) -applyPluginsParsedResultAction env dflags ms hpm_annotations parsed msgs = do +applyPluginsParsedResultAction env _dflags ms hpm_annotations parsed msgs = do + -- dflags is only used in GHC < 9.2 -- Apply parsedResultAction of plugins let applyPluginAction p opts = parsedResultAction p opts ms #if MIN_VERSION_ghc(9,3,0) @@ -80,7 +96,7 @@ #elif MIN_VERSION_ghc(9,2,0) env #else - dflags + _dflags #endif applyPluginAction #if MIN_VERSION_ghc(9,3,0) diff --git a/src/Development/IDE/GHC/Compat/Units.hs b/src/Development/IDE/GHC/Compat/Units.hs --- a/src/Development/IDE/GHC/Compat/Units.hs +++ b/src/Development/IDE/GHC/Compat/Units.hs @@ -53,41 +53,19 @@ findImportedModule, ) where -import Control.Monad -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as Map -#if MIN_VERSION_ghc(9,3,0) -import GHC.Unit.Home.ModInfo -#endif -#if MIN_VERSION_ghc(9,0,0) -#if MIN_VERSION_ghc(9,2,0) -import qualified GHC.Data.ShortText as ST -#if !MIN_VERSION_ghc(9,3,0) -import GHC.Driver.Env (hsc_unit_dbs) -#endif -import GHC.Driver.Ppr -import GHC.Unit.Env -import GHC.Unit.External -import GHC.Unit.Finder hiding - (findImportedModule) -#else -import GHC.Driver.Types -#endif -import GHC.Data.FastString -import qualified GHC.Driver.Session as DynFlags -import GHC.Types.Unique.Set -import qualified GHC.Unit.Info as UnitInfo -import GHC.Unit.State (LookupResult, UnitInfo, - UnitState (unitInfoMap)) -import qualified GHC.Unit.State as State -import GHC.Unit.Types hiding (moduleUnit, - toUnitId) -import qualified GHC.Unit.Types as Unit -import GHC.Utils.Outputable -#else +import Data.Either +import Data.Version +import Development.IDE.GHC.Compat.Core +import Development.IDE.GHC.Compat.Env +import Development.IDE.GHC.Compat.Outputable +import Prelude hiding (mod) + +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] + +#if !MIN_VERSION_ghc(9,0,0) import qualified DynFlags import FastString -import GhcPlugins (SDoc, showSDocForUser) +import qualified Finder as GHC import HscTypes import Module hiding (moduleUnitId) import qualified Module @@ -101,26 +79,51 @@ import qualified Packages #endif -import Development.IDE.GHC.Compat.Core -import Development.IDE.GHC.Compat.Env -import Development.IDE.GHC.Compat.Outputable +#if MIN_VERSION_ghc(9,0,0) +import GHC.Types.Unique.Set +import qualified GHC.Unit.Info as UnitInfo +import GHC.Unit.State (LookupResult, UnitInfo, + UnitState (unitInfoMap)) +import qualified GHC.Unit.State as State +import GHC.Unit.Types hiding (moduleUnit, + toUnitId) +import qualified GHC.Unit.Types as Unit +#endif + #if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0) import Data.Map (Map) +import qualified GHC.Driver.Finder as GHC +import qualified GHC.Driver.Session as DynFlags +import GHC.Driver.Types #endif -import Data.Either -import Data.Version -import qualified GHC -#if MIN_VERSION_ghc(9,3,0) -import GHC.Types.PkgQual (PkgQual (NoPkgQual)) +#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,3,0) +import GHC.Data.FastString + #endif -#if MIN_VERSION_ghc(9,1,0) + +#if MIN_VERSION_ghc(9,2,0) +import qualified GHC.Data.ShortText as ST +import GHC.Unit.External import qualified GHC.Unit.Finder as GHC -#elif MIN_VERSION_ghc(9,0,0) -import qualified GHC.Driver.Finder as GHC -#else -import qualified Finder as GHC #endif + +#if MIN_VERSION_ghc(9,2,0) && !MIN_VERSION_ghc(9,3,0) +import GHC.Unit.Env +import GHC.Unit.Finder hiding + (findImportedModule) +#endif + +#if MIN_VERSION_ghc(9,3,0) +import Control.Monad +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map +import qualified GHC +import qualified GHC.Driver.Session as DynFlags +import GHC.Types.PkgQual (PkgQual (NoPkgQual)) +import GHC.Unit.Home.ModInfo +#endif + #if MIN_VERSION_ghc(9,0,0) type PreloadUnitClosure = UniqSet UnitId diff --git a/src/Development/IDE/GHC/Compat/Util.hs b/src/Development/IDE/GHC/Compat/Util.hs --- a/src/Development/IDE/GHC/Compat/Util.hs +++ b/src/Development/IDE/GHC/Compat/Util.hs @@ -69,23 +69,9 @@ atEnd, ) 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 +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -import GHC.Data.FastString -import GHC.Data.Maybe -import GHC.Data.Pair -import GHC.Data.StringBuffer -import GHC.Types.Unique -import GHC.Types.Unique.DFM -import GHC.Utils.Fingerprint -import GHC.Utils.Misc -import GHC.Utils.Outputable (pprHsString) -import GHC.Utils.Panic hiding (try) -#else +#if !MIN_VERSION_ghc(9,0,0) import Bag import BooleanFormula import EnumSet @@ -100,6 +86,27 @@ import UniqDFM import Unique import Util +#endif + +#if MIN_VERSION_ghc(9,0,0) +import Control.Exception.Safe (MonadCatch, catch, try) +import GHC.Data.Bag +import GHC.Data.BooleanFormula +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.Types.Unique.DFM +import GHC.Utils.Fingerprint +import GHC.Utils.Outputable (pprHsString) +import GHC.Utils.Panic hiding (try) +#endif + +#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,3,0) +import GHC.Utils.Misc #endif #if MIN_VERSION_ghc(9,3,0) diff --git a/src/Development/IDE/GHC/CoreFile.hs b/src/Development/IDE/GHC/CoreFile.hs --- a/src/Development/IDE/GHC/CoreFile.hs +++ b/src/Development/IDE/GHC/CoreFile.hs @@ -19,11 +19,26 @@ import Data.IORef import Data.List (isPrefixOf) import Data.Maybe -import qualified Data.Text as T +import qualified Data.Text as T +import Development.IDE.GHC.Compat +import qualified Development.IDE.GHC.Compat.Util as Util import GHC.Fingerprint +import Prelude hiding (mod) -import Development.IDE.GHC.Compat +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] +#if !MIN_VERSION_ghc(9,0,0) +import Binary +import BinFingerprint (fingerprintBinMem) +import BinIface +import CoreSyn +import HscTypes +import IfaceEnv +import MkId +import TcIface +import ToIface +#endif + #if MIN_VERSION_ghc(9,0,0) import GHC.Core import GHC.CoreToIface @@ -33,29 +48,16 @@ import GHC.IfaceToCore import GHC.Types.Id.Make import GHC.Utils.Binary +#endif -#if MIN_VERSION_ghc(9,2,0) -import GHC.Types.TypeEnv -#else +#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0) import GHC.Driver.Types #endif -#else -import Binary -import BinFingerprint (fingerprintBinMem) -import BinIface -import CoreSyn -import HscTypes -import IdInfo -import IfaceEnv -import MkId -import TcIface -import ToIface -import Unique -import Var +#if MIN_VERSION_ghc(9,2,0) +import GHC.Types.TypeEnv #endif -import qualified Development.IDE.GHC.Compat.Util as Util -- | Initial ram buffer to allocate for writing interface files initBinMemSize :: Int @@ -118,7 +120,7 @@ #if MIN_VERSION_ghc(9,2,0) QuietBinIFace #else - (const $ pure ()) + const $ pure () #endif putWithUserData quietTrace bh fat_iface @@ -141,7 +143,7 @@ codeGutsToCoreFile hash CgGuts{..} = CoreFile (map (toIfaceTopBind1 cg_module) cg_binds) hash #else codeGutsToCoreFile hash CgGuts{..} = CoreFile (map (toIfaceTopBind1 cg_module) $ filter isNotImplictBind cg_binds) hash -#endif + -- | Implicit binds can be generated from the interface and are not tidied, -- so we must filter them out isNotImplictBind :: CoreBind -> Bool @@ -150,6 +152,7 @@ bindBindings :: CoreBind -> [Var] bindBindings (NonRec b _) = [b] bindBindings (Rec bnds) = map fst bnds +#endif getImplicitBinds :: TyCon -> [CoreBind] getImplicitBinds tc = cls_binds ++ getTyConImplicitBinds tc @@ -167,14 +170,14 @@ | (op, val_index) <- classAllSelIds cls `zip` [0..] ] get_defn :: Id -> CoreBind -get_defn id = NonRec id (unfoldingTemplate (realIdUnfolding id)) +get_defn identifier = NonRec identifier (unfoldingTemplate (realIdUnfolding identifier)) toIfaceTopBndr1 :: Module -> Id -> IfaceId -toIfaceTopBndr1 mod id - = IfaceId (mangleDeclName mod $ getName id) - (toIfaceType (idType id)) - (toIfaceIdDetails (idDetails id)) - (toIfaceIdInfo (idInfo id)) +toIfaceTopBndr1 mod identifier + = IfaceId (mangleDeclName mod $ getName identifier) + (toIfaceType (idType identifier)) + (toIfaceIdDetails (idDetails identifier)) + (toIfaceIdInfo (idInfo identifier)) toIfaceTopBind1 :: Module -> Bind Id -> TopIfaceBinding IfaceId toIfaceTopBind1 mod (NonRec b r) = TopIfaceNonRec (toIfaceTopBndr1 mod b) (toIfaceExpr r) @@ -224,8 +227,8 @@ pure $ ifid{ ifName = name' } | otherwise = pure ifid -- invariant: 'IfaceId' is always a 'IfaceId' constructor - getIfaceId (AnId id) = id - getIfaceId _ = error "tcIfaceId: got non Id" + getIfaceId (AnId identifier) = identifier + getIfaceId _ = error "tcIfaceId: got non Id" tc_iface_bindings :: TopIfaceBinding Id -> IfL CoreBind tc_iface_bindings (TopIfaceNonRec v e) = do 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 @@ -175,12 +175,12 @@ -- diagnostics catchSrcErrors :: DynFlags -> T.Text -> IO a -> IO (Either [FileDiagnostic] a) catchSrcErrors dflags fromWhere ghcM = do - Compat.handleGhcException (ghcExceptionToDiagnostics dflags) $ - handleSourceError (sourceErrorToDiagnostics dflags) $ + Compat.handleGhcException ghcExceptionToDiagnostics $ + handleSourceError sourceErrorToDiagnostics $ Right <$> ghcM where - ghcExceptionToDiagnostics dflags = return . Left . diagFromGhcException fromWhere dflags - sourceErrorToDiagnostics dflags = return . Left . diagFromErrMsgs fromWhere dflags + ghcExceptionToDiagnostics = return . Left . diagFromGhcException fromWhere dflags + sourceErrorToDiagnostics = return . Left . diagFromErrMsgs fromWhere dflags #if MIN_VERSION_ghc(9,3,0) . fmap (fmap Compat.renderDiagnosticMessageWithHints) . Compat.getMessages #endif 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 @@ -8,49 +8,57 @@ -- | Orphan instances for GHC. -- Note that the 'NFData' instances may not be law abiding. module Development.IDE.GHC.Orphans() where +import Development.IDE.GHC.Compat +import Development.IDE.GHC.Util -#if MIN_VERSION_ghc(9,2,0) -import GHC.Parser.Annotation +import Control.DeepSeq +import Control.Monad.Trans.Reader (ReaderT (..)) +import Data.Aeson +import Data.Hashable +import Data.String (IsString (fromString)) +import Data.Text (unpack) + +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] + +#if !MIN_VERSION_ghc(9,0,0) +import Bag +import ByteCodeTypes +import GhcPlugins hiding (UniqFM) +import qualified StringBuffer as SB +import Unique (getKey) #endif + #if MIN_VERSION_ghc(9,0,0) +import GHC.ByteCode.Types import GHC.Data.Bag import GHC.Data.FastString import qualified GHC.Data.StringBuffer as SB -import GHC.Types.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 +#endif -import Development.IDE.GHC.Compat -import Development.IDE.GHC.Util +#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,3,0) +import GHC (ModuleGraph) +import GHC.Types.Unique (getKey) +#endif -import Control.DeepSeq -import Data.Aeson +#if MIN_VERSION_ghc(9,2,0) import Data.Bifunctor (Bifunctor (..)) -import Data.Hashable -import Data.String (IsString (fromString)) -import Data.Text (unpack) -#if MIN_VERSION_ghc(9,0,0) -import GHC.ByteCode.Types -import GHC (ModuleGraph) -#else -import ByteCodeTypes +import GHC.Parser.Annotation #endif + #if MIN_VERSION_ghc(9,3,0) import GHC.Types.PkgQual #endif + #if MIN_VERSION_ghc(9,5,0) import GHC.Unit.Home.ModInfo #endif +-- Orphan instance for Shake.hs +-- https://hub.darcs.net/ross/transformers/issue/86 +deriving instance (Semigroup (m a)) => Semigroup (ReaderT r m a) + -- Orphan instances for types from the GHC API. instance Show CoreModule where show = unpack . printOutputable instance NFData CoreModule where rnf = rwhnf @@ -241,8 +249,14 @@ rnf = rwhnf #endif -instance NFData (HsExpr (GhcPass 'Renamed)) where +instance NFData (HsExpr (GhcPass Renamed)) where rnf = rwhnf +instance NFData (Pat (GhcPass Renamed)) where + rnf = rwhnf + instance NFData Extension where rnf = rwhnf + +instance NFData (UniqFM Name [Name]) where + rnf (ufmToIntMap -> m) = rnf m 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 @@ -30,25 +30,6 @@ getExtensions ) where -#if MIN_VERSION_ghc(9,2,0) -import GHC.Data.EnumSet -import GHC.Data.FastString -import GHC.Data.StringBuffer -import GHC.Driver.Env hiding (hscSetFlags) -import GHC.Driver.Monad -import GHC.Driver.Session hiding (ExposePackage) -import GHC.Parser.Lexer -import GHC.Runtime.Context -import GHC.Types.Name.Occurrence -import GHC.Types.Name.Reader -import GHC.Types.SrcLoc -import GHC.Unit.Module.ModDetails -import GHC.Unit.Module.ModGuts -import GHC.Utils.Fingerprint -import GHC.Utils.Outputable -#else -import Development.IDE.GHC.Compat.Util -#endif import Control.Concurrent import Control.Exception as E import Data.Binary.Put (Put, runPut) @@ -56,40 +37,43 @@ import Data.ByteString.Internal (ByteString (..)) import qualified Data.ByteString.Internal as BS import qualified Data.ByteString.Lazy as LBS -import Data.Data (Data) 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 Data.Time.Clock.POSIX (POSIXTime, getCurrentTime, - utcTimeToPOSIXSeconds) import Data.Typeable -import qualified Data.Unique as U -import Debug.Trace -import Development.IDE.GHC.Compat as GHC +import Development.IDE.GHC.Compat as GHC hiding (unitState) import qualified Development.IDE.GHC.Compat.Parser as Compat import qualified Development.IDE.GHC.Compat.Units as Compat import Development.IDE.Types.Location import Foreign.ForeignPtr import Foreign.Ptr import Foreign.Storable -import GHC hiding (ParsedModule (..)) +import GHC hiding (ParsedModule (..), + parser) 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 GHC.Stack import Ide.PluginUtils (unescape) -import System.Environment.Blank (getEnvDefault) import System.FilePath -import System.IO.Unsafe -import Text.Printf +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] +#if !MIN_VERSION_ghc(9,2,0) +import Development.IDE.GHC.Compat.Util +#endif + +#if MIN_VERSION_ghc(9,2,0) +import GHC.Data.EnumSet +import GHC.Data.FastString +import GHC.Data.StringBuffer +import GHC.Utils.Fingerprint +#endif ---------------------------------------------------------------------- -- GHC setup @@ -189,9 +173,9 @@ -- Will produce an 8 byte unreadable ByteString. fingerprintToBS :: Fingerprint -> BS.ByteString fingerprintToBS (Fingerprint a b) = BS.unsafeCreate 8 $ \ptr -> do - ptr <- pure $ castPtr ptr - pokeElemOff ptr 0 a - pokeElemOff ptr 1 b + ptr' <- pure $ castPtr ptr + pokeElemOff ptr' 0 a + pokeElemOff ptr' 1 b -- | Take the 'Fingerprint' of a 'StringBuffer'. fingerprintFromStringBuffer :: StringBuffer -> IO Fingerprint diff --git a/src/Development/IDE/Import/DependencyInformation.hs b/src/Development/IDE/Import/DependencyInformation.hs --- a/src/Development/IDE/Import/DependencyInformation.hs +++ b/src/Development/IDE/Import/DependencyInformation.hs @@ -1,5 +1,6 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE CPP #-} module Development.IDE.Import.DependencyInformation ( DependencyInformation(..) @@ -33,7 +34,7 @@ import Data.Bifunctor import Data.Coerce import Data.Either -import Data.Graph +import Data.Graph hiding (edges, path) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HMS import Data.IntMap (IntMap) @@ -48,13 +49,19 @@ import Data.Tuple.Extra hiding (first, second) import Development.IDE.GHC.Orphans () import GHC.Generics (Generic) +import Prelude hiding (mod) import Development.IDE.Import.FindImports (ArtifactsLocation (..)) import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location +import Development.IDE.GHC.Compat + +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] + +#if !MIN_VERSION_ghc(9,3,0) import GHC -import Development.IDE.GHC.Compat +#endif -- | The imports for a given module. newtype ModuleImports = ModuleImports @@ -92,14 +99,14 @@ case HMS.lookup (artifactFilePath path) pathToIdMap of Nothing -> let !newId = FilePathId nextFreshId - in (newId, insertPathId path newId m) - Just id -> (id, m) + in (newId, insertPathId newId ) + Just fileId -> (fileId, m) where - insertPathId :: ArtifactsLocation -> FilePathId -> PathIdMap -> PathIdMap - insertPathId path id PathIdMap{..} = + insertPathId :: FilePathId -> PathIdMap + insertPathId fileId = PathIdMap - (IntMap.insert (getFilePathId id) path idToPathMap) - (HMS.insert (artifactFilePath path) id pathToIdMap) + (IntMap.insert (getFilePathId fileId) path idToPathMap) + (HMS.insert (artifactFilePath path) fileId pathToIdMap) (succ nextFreshId) insertImport :: FilePathId -> Either ModuleParseError ModuleImports -> RawDependencyInformation -> RawDependencyInformation @@ -115,7 +122,7 @@ idToPath pathIdMap filePathId = artifactFilePath $ idToModLocation pathIdMap filePathId idToModLocation :: PathIdMap -> FilePathId -> ArtifactsLocation -idToModLocation PathIdMap{idToPathMap} (FilePathId id) = idToPathMap IntMap.! id +idToModLocation PathIdMap{idToPathMap} (FilePathId i) = idToPathMap IntMap.! i type BootIdMap = FilePathIdMap FilePathId @@ -137,7 +144,7 @@ DependencyInformation { depErrorNodes :: !(FilePathIdMap (NonEmpty NodeError)) -- ^ Nodes that cannot be processed correctly. - , depModules :: !(FilePathIdMap ShowableModule) + , depModules :: !(FilePathIdMap ShowableModule) , depModuleDeps :: !(FilePathIdMap FilePathIdSet) -- ^ For a non-error node, this contains the set of module immediate dependencies -- in the same package. @@ -273,9 +280,9 @@ errorsForCycle files = IntMap.fromListWith (<>) $ coerce $ concatMap (cycleErrorsForFile files) files cycleErrorsForFile :: [FilePathId] -> FilePathId -> [(FilePathId,NodeResult)] - cycleErrorsForFile cycle f = - let entryPoints = mapMaybe (findImport f) cycle - in map (\imp -> (f, ErrorNode (PartOfCycle imp cycle :| []))) entryPoints + cycleErrorsForFile cycles' f = + let entryPoints = mapMaybe (findImport f) cycles' + in map (\imp -> (f, ErrorNode (PartOfCycle imp cycles' :| []))) entryPoints otherErrors = IntMap.map otherErrorsForFile g otherErrorsForFile :: Either ModuleParseError ModuleImports -> NodeResult otherErrorsForFile (Left err) = ErrorNode (ParseError err :| []) 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 @@ -15,7 +15,6 @@ 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 @@ -27,6 +26,13 @@ import Data.List (isSuffixOf) import Data.Maybe import System.FilePath + +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] + +#if !MIN_VERSION_ghc(9,3,0) +import Development.IDE.GHC.Compat.Util +#endif + #if MIN_VERSION_ghc(9,3,0) import GHC.Types.PkgQual import GHC.Unit.State @@ -55,14 +61,14 @@ rnf PackageImport = () modSummaryToArtifactsLocation :: NormalizedFilePath -> Maybe ModSummary -> ArtifactsLocation -modSummaryToArtifactsLocation nfp ms = ArtifactsLocation nfp (ms_location <$> ms) source mod +modSummaryToArtifactsLocation nfp ms = ArtifactsLocation nfp (ms_location <$> ms) source mbMod where isSource HsSrcFile = True isSource _ = False source = case ms of - Nothing -> "-boot" `isSuffixOf` fromNormalizedFilePath nfp - Just ms -> isSource (ms_hsc_src ms) - mod = ms_mod <$> ms + Nothing -> "-boot" `isSuffixOf` fromNormalizedFilePath nfp + Just modSum -> isSource (ms_hsc_src modSum) + mbMod = ms_mod <$> ms -- | locate a module in the file system. Where we go from *daml to Haskell locateModuleFile :: MonadIO m @@ -89,7 +95,7 @@ -- as they can never be imported into another package. #if MIN_VERSION_ghc(9,3,0) mkImportDirs :: HscEnv -> (UnitId, DynFlags) -> Maybe (UnitId, [FilePath]) -mkImportDirs env (i, flags) = Just (i, importPaths flags) +mkImportDirs _env (i, flags) = Just (i, importPaths flags) #else mkImportDirs :: HscEnv -> (UnitId, DynFlags) -> Maybe (PackageName, (UnitId, [FilePath])) mkImportDirs env (i, flags) = (, (i, importPaths flags)) <$> getUnitName env i @@ -130,7 +136,7 @@ | Just (uid, dirs) <- lookup (PackageName pkgName) import_paths -> lookupLocal uid dirs #endif - | otherwise -> lookupInPackageDB env + | otherwise -> lookupInPackageDB #if MIN_VERSION_ghc(9,3,0) NoPkgQual -> do #else @@ -139,7 +145,7 @@ mbFile <- locateModuleFile ((homeUnitId_ dflags, importPaths dflags) : other_imports) exts targetFor isSource $ unLoc modName case mbFile of - Nothing -> lookupInPackageDB env + Nothing -> lookupInPackageDB Just (uid, file) -> toModLocation uid file where dflags = hsc_dflags env @@ -160,7 +166,7 @@ hpt_deps :: [UnitId] hpt_deps = homeUnitDepends units #else - import_paths' + _import_paths' #endif -- first try to find the module as a file. If we can't find it try to find it in the package @@ -168,7 +174,7 @@ -- Here the importPaths for the current modules are added to the front of the import paths from the other components. -- This is particularly important for Paths_* modules which get generated for every component but unless you use it in -- each component will end up being found in the wrong place and cause a multi-cradle match failure. - import_paths' = + _import_paths' = -- import_paths' is only used in GHC < 9.4 #if MIN_VERSION_ghc(9,3,0) import_paths #else @@ -178,19 +184,19 @@ toModLocation uid file = liftIO $ do loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file) #if MIN_VERSION_ghc(9,0,0) - let mod = mkModule (RealUnit $ Definite uid) (unLoc modName) -- TODO support backpack holes + let genMod = mkModule (RealUnit $ Definite uid) (unLoc modName) -- TODO support backpack holes #else - let mod = mkModule uid (unLoc modName) + let genMod = mkModule uid (unLoc modName) #endif - return $ Right $ FileImport $ ArtifactsLocation file (Just loc) (not isSource) (Just mod) + return $ Right $ FileImport $ ArtifactsLocation file (Just loc) (not isSource) (Just genMod) lookupLocal uid dirs = do mbFile <- locateModuleFile [(uid, dirs)] exts targetFor isSource $ unLoc modName case mbFile of Nothing -> return $ Left $ notFoundErr env modName $ LookupNotFound [] - Just (uid, file) -> toModLocation uid file + Just (uid', file) -> toModLocation uid' file - lookupInPackageDB env = do + lookupInPackageDB = do case Compat.lookupModuleWithSuggestions env (unLoc modName) mbPkgName of LookupFound _m _pkgConfig -> return $ Right PackageImport reason -> return $ Left $ notFoundErr env modName reason diff --git a/src/Development/IDE/LSP/HoverDefinition.hs b/src/Development/IDE/LSP/HoverDefinition.hs --- a/src/Development/IDE/LSP/HoverDefinition.hs +++ b/src/Development/IDE/LSP/HoverDefinition.hs @@ -40,7 +40,7 @@ hover = request "Hover" getAtPoint (InR Null) foundHover documentHighlight = request "DocumentHighlight" highlightAtPoint (InR Null) InL -references :: PluginMethodHandler IdeState 'Method_TextDocumentReferences +references :: PluginMethodHandler IdeState Method_TextDocumentReferences references ide _ (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = do nfp <- getNormalizedFilePathE uri liftIO $ logDebug (ideLogger ide) $ @@ -48,7 +48,7 @@ " in file: " <> T.pack (show nfp) InL <$> (liftIO $ runAction "references" ide $ refsAtPoint nfp pos) -wsSymbols :: PluginMethodHandler IdeState 'Method_WorkspaceSymbol +wsSymbols :: PluginMethodHandler IdeState Method_WorkspaceSymbol wsSymbols ide _ (WorkspaceSymbolParams _ _ query) = liftIO $ do logDebug (ideLogger ide) $ "Workspace symbols request: " <> query runIdeAction "WorkspaceSymbols" (shakeExtras ide) $ InL . fromMaybe [] <$> workspaceSymbols query diff --git a/src/Development/IDE/LSP/LanguageServer.hs b/src/Development/IDE/LSP/LanguageServer.hs --- a/src/Development/IDE/LSP/LanguageServer.hs +++ b/src/Development/IDE/LSP/LanguageServer.hs @@ -43,7 +43,6 @@ import qualified Development.IDE.Session as Session import Development.IDE.Types.Shake (WithHieDb) import Ide.Logger -import qualified Ide.Logger as Logger import Language.LSP.Server (LanguageContextEnv, LspServerLog, type (<~>)) @@ -77,8 +76,8 @@ "Reactor thread stopped" LogCancelledRequest requestId -> "Cancelled request" <+> viaShow requestId - LogSession log -> pretty log - LogLspServer log -> pretty log + LogSession msg -> pretty msg + LogLspServer msg -> pretty msg -- used to smuggle RankNType WithHieDb through dbMVar newtype WithHieDbShield = WithHieDbShield WithHieDb @@ -91,12 +90,13 @@ -> Handle -- output -> config -> (config -> Value -> Either T.Text config) + -> (config -> m config ()) -> (MVar () -> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either ResponseError (LSP.LanguageContextEnv config, a)), LSP.Handlers (m config), (LanguageContextEnv config, a) -> m config <~> IO)) -> IO () -runLanguageServer recorder options inH outH defaultConfig onConfigurationChange setup = do +runLanguageServer recorder options inH outH defaultConfig parseConfig onConfigChange setup = do -- This MVar becomes full when the server thread exits or we receive exit message from client. -- LSP server will be canceled when it's full. clientMsgVar <- newEmptyMVar @@ -104,8 +104,11 @@ (doInitialize, staticHandlers, interpretHandler) <- setup clientMsgVar let serverDefinition = LSP.ServerDefinition - { LSP.onConfigurationChange = onConfigurationChange + { LSP.parseConfig = parseConfig + , LSP.onConfigChange = onConfigChange , LSP.defaultConfig = defaultConfig + -- TODO: magic string + , LSP.configSection = "haskell" , LSP.doInitialize = doInitialize , LSP.staticHandlers = (const staticHandlers) , LSP.interpretHandler = interpretHandler @@ -113,10 +116,7 @@ } let lspCologAction :: MonadIO m2 => Colog.LogAction m2 (Colog.WithSeverity LspServerLog) - lspCologAction = toCologActionWithPrio $ cfilter - -- filter out bad logs in lsp, see: https://github.com/haskell/lsp/issues/447 - (\msg -> priority msg >= Info) - (cmapWithPrio LogLspServer recorder) + lspCologAction = toCologActionWithPrio (cmapWithPrio LogLspServer recorder) void $ untilMVar clientMsgVar $ void $ LSP.runServerWithHandles @@ -211,16 +211,16 @@ let initConfig = parseConfiguration params - log Info $ LogRegisteringIdeConfig initConfig + logWith recorder Info $ LogRegisteringIdeConfig initConfig registerIdeConfiguration (shakeExtras ide) initConfig let handleServerException (Left e) = do - log Error $ LogReactorThreadException e + logWith recorder Error $ LogReactorThreadException e exitClientMsg handleServerException (Right _) = pure () exceptionInHandler e = do - log Error $ LogReactorMessageActionException e + logWith recorder Error $ LogReactorMessageActionException e checkCancelled _id act k = flip finally (clearReqId _id) $ @@ -232,15 +232,15 @@ cancelOrRes <- race (waitForCancel _id) act case cancelOrRes of Left () -> do - log Debug $ LogCancelledRequest _id + logWith recorder Debug $ LogCancelledRequest _id k $ ResponseError (InL LSPErrorCodes_RequestCancelled) "" Nothing Right res -> pure res ) $ \(e :: SomeException) -> do exceptionInHandler e k $ ResponseError (InR ErrorCodes_InternalError) (T.pack $ show e) Nothing _ <- flip forkFinally handleServerException $ do - untilMVar lifetime $ runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \withHieDb hieChan -> do - putMVar dbMVar (WithHieDbShield withHieDb,hieChan) + untilMVar lifetime $ runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \withHieDb' hieChan' -> do + putMVar dbMVar (WithHieDbShield withHieDb',hieChan') forever $ do msg <- readChan clientMsgChan -- We dispatch notifications synchronously and requests asynchronously @@ -248,12 +248,8 @@ case msg of ReactorNotification act -> handle exceptionInHandler act ReactorRequest _id act k -> void $ async $ checkCancelled _id act k - log Info LogReactorThreadStopped + logWith recorder Info LogReactorThreadStopped pure $ Right (env,ide) - - where - log :: Logger.Priority -> Log -> IO () - log = logWith recorder -- | Runs the action until it ends or until the given MVar is put. diff --git a/src/Development/IDE/LSP/Notifications.hs b/src/Development/IDE/LSP/Notifications.hs --- a/src/Development/IDE/LSP/Notifications.hs +++ b/src/Development/IDE/LSP/Notifications.hs @@ -32,12 +32,10 @@ import qualified Development.IDE.Core.FileStore as FileStore import Development.IDE.Core.IdeConfiguration import Development.IDE.Core.OfInterest hiding (Log, LogShake) -import Development.IDE.Core.RuleTypes (GetClientSettings (..)) import Development.IDE.Core.Service hiding (Log, LogShake) import Development.IDE.Core.Shake hiding (Log, Priority) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Types.Location -import Development.IDE.Types.Shake (toKey) import Ide.Logger import Ide.Types import Numeric.Natural @@ -49,8 +47,8 @@ instance Pretty Log where pretty = \case - LogShake log -> pretty log - LogFileStore log -> pretty log + LogShake msg -> pretty msg + LogFileStore msg -> pretty msg whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO () whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath' @@ -119,12 +117,9 @@ $ add (foldMap (S.singleton . parseWorkspaceFolder) (_added events)) . substract (foldMap (S.singleton . parseWorkspaceFolder) (_removed events)) - , mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeConfiguration $ - \ide vfs _ (DidChangeConfigurationParams cfg) -> liftIO $ do - let msg = Text.pack $ show cfg - logDebug (ideLogger ide) $ "Configuration changed: " <> msg - modifyClientSettings ide (const $ Just cfg) - setSomethingModified (VFSModified vfs) ide [toKey GetClientSettings emptyFilePath] "config change" + -- Nothing additional to do here beyond what `lsp` does for us, but this prevents + -- complaints about there being no handler defined + , mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeConfiguration mempty , mkPluginNotificationHandler LSP.SMethod_Initialized $ \ide _ _ _ -> do --------- Initialize Shake session -------------------------------------------------------------------- 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 @@ -11,10 +11,8 @@ import Control.Monad.IO.Class import Data.Functor -import Data.Foldable (toList) import Data.Generics hiding (Prefix) import Data.Maybe -import qualified Data.Text as T import Development.IDE.Core.Rules import Development.IDE.Core.Shake import Development.IDE.GHC.Compat @@ -29,12 +27,20 @@ TextDocumentIdentifier (TextDocumentIdentifier), type (|?) (InL, InR), uriToFilePath) import Language.LSP.Protocol.Message + +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] + #if MIN_VERSION_ghc(9,2,0) -import Data.List.NonEmpty (nonEmpty) +import Data.List.NonEmpty (nonEmpty) +import Data.Foldable (toList) #endif +#if !MIN_VERSION_ghc(9,3,0) +import qualified Data.Text as T +#endif + moduleOutline - :: PluginMethodHandler IdeState 'Method_TextDocumentDocumentSymbol + :: PluginMethodHandler IdeState Method_TextDocumentDocumentSymbol moduleOutline ideState _ DocumentSymbolParams{ _textDocument = TextDocumentIdentifier uri } = liftIO $ case uriToFilePath uri of Just (toNormalizedFilePath' -> fp) -> do @@ -89,13 +95,13 @@ , _detail = Just "class" , _children = Just $ - [ (defDocumentSymbol l :: DocumentSymbol) + [ (defDocumentSymbol l' :: DocumentSymbol) { _name = printOutputable n , _kind = SymbolKind_Method - , _selectionRange = realSrcSpanToRange l' + , _selectionRange = realSrcSpanToRange l'' } - | L (locA -> (RealSrcSpan l _)) (ClassOpSig _ False names _) <- tcdSigs - , L (locA -> (RealSrcSpan l' _)) n <- names + | L (locA -> (RealSrcSpan l' _)) (ClassOpSig _ False names _) <- tcdSigs + , L (locA -> (RealSrcSpan l'' _)) n <- names ] } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ DataDecl { tcdLName = L _ name, tcdDataDefn = HsDataDefn { dd_cons } })) @@ -104,28 +110,28 @@ , _kind = SymbolKind_Struct , _children = Just $ - [ (defDocumentSymbol l :: DocumentSymbol) +#if MIN_VERSION_ghc(9,2,0) + [ (defDocumentSymbol l'' :: DocumentSymbol) { _name = printOutputable n , _kind = SymbolKind_Constructor , _selectionRange = realSrcSpanToRange l' -#if MIN_VERSION_ghc(9,2,0) , _children = toList <$> nonEmpty childs } | con <- extract_cons dd_cons , let (cs, flds) = hsConDeclsBinders con , let childs = mapMaybe cvtFld flds , L (locA -> RealSrcSpan l' _) n <- cs - , let l = case con of - L (locA -> RealSrcSpan l _) _ -> l + , let l'' = case con of + L (locA -> RealSrcSpan l''' _) _ -> l''' _ -> l' ] } where cvtFld :: LFieldOcc GhcPs -> Maybe DocumentSymbol #if MIN_VERSION_ghc(9,3,0) - cvtFld (L (locA -> RealSrcSpan l _) n) = Just $ (defDocumentSymbol l :: DocumentSymbol) + cvtFld (L (locA -> RealSrcSpan l' _) n) = Just $ (defDocumentSymbol l' :: DocumentSymbol) #else - cvtFld (L (RealSrcSpan l _) n) = Just $ (defDocumentSymbol l :: DocumentSymbol) + cvtFld (L (RealSrcSpan l' _) n) = Just $ (defDocumentSymbol l' :: DocumentSymbol) #endif #if MIN_VERSION_ghc(9,3,0) { _name = printOutputable (unLoc (foLabel n)) @@ -136,21 +142,25 @@ } cvtFld _ = Nothing #else + [ (defDocumentSymbol l'' :: DocumentSymbol) + { _name = printOutputable n + , _kind = SymbolKind_Constructor + , _selectionRange = realSrcSpanToRange l' , _children = conArgRecordFields (con_args x) } - | L (locA -> (RealSrcSpan l _ )) x <- dd_cons + | L (locA -> (RealSrcSpan l'' _ )) x <- dd_cons , L (locA -> (RealSrcSpan l' _)) n <- getConNames' x ] } where -- | Extract the record fields of a constructor conArgRecordFields (RecCon (L _ lcdfs)) = Just - [ (defDocumentSymbol l :: DocumentSymbol) + [ (defDocumentSymbol l' :: DocumentSymbol) { _name = printOutputable n , _kind = SymbolKind_Field } | L _ cdf <- lcdfs - , L (locA -> (RealSrcSpan l _)) n <- rdrNameFieldOcc . unLoc <$> cd_fld_names cdf + , L (locA -> (RealSrcSpan l' _)) n <- rdrNameFieldOcc . unLoc <$> cd_fld_names cdf ] conArgRecordFields _ = Nothing #endif diff --git a/src/Development/IDE/LSP/Server.hs b/src/Development/IDE/LSP/Server.hs --- a/src/Development/IDE/LSP/Server.hs +++ b/src/Development/IDE/LSP/Server.hs @@ -14,7 +14,7 @@ import Control.Monad.Reader import Development.IDE.Core.Shake import Development.IDE.Core.Tracing -import Ide.Types (HasTracing, traceWithSpan) +import Ide.Types import Language.LSP.Protocol.Message import Language.LSP.Server (Handlers, LspM) import qualified Language.LSP.Server as LSP @@ -30,7 +30,7 @@ deriving (Functor, Applicative, Monad, MonadReader (ReactorChan, IdeState), MonadIO, MonadUnliftIO, LSP.MonadLsp c) requestHandler - :: forall (m :: Method ClientToServer Request) c. (HasTracing (MessageParams m)) => + :: forall m c. PluginMethod Request m => SMethod m -> (IdeState -> MessageParams m -> LspM c (Either ResponseError (MessageResult m))) -> Handlers (ServerM c) @@ -45,7 +45,7 @@ writeChan chan $ ReactorRequest (SomeLspId _id) (trace $ LSP.runLspT env $ resp' =<< k ide _params) (LSP.runLspT env . resp' . Left) notificationHandler - :: forall (m :: Method ClientToServer Notification) c. (HasTracing (MessageParams m)) => + :: forall m c. PluginMethod Notification m => SMethod m -> (IdeState -> VFS -> MessageParams m -> LspM c ()) -> Handlers (ServerM c) diff --git a/src/Development/IDE/Main.hs b/src/Development/IDE/Main.hs --- a/src/Development/IDE/Main.hs +++ b/src/Development/IDE/Main.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE PackageImports #-} {-# OPTIONS_GHC -Wno-orphans #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RankNTypes #-} module Development.IDE.Main (Arguments(..) ,defaultArguments @@ -12,13 +11,18 @@ ,testing ,Log(..) ) where + import Control.Concurrent.Extra (withNumCapabilities) +import Control.Concurrent.MVar (newEmptyMVar, + putMVar, tryReadMVar) import Control.Concurrent.STM.Stats (dumpSTMStats) import Control.Exception.Safe (SomeException, catchAny, displayException) import Control.Monad.Extra (concatMapM, unless, when) +import Control.Monad.IO.Class (liftIO) +import qualified Data.Aeson as J import Data.Coerce (coerce) import Data.Default (Default (def)) import Data.Foldable (traverse_) @@ -30,14 +34,15 @@ import Data.Maybe (catMaybes, isJust) import qualified Data.Text as T import Development.IDE (Action, - GhcVersion (..), Priority (Debug, Error), - Rules, ghcVersion, + Rules, emptyFilePath, hDuplicateTo') import Development.IDE.Core.Debouncer (Debouncer, newAsyncDebouncer) -import Development.IDE.Core.FileStore (isWatchSupported) +import Development.IDE.Core.FileStore (isWatchSupported, + setSomethingModified) import Development.IDE.Core.IdeConfiguration (IdeConfiguration (..), + modifyClientSettings, registerIdeConfiguration) import Development.IDE.Core.OfInterest (FileOfInterestStatus (OnDisk), kick, @@ -77,14 +82,6 @@ import qualified Development.IDE.Session as Session import Development.IDE.Types.Location (NormalizedUri, toNormalizedFilePath') -import Ide.Logger (Logger, - Pretty (pretty), - Priority (Info, Warning), - Recorder, - WithPriority, - cmapWithPrio, - logWith, nest, vsep, - (<+>)) import Development.IDE.Types.Monitoring (Monitoring) import Development.IDE.Types.Options (IdeGhcSession, IdeOptions (optCheckParents, optCheckProject, optReportProgress, optRunSubset), @@ -93,12 +90,20 @@ defaultIdeOptions, optModifyDynFlags, optTesting) -import Development.IDE.Types.Shake (WithHieDb) +import Development.IDE.Types.Shake (WithHieDb, toKey) import GHC.Conc (getNumProcessors) import GHC.IO.Encoding (setLocaleEncoding) import GHC.IO.Handle (hDuplicate) import HIE.Bios.Cradle (findCradle) import qualified HieDb.Run as HieDb +import Ide.Logger (Logger, + Pretty (pretty), + Priority (Info), + Recorder, + WithPriority, + cmapWithPrio, + logDebug, logWith, + nest, vsep, (<+>)) import Ide.Plugin.Config (CheckParents (NeverCheck), Config, checkParents, checkProject, @@ -147,7 +152,7 @@ instance Pretty Log where pretty = \case - LogHeapStats log -> pretty log + LogHeapStats msg -> pretty msg LogLspStart pluginIds -> nest 2 $ vsep [ "Starting LSP server..." @@ -160,13 +165,13 @@ "shouldRunSubset:" <+> pretty shouldRunSubset LogSetInitialDynFlagsException e -> "setInitialDynFlags:" <+> pretty (displayException e) - LogService log -> pretty log - LogShake log -> pretty log - LogGhcIde log -> pretty log - LogLanguageServer log -> pretty log - LogSession log -> pretty log - LogPluginHLS log -> pretty log - LogRules log -> pretty log + LogService msg -> pretty msg + LogShake msg -> pretty msg + LogGhcIde msg -> pretty msg + LogLanguageServer msg -> pretty msg + LogSession msg -> pretty msg + LogPluginHLS msg -> pretty msg + LogRules msg -> pretty msg data Command = Check [FilePath] -- ^ Typecheck some paths and print diagnostics. Exit code is the number of failures @@ -281,9 +286,6 @@ defaultMain :: Recorder (WithPriority Log) -> Arguments -> IO () defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats recorder) fun where - log :: Priority -> Log -> IO () - log = logWith recorder - fun = do setLocaleEncoding utf8 pid <- T.pack . show <$> getProcessID @@ -294,7 +296,7 @@ hlsCommands = allLspCmdIds' pid argsHlsPlugins plugins = hlsPlugin <> argsGhcidePlugin options = argsLspOptions { LSP.optExecuteCommandCommands = LSP.optExecuteCommandCommands argsLspOptions <> Just hlsCommands } - argsOnConfigChange = getConfigFromNotification argsHlsPlugins + argsParseConfig = getConfigFromNotification argsHlsPlugins rules = argsRules >> pluginRules plugins debouncer <- argsDebouncer @@ -306,14 +308,15 @@ case argCommand of LSP -> withNumCapabilities numCapabilities $ do - t <- offsetTime - log Info $ LogLspStart (pluginId <$> ipMap argsHlsPlugins) + ioT <- offsetTime + logWith recorder Info $ LogLspStart (pluginId <$> ipMap argsHlsPlugins) + ideStateVar <- newEmptyMVar let getIdeState :: LSP.LanguageContextEnv Config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState getIdeState env rootPath withHieDb hieChan = do traverse_ IO.setCurrentDirectory rootPath - t <- t - log Info $ LogLspStartDuration t + t <- ioT + logWith recorder Info $ LogLspStartDuration t dir <- maybe IO.getCurrentDirectory return rootPath @@ -322,7 +325,7 @@ _mlibdir <- setInitialDynFlags (cmapWithPrio LogSession recorder) dir argsSessionLoadingOptions -- TODO: should probably catch/log/rethrow at top level instead - `catchAny` (\e -> log Error (LogSetInitialDynFlagsException e) >> pure Nothing) + `catchAny` (\e -> logWith recorder Error (LogSetInitialDynFlagsException e) >> pure Nothing) sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir config <- LSP.runLspT env LSP.getConfig @@ -330,16 +333,16 @@ -- disable runSubset if the client doesn't support watched files runSubset <- (optRunSubset def_options &&) <$> LSP.runLspT env isWatchSupported - log Debug $ LogShouldRunSubset runSubset + logWith recorder Debug $ LogShouldRunSubset runSubset - let options = def_options + let ideOptions = def_options { optReportProgress = clientSupportsProgress caps , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins , optRunSubset = runSubset } caps = LSP.resClientCapabilities env monitoring <- argsMonitoring - initialise + ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins @@ -347,14 +350,28 @@ (Just env) logger debouncer - options + ideOptions withHieDb hieChan monitoring + putMVar ideStateVar ide + pure ide let setup = setupLSP (cmapWithPrio LogLanguageServer recorder) argsGetHieDbLoc (pluginHandlers plugins) getIdeState + -- See Note [Client configuration in Rules] + onConfigChange cfg = do + -- TODO: this is nuts, we're converting back to JSON just to get a fingerprint + let cfgObj = J.toJSON cfg + mide <- liftIO $ tryReadMVar ideStateVar + case mide of + Nothing -> pure () + Just ide -> liftIO $ do + let msg = T.pack $ show cfg + logDebug (Shake.ideLogger ide) $ "Configuration changed: " <> msg + modifyClientSettings ide (const $ Just cfgObj) + setSomethingModified Shake.VFSUnmodified ide [toKey Rules.GetClientSettings emptyFilePath] "config change" - runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsDefaultHlsConfig argsOnConfigChange setup + runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsDefaultHlsConfig argsParseConfig onConfigChange setup dumpSTMStats Check argFiles -> do dir <- maybe IO.getCurrentDirectory return argsProjectRoot @@ -370,11 +387,11 @@ putStrLn $ "\nStep 1/4: Finding files to test in " ++ dir files <- expandFiles (argFiles ++ ["." | null argFiles]) -- LSP works with absolute file paths, so try and behave similarly - files <- nubOrd <$> mapM IO.canonicalizePath files - putStrLn $ "Found " ++ show (length files) ++ " files" + absoluteFiles <- nubOrd <$> mapM IO.canonicalizePath files + putStrLn $ "Found " ++ show (length absoluteFiles) ++ " files" putStrLn "\nStep 2/4: Looking for hie.yaml files that control setup" - cradles <- mapM findCradle files + cradles <- mapM findCradle absoluteFiles let ucradles = nubOrd cradles let n = length ucradles putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1] @@ -382,25 +399,25 @@ putStrLn "\nStep 3/4: Initializing the IDE" sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader - options = def_options + ideOptions = def_options { optCheckParents = pure NeverCheck , optCheckProject = pure False , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins } - ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing logger debouncer options hiedb hieChan mempty + ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing logger debouncer ideOptions hiedb hieChan mempty shakeSessionInit (cmapWithPrio LogShake recorder) ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) putStrLn "\nStep 4/4: Type checking the files" - setFilesOfInterest ide $ HashMap.fromList $ map ((,OnDisk) . toNormalizedFilePath') files - results <- runAction "User TypeCheck" ide $ uses TypeCheck (map toNormalizedFilePath' files) - _results <- runAction "GetHie" ide $ uses GetHieAst (map toNormalizedFilePath' files) - _results <- runAction "GenerateCore" ide $ uses GenerateCore (map toNormalizedFilePath' files) - let (worked, failed) = partition fst $ zip (map isJust results) files + setFilesOfInterest ide $ HashMap.fromList $ map ((,OnDisk) . toNormalizedFilePath') absoluteFiles + results <- runAction "User TypeCheck" ide $ uses TypeCheck (map toNormalizedFilePath' absoluteFiles) + _results <- runAction "GetHie" ide $ uses GetHieAst (map toNormalizedFilePath' absoluteFiles) + _results <- runAction "GenerateCore" ide $ uses GenerateCore (map toNormalizedFilePath' absoluteFiles) + let (worked, failed) = partition fst $ zip (map isJust results) absoluteFiles when (failed /= []) $ putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed - let nfiles xs = let n = length xs in if n == 1 then "1 file" else show n ++ " files" + let nfiles xs = let n' = length xs in if n' == 1 then "1 file" else show n' ++ " files" putStrLn $ "\nCompleted (" ++ nfiles worked ++ " worked, " ++ nfiles failed ++ " failed)" unless (null failed) (exitWith $ ExitFailure (length failed)) @@ -420,12 +437,12 @@ runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \hiedb hieChan -> do sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions "." let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader - options = def_options + ideOptions = def_options { optCheckParents = pure NeverCheck , optCheckProject = pure False , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins } - ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing logger debouncer options hiedb hieChan mempty + ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing logger debouncer ideOptions hiedb hieChan mempty shakeSessionInit (cmapWithPrio LogShake recorder) ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) c ide @@ -437,9 +454,9 @@ then return [x] else do let recurse "." = True - recurse x | "." `isPrefixOf` takeFileName x = False -- skip .git etc - recurse x = takeFileName x `notElem` ["dist", "dist-newstyle"] -- cabal directories - files <- filter (\x -> takeExtension x `elem` [".hs", ".lhs"]) <$> IO.listFilesInside (return . recurse) x + recurse y | "." `isPrefixOf` takeFileName y = False -- skip .git etc + recurse y = takeFileName y `notElem` ["dist", "dist-newstyle"] -- cabal directories + files <- filter (\y -> takeExtension y `elem` [".hs", ".lhs"]) <$> IO.listFilesInside (return . recurse) x when (null files) $ fail $ "Couldn't find any .hs/.lhs files inside directory: " ++ x return files diff --git a/src/Development/IDE/Main/HeapStats.hs b/src/Development/IDE/Main/HeapStats.hs --- a/src/Development/IDE/Main/HeapStats.hs +++ b/src/Development/IDE/Main/HeapStats.hs @@ -19,7 +19,7 @@ deriving Show instance Pretty Log where - pretty log = case log of + pretty = \case LogHeapStatsPeriod period -> "Logging heap statistics every" <+> pretty (toFormattedSeconds period) LogHeapStatsDisabled -> diff --git a/src/Development/IDE/Monitoring/EKG.hs b/src/Development/IDE/Monitoring/EKG.hs --- a/src/Development/IDE/Monitoring/EKG.hs +++ b/src/Development/IDE/Monitoring/EKG.hs @@ -3,6 +3,7 @@ import Development.IDE.Types.Monitoring (Monitoring (..)) import Ide.Logger (Logger) + #ifdef MONITORING_EKG import Control.Concurrent (killThread) import Control.Concurrent.Async (async, waitCatch) diff --git a/src/Development/IDE/Monitoring/OpenTelemetry.hs b/src/Development/IDE/Monitoring/OpenTelemetry.hs --- a/src/Development/IDE/Monitoring/OpenTelemetry.hs +++ b/src/Development/IDE/Monitoring/OpenTelemetry.hs @@ -15,9 +15,9 @@ monitoring | userTracingEnabled = do actions <- newIORef [] - let registerCounter name read = do + let registerCounter name readA = do observer <- mkValueObserver (encodeUtf8 name) - let update = observe observer . fromIntegral =<< read + let update = observe observer . fromIntegral =<< readA atomicModifyIORef'_ actions (update :) registerGauge = registerCounter let start = do 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 @@ -11,11 +11,10 @@ import Control.Concurrent.Async (concurrently) import Control.Concurrent.STM.Stats (readTVarIO) -import Control.Lens ((&), (.~)) +import Control.Lens ((&), (.~), (?~)) import Control.Monad.IO.Class import Control.Monad.Trans.Except (ExceptT (ExceptT), withExceptT) -import Data.Aeson import qualified Data.HashMap.Strict as Map import qualified Data.HashSet as Set import Data.Maybe @@ -25,7 +24,8 @@ import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service hiding (Log, LogShake) -import Development.IDE.Core.Shake hiding (Log) +import Development.IDE.Core.Shake hiding (Log, + knownTargets) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat import Development.IDE.GHC.Util @@ -50,17 +50,24 @@ import Language.LSP.Protocol.Types import qualified Language.LSP.Server as LSP import Numeric.Natural +import Prelude hiding (mod) import Text.Fuzzy.Parallel (Scored (..)) import Development.IDE.Core.Rules (usePropertyAction) -import qualified GHC.LanguageExtensions as LangExt + import qualified Ide.Plugin.Config as Config +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] + +#if MIN_VERSION_ghc(9,2,0) +import qualified GHC.LanguageExtensions as LangExt +#endif + data Log = LogShake Shake.Log deriving Show instance Pretty Log where pretty = \case - LogShake log -> pretty log + LogShake msg -> pretty msg ghcideCompletionsPluginPriority :: Natural ghcideCompletionsPluginPriority = defaultPluginPriority @@ -79,8 +86,8 @@ produceCompletions recorder = do define (cmapWithPrio LogShake recorder) $ \LocalCompletions file -> do let uri = fromNormalizedUri $ normalizedFilePathToUri file - pm <- useWithStale GetParsedModule file - case pm of + mbPm <- useWithStale GetParsedModule file + case mbPm of Just (pm, _) -> do let cdata = localCompletionsForParsedModule uri pm return ([], Just cdata) @@ -90,9 +97,9 @@ -- synthesizing a fake module with an empty body from the buffer -- in the ModSummary, which preserves all the imports ms <- fmap fst <$> useWithStale GetModSummaryWithoutTimestamps file - sess <- fmap fst <$> useWithStale GhcSessionDeps file + mbSess <- fmap fst <$> useWithStale GhcSessionDeps file - case (ms, sess) of + case (ms, mbSess) of (Just ModSummaryResult{..}, Just sess) -> do let env = hscEnv sess -- We do this to be able to provide completions of items that are not restricted to the explicit list @@ -122,7 +129,7 @@ f x = x in f <$> iDecl -resolveCompletion :: ResolveFunction IdeState CompletionResolveData 'Method_CompletionItemResolve +resolveCompletion :: ResolveFunction IdeState CompletionResolveData Method_CompletionItemResolve resolveCompletion ide _pid comp@CompletionItem{_detail,_documentation,_data_} uri (CompletionResolveData _ needType (NameDetails mod occ)) = do file <- getNormalizedFilePathE uri @@ -137,8 +144,8 @@ #endif mdkm <- liftIO $ runIdeAction "CompletionResolve.GetDocMap" (shakeExtras ide) $ useWithStaleFast GetDocMap file let (dm,km) = case mdkm of - Just (DKMap dm km, _) -> (dm,km) - Nothing -> (mempty, mempty) + Just (DKMap docMap kindMap, _) -> (docMap,kindMap) + Nothing -> (mempty, mempty) doc <- case lookupNameEnv dm name of Just doc -> pure $ spanDocToMarkdown doc Nothing -> liftIO $ spanDocToMarkdown <$> getDocumentationTryGhc (hscEnv sess) name @@ -155,13 +162,13 @@ InR $ MarkupContent MarkupKind_Markdown $ T.intercalate sectionSeparator (old:doc) _ -> InR $ MarkupContent MarkupKind_Markdown $ T.intercalate sectionSeparator doc pure (comp & L.detail .~ (det1 <> _detail) - & L.documentation .~ Just doc1) + & L.documentation ?~ doc1) where stripForall ty = case splitForAllTyCoVars ty of (_,res) -> res -- | Generate code actions. -getCompletionsLSP :: PluginMethodHandler IdeState 'Method_TextDocumentCompletion +getCompletionsLSP :: PluginMethodHandler IdeState Method_TextDocumentCompletion getCompletionsLSP ide plId CompletionParams{_textDocument=TextDocumentIdentifier uri ,_position=position @@ -207,7 +214,7 @@ Just (cci', parsedMod, bindMap) -> do let pfix = getCompletionPrefix position cnts case (pfix, completionContext) of - ((PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."}) + (PosPrefixInfo _ "" _ _, Just CompletionContext { _triggerCharacter = Just "."}) -> return (InL []) (_, _) -> do let clientCaps = clientCapabilities $ shakeExtras ide 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 @@ -1,8 +1,8 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedLabels #-} -- Mostly taken from "haskell-ide-engine" module Development.IDE.Plugin.Completions.Logic ( @@ -15,7 +15,8 @@ ) where import Control.Applicative -import Control.Lens hiding (Context) +import Control.Lens hiding (Context, + parts) import Data.Char (isAlphaNum, isUpper) import Data.Default (def) import Data.Generics @@ -23,9 +24,10 @@ (stripPrefix) import qualified Data.Map as Map import Data.Row +import Prelude hiding (mod) -import Data.Maybe (catMaybes, fromMaybe, - isJust, isNothing, +import Data.Maybe (fromMaybe, isJust, + isNothing, listToMaybe, mapMaybe) import qualified Data.Text as T @@ -34,37 +36,22 @@ import Control.Monad import Data.Aeson (ToJSON (toJSON)) import Data.Function (on) -import Data.Functor -import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HashSet import Data.Monoid (First (..)) import Data.Ord (Down (Down)) import qualified Data.Set as Set -import Development.IDE.Core.Compile import Development.IDE.Core.PositionMapping -import Development.IDE.GHC.Compat hiding (ppr) +import Development.IDE.GHC.Compat hiding (isQual, ppr) import qualified Development.IDE.GHC.Compat as GHC import Development.IDE.GHC.Compat.Util import Development.IDE.GHC.CoreFile (occNamePrefixes) import Development.IDE.GHC.Error import Development.IDE.GHC.Util import Development.IDE.Plugin.Completions.Types -import Development.IDE.Spans.Common -import Development.IDE.Spans.Documentation import Development.IDE.Spans.LocalBindings import Development.IDE.Types.Exports -import Development.IDE.Types.HscEnvEq import Development.IDE.Types.Options - -#if MIN_VERSION_ghc(9,2,0) -import GHC.Plugins (Depth (AllTheWay), - defaultSDocContext, - mkUserStyle, - neverQualify, - renderWithContext, - sdocStyle) -#endif import Ide.PluginUtils (mkLspCommand) import Ide.Types (CommandId (..), IdePlugins (..), @@ -76,10 +63,24 @@ original) import qualified Data.Text.Utf16.Rope as Rope -import Development.IDE +import Development.IDE hiding (line) import Development.IDE.Spans.AtPoint (pointCommand) +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] + +#if MIN_VERSION_ghc(9,2,0) +import GHC.Plugins (Depth (AllTheWay), + mkUserStyle, + neverQualify, + sdocStyle) +#endif + +#if MIN_VERSION_ghc(9,2,0) && !MIN_VERSION_ghc(9,3,0) +import GHC.Plugins (defaultSDocContext, + renderWithContext) +#endif + #if MIN_VERSION_ghc(9,5,0) import Language.Haskell.Syntax.Basic #endif @@ -144,12 +145,15 @@ | pos `isInsideSrcSpan` r = Just TypeContext goInline _ = Nothing +#if MIN_VERSION_ghc(9,5,0) importGo :: GHC.LImportDecl GhcPs -> Maybe Context importGo (L (locA -> r) impDecl) | pos `isInsideSrcSpan` r -#if MIN_VERSION_ghc(9,5,0) = importInline importModuleName (fmap (fmap reLoc) $ ideclImportList impDecl) #else + importGo :: GHC.LImportDecl GhcPs -> Maybe Context + importGo (L (locA -> r) impDecl) + | pos `isInsideSrcSpan` r = importInline importModuleName (fmap (fmap reLoc) $ ideclHiding impDecl) #endif <|> Just (ImportContext importModuleName) @@ -160,18 +164,24 @@ -- importInline :: String -> Maybe (Bool, GHC.Located [LIE GhcPs]) -> Maybe Context #if MIN_VERSION_ghc(9,5,0) importInline modName (Just (EverythingBut, L r _)) + | pos `isInsideSrcSpan` r = Just $ ImportHidingContext modName + | otherwise = Nothing #else importInline modName (Just (True, L r _)) -#endif | pos `isInsideSrcSpan` r = Just $ ImportHidingContext modName | otherwise = Nothing +#endif + #if MIN_VERSION_ghc(9,5,0) importInline modName (Just (Exactly, L r _)) + | pos `isInsideSrcSpan` r = Just $ ImportListContext modName + | otherwise = Nothing #else importInline modName (Just (False, L r _)) -#endif | pos `isInsideSrcSpan` r = Just $ ImportListContext modName | otherwise = Nothing +#endif + importInline _ _ = Nothing occNameToComKind :: OccName -> CompletionItemKind @@ -191,7 +201,7 @@ -> IdeOptions -> Uri -> CompItem -> CompletionItem mkCompl pId - IdeOptions {..} + _ideOptions uri CI { compKind, @@ -285,27 +295,27 @@ mkModCompl :: T.Text -> CompletionItem mkModCompl label = - (defaultCompletionItemWithLabel label) - { _kind = Just CompletionItemKind_Module } + defaultCompletionItemWithLabel label + & L.kind ?~ CompletionItemKind_Module mkModuleFunctionImport :: T.Text -> T.Text -> CompletionItem mkModuleFunctionImport moduleName label = - (defaultCompletionItemWithLabel label) - { _kind = Just CompletionItemKind_Function - , _detail = Just moduleName } + defaultCompletionItemWithLabel label + & L.kind ?~ CompletionItemKind_Function + & L.detail ?~ moduleName mkImportCompl :: T.Text -> T.Text -> CompletionItem mkImportCompl enteredQual label = - (defaultCompletionItemWithLabel m) - { _kind = Just CompletionItemKind_Module - , _detail = Just label } + defaultCompletionItemWithLabel m + & L.kind ?~ CompletionItemKind_Module + & L.detail ?~ label where m = fromMaybe "" (T.stripPrefix enteredQual label) mkExtCompl :: T.Text -> CompletionItem mkExtCompl label = - (defaultCompletionItemWithLabel label) - { _kind = Just CompletionItemKind_Keyword } + defaultCompletionItemWithLabel label + & L.kind ?~ CompletionItemKind_Keyword defaultCompletionItemWithLabel :: T.Text -> CompletionItem defaultCompletionItemWithLabel label = @@ -313,14 +323,14 @@ def def def def def def def def def fromIdentInfo :: Uri -> IdentInfo -> Maybe T.Text -> CompItem -fromIdentInfo doc id@IdentInfo{..} q = CI +fromIdentInfo doc identInfo@IdentInfo{..} q = CI { compKind= occNameToComKind name , insertText=rend , provenance = DefinedIn mod , label=rend , typeText = Nothing , isInfix=Nothing - , isTypeCompl= not (isDatacon id) && isUpper (T.head rend) + , isTypeCompl= not (isDatacon identInfo) && isUpper (T.head rend) , additionalTextEdits= Just $ ExtendImport { doc, @@ -332,8 +342,8 @@ , nameDetails = Nothing , isLocalCompletion = False } - where rend = rendered id - mod = moduleNameText id + where rend = rendered identInfo + mod = moduleNameText identInfo cacheDataProducer :: Uri -> [ModuleName] -> Module -> GlobalRdrEnv-> GlobalRdrEnv -> [LImportDecl GhcPs] -> CachedCompletions cacheDataProducer uri visibleMods curMod globalEnv inScopeEnv limports = @@ -396,7 +406,7 @@ in (unqual,QualCompls qual) toCompItem :: Parent -> Module -> T.Text -> Name -> Maybe (LImportDecl GhcPs) -> [CompItem] - toCompItem par m mn n imp' = + toCompItem par _ mn n imp' = -- docs <- getDocumentationTryGhc packageState curMod n let (mbParent, originName) = case par of NoParent -> (Nothing, nameOccName n) @@ -439,34 +449,34 @@ } where typeSigIds = Set.fromList - [ id + [ identifier | L _ (SigD _ (TypeSig _ ids _)) <- hsmodDecls - , L _ id <- ids + , L _ identifier <- ids ] hasTypeSig = (`Set.member` typeSigIds) . unLoc compls = concat [ case decl of SigD _ (TypeSig _ ids typ) -> - [mkComp id CompletionItemKind_Function (Just $ showForSnippet typ) | id <- ids] + [mkComp identifier CompletionItemKind_Function (Just $ showForSnippet typ) | identifier <- ids] ValD _ FunBind{fun_id} -> [ mkComp fun_id CompletionItemKind_Function Nothing | not (hasTypeSig fun_id) ] ValD _ PatBind{pat_lhs} -> - [mkComp id CompletionItemKind_Variable Nothing - | VarPat _ id <- listify (\(_ :: Pat GhcPs) -> True) pat_lhs] + [mkComp identifier CompletionItemKind_Variable Nothing + | VarPat _ identifier <- listify (\(_ :: Pat GhcPs) -> True) pat_lhs] TyClD _ ClassDecl{tcdLName, tcdSigs, tcdATs} -> mkComp tcdLName CompletionItemKind_Interface (Just $ showForSnippet tcdLName) : - [ mkComp id CompletionItemKind_Function (Just $ showForSnippet typ) + [ mkComp identifier CompletionItemKind_Function (Just $ showForSnippet typ) | L _ (ClassOpSig _ _ ids typ) <- tcdSigs - , id <- ids] ++ + , identifier <- ids] ++ [ mkComp fdLName CompletionItemKind_Struct (Just $ showForSnippet fdLName) | L _ (FamilyDecl{fdLName}) <- tcdATs] TyClD _ x -> - let generalCompls = [mkComp id cl (Just $ showForSnippet $ tyClDeclLName x) - | id <- listify (\(_ :: LIdP GhcPs) -> True) x - , let cl = occNameToComKind (rdrNameOcc $ unLoc id)] + let generalCompls = [mkComp identifier cl (Just $ showForSnippet $ tyClDeclLName x) + | identifier <- listify (\(_ :: LIdP GhcPs) -> True) x + , let cl = occNameToComKind (rdrNameOcc $ unLoc identifier)] -- here we only have to look at the outermost type recordCompls = findRecordCompl uri (Local pos) x in @@ -670,9 +680,9 @@ | otherwise = ((qual,) <$> Map.findWithDefault [] prefixScope (getQualCompls qualCompls)) ++ map (\compl -> (notQual, compl (Just prefixScope))) anyQualCompls - filtListWith f list = + filtListWith f xs = [ fmap f label - | label <- Fuzzy.simpleFilter chunkSize maxC fullPrefix list + | label <- Fuzzy.simpleFilter chunkSize maxC fullPrefix xs , enteredQual `T.isPrefixOf` original label ] 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 @@ -19,17 +19,24 @@ import Data.Typeable (Typeable) import Development.IDE.GHC.Compat import Development.IDE.Graph (RuleResult) -import Development.IDE.Spans.Common +import Development.IDE.Spans.Common () import GHC.Generics (Generic) import Ide.Plugin.Properties import Language.LSP.Protocol.Types (CompletionItemKind (..), Uri) import qualified Language.LSP.Protocol.Types as J + +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] + +#if !MIN_VERSION_ghc(9,0,0) +import qualified OccName as Occ +#endif + #if MIN_VERSION_ghc(9,0,0) import qualified GHC.Types.Name.Occurrence as Occ -#else -import qualified OccName as Occ #endif + + -- | Produce completions info for a file type instance RuleResult LocalCompletions = CachedCompletions type instance RuleResult NonLocalCompletions = CachedCompletions @@ -53,8 +60,8 @@ extendImportCommandId = "extendImport" properties :: Properties - '[ 'PropertyKey "autoExtendOn" 'TBoolean, - 'PropertyKey "snippetsOn" 'TBoolean] + '[ 'PropertyKey "autoExtendOn" TBoolean, + 'PropertyKey "snippetsOn" TBoolean] properties = emptyProperties & defineBooleanProperty #snippetsOn "Inserts snippets when using code completions" @@ -200,7 +207,7 @@ instance Show NameDetails where show = show . toJSON --- | The data that is acutally sent for resolve support +-- | The data that is actually sent for resolve support -- We need the URI to be able to reconstruct the GHC environment -- in the file the completion was triggered in. data CompletionResolveData = CompletionResolveData diff --git a/src/Development/IDE/Plugin/HLS.hs b/src/Development/IDE/Plugin/HLS.hs --- a/src/Development/IDE/Plugin/HLS.hs +++ b/src/Development/IDE/Plugin/HLS.hs @@ -11,7 +11,6 @@ ) where import Control.Exception (SomeException) -import Control.Lens ((^.)) import Control.Monad import Control.Monad.Trans.Except (runExceptT) import qualified Data.Aeson as A @@ -39,7 +38,6 @@ import Ide.Plugin.Error import Ide.PluginUtils (getClientConfig) import Ide.Types as HLS -import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types import qualified Language.LSP.Server as LSP @@ -65,22 +63,15 @@ LogPluginError (PluginId pId) err -> pretty pId <> ":" <+> pretty err LogResponseError (PluginId pId) err -> - pretty pId <> ":" <+> prettyResponseError err + pretty pId <> ":" <+> pretty err LogNoPluginForMethod (Some method) -> - "No plugin enabled for " <> pretty (show method) + "No plugin enabled for " <> pretty method LogInvalidCommandIdentifier-> "Invalid command identifier" ExceptionInPlugin plId (Some method) exception -> "Exception in plugin " <> viaShow plId <> " while processing " - <> viaShow method <> ": " <> viaShow exception + <> pretty method <> ": " <> viaShow exception instance Show Log where show = renderString . layoutCompact . pretty --- various error message specific builders -prettyResponseError :: ResponseError -> Doc a -prettyResponseError err = errorCode <> ":" <+> errorBody - where - errorCode = pretty $ show $ err ^. L.code - errorBody = pretty $ err ^. L.message - noPluginEnabled :: Recorder (WithPriority Log) -> SMethod m -> [PluginId] -> IO (Either ResponseError c) noPluginEnabled recorder m fs' = do logWith recorder Warning (LogNoPluginForMethod $ Some m) @@ -91,7 +82,7 @@ pluginNotEnabled method availPlugins = "No plugin enabled for " <> T.pack (show method) <> ", potentially available: " <> (T.intercalate ", " $ map (\(PluginId plid) -> plid) availPlugins) - + pluginDoesntExist :: PluginId -> Text pluginDoesntExist (PluginId pid) = "Plugin " <> pid <> " doesn't exist" @@ -232,9 +223,9 @@ -- --------------------------------------------------------------------- extensiblePlugins :: Recorder (WithPriority Log) -> [(PluginId, PluginDescriptor IdeState)] -> Plugin Config -extensiblePlugins recorder xs = mempty { P.pluginHandlers = handlers } +extensiblePlugins recorder plugins = mempty { P.pluginHandlers = handlers } where - IdeHandlers handlers' = foldMap bakePluginId xs + IdeHandlers handlers' = foldMap bakePluginId plugins bakePluginId :: (PluginId, PluginDescriptor IdeState) -> IdeHandlers bakePluginId (pid,pluginDesc) = IdeHandlers $ DMap.map (\(PluginHandler f) -> IdeHandler [(pid,pluginDesc,f pid)]) @@ -250,11 +241,11 @@ -- Clients generally don't display ResponseErrors so instead we log any that we come across case nonEmpty fs of Nothing -> liftIO $ noPluginEnabled recorder m ((\(x, _, _) -> x) <$> fs') - Just fs -> do - let handlers = fmap (\(plid,_,handler) -> (plid,handler)) fs - es <- runConcurrently exceptionInPlugin m handlers ide params + Just neFs -> do + let plidsAndHandlers = fmap (\(plid,_,handler) -> (plid,handler)) neFs + es <- runConcurrently exceptionInPlugin m plidsAndHandlers ide params caps <- LSP.getClientCapabilities - let (errs,succs) = partitionEithers $ toList $ join $ NE.zipWith (\(pId,_) -> fmap (first (pId,))) handlers es + let (errs,succs) = partitionEithers $ toList $ join $ NE.zipWith (\(pId,_) -> fmap (first (pId,))) plidsAndHandlers es liftIO $ unless (null errs) $ logErrors recorder errs case nonEmpty succs of Nothing -> do @@ -288,12 +279,12 @@ case nonEmpty fs of Nothing -> do logWith recorder Warning (LogNoPluginForMethod $ Some m) - Just fs -> do + Just neFs -> do -- We run the notifications in order, so the core ghcide provider -- (which restarts the shake process) hopefully comes last mapM_ (\(pid,_,f) -> otTracedProvider pid (fromString $ show m) $ f ide vfs params `catchAny` -- See Note [Exception handling in plugins] - (\e -> logWith recorder Warning (ExceptionInPlugin pid (Some m) e))) fs + (\e -> logWith recorder Warning (ExceptionInPlugin pid (Some m) e))) neFs -- --------------------------------------------------------------------- @@ -344,14 +335,14 @@ instance Semigroup IdeHandlers where (IdeHandlers a) <> (IdeHandlers b) = IdeHandlers $ DMap.unionWithKey go a b where - go _ (IdeHandler a) (IdeHandler b) = IdeHandler (a <> b) + go _ (IdeHandler c) (IdeHandler d) = IdeHandler (c <> d) instance Monoid IdeHandlers where mempty = IdeHandlers mempty instance Semigroup IdeNotificationHandlers where (IdeNotificationHandlers a) <> (IdeNotificationHandlers b) = IdeNotificationHandlers $ DMap.unionWithKey go a b where - go _ (IdeNotificationHandler a) (IdeNotificationHandler b) = IdeNotificationHandler (a <> b) + go _ (IdeNotificationHandler c) (IdeNotificationHandler d) = IdeNotificationHandler (c <> d) instance Monoid IdeNotificationHandlers where mempty = IdeNotificationHandlers mempty diff --git a/src/Development/IDE/Plugin/HLS/GhcIde.hs b/src/Development/IDE/Plugin/HLS/GhcIde.hs --- a/src/Development/IDE/Plugin/HLS/GhcIde.hs +++ b/src/Development/IDE/Plugin/HLS/GhcIde.hs @@ -27,9 +27,9 @@ instance Pretty Log where pretty = \case - LogNotifications log -> pretty log - LogCompletions log -> pretty log - LogTypeLenses log -> pretty log + LogNotifications msg -> pretty msg + LogCompletions msg -> pretty msg + LogTypeLenses msg -> pretty msg descriptors :: Recorder (WithPriority Log) -> [PluginDescriptor IdeState] descriptors recorder = @@ -59,7 +59,7 @@ -- --------------------------------------------------------------------- -hover' :: PluginMethodHandler IdeState 'Method_TextDocumentHover +hover' :: PluginMethodHandler IdeState Method_TextDocumentHover hover' ideState _ HoverParams{..} = do liftIO $ logDebug (ideLogger ideState) "GhcIde.hover entered (ideLogger)" -- AZ hover ideState TextDocumentPositionParams{..} 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 @@ -46,7 +46,6 @@ import Development.IDE.Types.HscEnvEq (HscEnvEq (hscEnv)) import Development.IDE.Types.Location (fromUri) import GHC.Generics (Generic) -import Ide.Plugin.Config (CheckParents) import Ide.Plugin.Error import Ide.Types import Language.LSP.Protocol.Message 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 @@ -15,28 +15,29 @@ import Control.Concurrent.STM.Stats (atomically) import Control.DeepSeq (rwhnf) +import Control.Lens ((?~)) import Control.Monad (mzero) import Control.Monad.Extra (whenMaybe) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Class (MonadTrans (lift)) -import Data.Aeson.Types (Value, toJSON) +import Data.Aeson.Types (toJSON) import qualified Data.Aeson.Types as A import Data.List (find) import qualified Data.Map as Map -import Data.Maybe (catMaybes, mapMaybe) +import Data.Maybe (catMaybes, maybeToList) import qualified Data.Text as T import Development.IDE (GhcSession (..), HscEnvEq (hscEnv), - RuleResult, Rules, + RuleResult, Rules, Uri, define, srcSpanToRange, usePropertyAction) import Development.IDE.Core.Compile (TcModuleResult (..)) import Development.IDE.Core.PluginUtils import Development.IDE.Core.PositionMapping (PositionMapping, + fromCurrentRange, toCurrentRange) import Development.IDE.Core.Rules (IdeState, runAction) -import Development.IDE.Core.RuleTypes (GetBindings (GetBindings), - TypeCheck (TypeCheck)) +import Development.IDE.Core.RuleTypes (TypeCheck (TypeCheck)) import Development.IDE.Core.Service (getDiagnostics) import Development.IDE.Core.Shake (getHiddenDiagnostics, use) @@ -44,8 +45,7 @@ import Development.IDE.GHC.Compat import Development.IDE.GHC.Util (printName) import Development.IDE.Graph.Classes -import Development.IDE.Spans.LocalBindings (Bindings, getFuzzyScope) -import Development.IDE.Types.Location (Position (Position, _character, _line), +import Development.IDE.Types.Location (Position (Position, _line), Range (Range, _end, _start)) import GHC.Generics (Generic) import Ide.Logger (Pretty (pretty), @@ -60,31 +60,35 @@ PluginDescriptor (..), PluginId, PluginMethodHandler, + ResolveFunction, configCustomConfig, defaultConfigDescriptor, defaultPluginDescriptor, mkCustomConfig, - mkPluginHandler) -import Language.LSP.Protocol.Message (Method (Method_TextDocumentCodeLens), + mkPluginHandler, + mkResolveHandler) +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message (Method (Method_CodeLensResolve, Method_TextDocumentCodeLens), SMethod (..)) import Language.LSP.Protocol.Types (ApplyWorkspaceEditParams (ApplyWorkspaceEditParams), - CodeLens (CodeLens), + CodeLens (..), CodeLensParams (CodeLensParams, _textDocument), - Diagnostic (..), + Command, Diagnostic (..), Null (Null), TextDocumentIdentifier (TextDocumentIdentifier), TextEdit (TextEdit), WorkspaceEdit (WorkspaceEdit), type (|?) (..)) import qualified Language.LSP.Server as LSP -import Text.Regex.TDFA ((=~), (=~~)) +import Text.Regex.TDFA ((=~)) data Log = LogShake Shake.Log deriving Show instance Pretty Log where pretty = \case - LogShake log -> pretty log + LogShake msg -> pretty msg + typeLensCommandId :: T.Text typeLensCommandId = "typesignature.add" @@ -92,12 +96,13 @@ descriptor recorder plId = (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeLens codeLensProvider + <> mkResolveHandler SMethod_CodeLensResolve codeLensResolveProvider , pluginCommands = [PluginCommand (CommandId typeLensCommandId) "adds a signature" commandHandler] , pluginRules = rules recorder , pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties} } -properties :: Properties '[ 'PropertyKey "mode" ('TEnum Mode)] +properties :: Properties '[ 'PropertyKey "mode" (TEnum Mode)] properties = emptyProperties & defineEnumProperty #mode "Control how type lenses are shown" [ (Always, "Always displays type lenses of global bindings") @@ -109,97 +114,115 @@ codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentifier uri} = do mode <- liftIO $ runAction "codeLens.config" ideState $ usePropertyAction #mode pId properties nfp <- getNormalizedFilePathE uri - env <- hscEnv . fst <$> - runActionE "codeLens.GhcSession" ideState - (useWithStaleE GhcSession nfp) - - (tmr, _) <- runActionE "codeLens.TypeCheck" ideState - (useWithStaleE TypeCheck nfp) - - (bindings, _) <- runActionE "codeLens.GetBindings" ideState - (useWithStaleE GetBindings nfp) - - (gblSigs@(GlobalBindingTypeSigsResult gblSigs'), gblSigsMp) <- - runActionE "codeLens.GetGlobalBindingTypeSigs" ideState - (useWithStaleE GetGlobalBindingTypeSigs nfp) - - diag <- liftIO $ atomically $ getDiagnostics ideState - hDiag <- liftIO $ atomically $ getHiddenDiagnostics ideState + -- We have two ways we can possibly generate code lenses for type lenses. + -- Different options are with different "modes" of the type-lenses plugin. + -- (Remember here, as the code lens is not resolved yet, we only really need + -- the range and any data that will help us resolve it later) + let -- The first option is to generate lens from diagnostics about + -- top level bindings. + generateLensFromGlobalDiags diags = + -- We don't actually pass any data to resolve, however we need this + -- dummy type to make sure HLS resolves our lens + [ CodeLens _range Nothing (Just $ toJSON TypeLensesResolve) + | (dFile, _, diag@Diagnostic{_range}) <- diags + , dFile == nfp + , isGlobalDiagnostic diag] + -- The second option is to generate lenses from the GlobalBindingTypeSig + -- rule. This is the only type that needs to have the range adjusted + -- with PositionMapping. + -- PositionMapping for diagnostics doesn't make sense, because we always + -- have fresh diagnostics even if current module parsed failed (the + -- diagnostic would then be parse failed). See + -- https://github.com/haskell/haskell-language-server/pull/3558 for this + -- discussion. + generateLensFromGlobal sigs mp = do + [ CodeLens newRange Nothing (Just $ toJSON TypeLensesResolve) + | sig <- sigs + , Just range <- [srcSpanToRange (gbSrcSpan sig)] + , Just newRange <- [toCurrentRange mp range]] + if mode == Always || mode == Exported + then do + -- In this mode we get the global bindings from the + -- GlobalBindingTypeSigs rule. + (GlobalBindingTypeSigsResult gblSigs, gblSigsMp) <- + runActionE "codeLens.GetGlobalBindingTypeSigs" ideState + $ useWithStaleE GetGlobalBindingTypeSigs nfp + -- Depending on whether we only want exported or not we filter our list + -- of signatures to get what we want + let relevantGlobalSigs = + if mode == Exported + then filter gbExported gblSigs + else gblSigs + pure $ InL $ generateLensFromGlobal relevantGlobalSigs gblSigsMp + else do + -- For this mode we exclusively use diagnostics to create the lenses. + -- However we will still use the GlobalBindingTypeSigs to resolve them. + diags <- liftIO $ atomically $ getDiagnostics ideState + hDiags <- liftIO $ atomically $ getHiddenDiagnostics ideState + let allDiags = diags <> hDiags + pure $ InL $ generateLensFromGlobalDiags allDiags - let toWorkSpaceEdit tedit = WorkspaceEdit (Just $ Map.singleton uri $ tedit) Nothing Nothing - generateLensForGlobal mp sig@GlobalBindingTypeSig{gbRendered} = do - range <- toCurrentRange mp =<< srcSpanToRange (gbSrcSpan sig) - tedit <- gblBindingTypeSigToEdit sig (Just gblSigsMp) - let wedit = toWorkSpaceEdit [tedit] - pure $ generateLens pId range (T.pack gbRendered) wedit - generateLensFromDiags f = - [ generateLens pId _range title edit - | (dFile, _, dDiag@Diagnostic{_range = _range}) <- diag ++ hDiag - , dFile == nfp - , (title, tedit) <- f dDiag - , let edit = toWorkSpaceEdit tedit - ] - -- `suggestLocalSignature` relies on diagnostic, if diagnostics don't have the local signature warning, - -- the `bindings` is useless, and if diagnostic has, that means we parsed success, and the `bindings` is fresh. - pure $ InL $ case mode of - Always -> - mapMaybe (generateLensForGlobal gblSigsMp) gblSigs' - <> generateLensFromDiags - (suggestLocalSignature False (Just env) (Just tmr) (Just bindings)) -- we still need diagnostics for local bindings - Exported -> mapMaybe (generateLensForGlobal gblSigsMp) (filter gbExported gblSigs') - Diagnostics -> generateLensFromDiags - $ suggestSignature False (Just env) (Just gblSigs) (Just tmr) (Just bindings) +codeLensResolveProvider :: ResolveFunction IdeState TypeLensesResolve Method_CodeLensResolve +codeLensResolveProvider ideState pId lens@CodeLens{_range} uri TypeLensesResolve = do + nfp <- getNormalizedFilePathE uri + (gblSigs@(GlobalBindingTypeSigsResult _), pm) <- + runActionE "codeLens.GetGlobalBindingTypeSigs" ideState + $ useWithStaleE GetGlobalBindingTypeSigs nfp + -- regardless of how the original lens was generated, we want to get the range + -- that the global bindings rule would expect here, hence the need to reverse + -- position map the range, regardless of whether it was position mapped in the + -- beginning or freshly taken from diagnostics. + newRange <- handleMaybe PluginStaleResolve (fromCurrentRange pm _range) + -- We also pass on the PositionMapping so that the generated text edit can + -- have the range adjusted. + (title, edit) <- + handleMaybe PluginStaleResolve $ suggestGlobalSignature' False (Just gblSigs) (Just pm) newRange + pure $ lens & L.command ?~ generateLensCommand pId uri title edit -generateLens :: PluginId -> Range -> T.Text -> WorkspaceEdit -> CodeLens -generateLens pId _range title edit = - let cId = mkLspCommand pId (CommandId typeLensCommandId) title (Just [toJSON edit]) - in CodeLens _range (Just cId) Nothing +generateLensCommand :: PluginId -> Uri -> T.Text -> TextEdit -> Command +generateLensCommand pId uri title edit = + let wEdit = WorkspaceEdit (Just $ Map.singleton uri $ [edit]) Nothing Nothing + in mkLspCommand pId (CommandId typeLensCommandId) title (Just [toJSON wEdit]) +-- Since the lenses are created with diagnostics, and since the globalTypeSig +-- rule can't be changed as it is also used by the hls-refactor plugin, we can't +-- rely on actions. Because we can't rely on actions it doesn't make sense to +-- recompute the edit upon command. Hence the command here just takes a edit +-- and applies it. commandHandler :: CommandFunction IdeState WorkspaceEdit commandHandler _ideState wedit = do _ <- lift $ LSP.sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) pure $ InR Null -------------------------------------------------------------------------------- +suggestSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> Diagnostic -> [(T.Text, TextEdit)] +suggestSignature isQuickFix mGblSigs diag = + maybeToList (suggestGlobalSignature isQuickFix mGblSigs diag) -suggestSignature :: Bool -> Maybe HscEnv -> Maybe GlobalBindingTypeSigsResult -> Maybe TcModuleResult -> Maybe Bindings -> Diagnostic -> [(T.Text, [TextEdit])] -suggestSignature isQuickFix env mGblSigs mTmr mBindings diag = - suggestGlobalSignature isQuickFix mGblSigs diag <> suggestLocalSignature isQuickFix env mTmr mBindings diag +-- The suggestGlobalSignature is separated into two functions. The main function +-- works with a diagnostic, which then calls the secondary function with +-- whatever pieces of the diagnostic it needs. This allows the resolve function, +-- which no longer has the Diagnostic, to still call the secondary functions. +suggestGlobalSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> Diagnostic -> Maybe (T.Text, TextEdit) +suggestGlobalSignature isQuickFix mGblSigs diag@Diagnostic{_range} + | isGlobalDiagnostic diag = + suggestGlobalSignature' isQuickFix mGblSigs Nothing _range + | otherwise = Nothing -suggestGlobalSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> Diagnostic -> [(T.Text, [TextEdit])] -suggestGlobalSignature isQuickFix mGblSigs Diagnostic{_message, _range} - | _message - =~ ("(Top-level binding|Pattern synonym) with no type signature" :: T.Text) - , Just (GlobalBindingTypeSigsResult sigs) <- mGblSigs - , Just sig <- find (\x -> sameThing (gbSrcSpan x) _range) sigs - , signature <- T.pack $ gbRendered sig - , title <- if isQuickFix then "add signature: " <> signature else signature - , Just action <- gblBindingTypeSigToEdit sig Nothing = - [(title, [action])] - | otherwise = [] +isGlobalDiagnostic :: Diagnostic -> Bool +isGlobalDiagnostic Diagnostic{_message} = _message =~ ("(Top-level binding|Pattern synonym) with no type signature" :: T.Text) -suggestLocalSignature :: Bool -> Maybe HscEnv -> Maybe TcModuleResult -> Maybe Bindings -> Diagnostic -> [(T.Text, [TextEdit])] -suggestLocalSignature isQuickFix mEnv mTmr mBindings Diagnostic{_message, _range = _range@Range{..}} - | Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, [identifier]) <- - (T.unwords . T.words $ _message) - =~~ ("Polymorphic local binding with no type signature: (.*) ::" :: T.Text) - , Just bindings <- mBindings - , Just env <- mEnv - , localScope <- getFuzzyScope bindings _start _end - , -- we can't use srcspan to lookup scoped bindings, because the error message reported by GHC includes the entire binding, instead of simply the name - Just (name, ty) <- find (\(x, _) -> printName x == T.unpack identifier) localScope >>= \(name, mTy) -> (name,) <$> mTy - , 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 env tcg_rdr_env) $ pprSigmaType ty - , signature <- T.pack $ printName name <> " :: " <> tyMsg - , startCharacter <- _character _start - , startOfLine <- Position (_line _start) startCharacter - , beforeLine <- Range startOfLine startOfLine +-- If a PositionMapping is supplied, this function will call +-- gblBindingTypeSigToEdit with it to create a TextEdit in the right location. +suggestGlobalSignature' :: Bool -> Maybe GlobalBindingTypeSigsResult -> Maybe PositionMapping -> Range -> Maybe (T.Text, TextEdit) +suggestGlobalSignature' isQuickFix mGblSigs pm range + | Just (GlobalBindingTypeSigsResult sigs) <- mGblSigs + , Just sig <- find (\x -> sameThing (gbSrcSpan x) range) sigs + , signature <- T.pack $ gbRendered sig , title <- if isQuickFix then "add signature: " <> signature else signature - , action <- TextEdit beforeLine $ signature <> "\n" <> T.replicate (fromIntegral startCharacter) " " = - [(title, [action])] - | otherwise = [] + , Just action <- gblBindingTypeSigToEdit sig pm = + Just (title, action) + | otherwise = Nothing sameThing :: SrcSpan -> Range -> Bool sameThing s1 s2 = (_start <$> srcSpanToRange s1) == (_start <$> Just s2) @@ -209,12 +232,20 @@ | Just Range{..} <- srcSpanToRange $ getSrcSpan gbName , startOfLine <- Position (_line _start) 0 , beforeLine <- Range startOfLine startOfLine - -- If `mmp` is `Nothing`, return the original range, it used by lenses from diagnostic, + -- If `mmp` is `Nothing`, return the original range, -- otherwise we apply `toCurrentRange`, and the guard should fail if `toCurrentRange` failed. , Just range <- maybe (Just beforeLine) (flip toCurrentRange beforeLine) mmp - = Just $ TextEdit range $ T.pack gbRendered <> "\n" + -- We need to flatten the signature, as otherwise long signatures are + -- rendered on multiple lines with invalid formatting. + , renderedFlat <- unwords $ lines gbRendered + = Just $ TextEdit range $ T.pack renderedFlat <> "\n" | otherwise = Nothing +-- |We don't need anything to resolve our lens, but a data field is mandatory +-- to get types resolved in HLS +data TypeLensesResolve = TypeLensesResolve + deriving (Generic, A.FromJSON, A.ToJSON) + data Mode = -- | always displays type lenses of global bindings, no matter what GHC flags are set Always @@ -282,11 +313,11 @@ showDoc = showDocRdrEnv hsc rdrEnv hasSig :: (Monad m) => Name -> m a -> m (Maybe a) hasSig name f = whenMaybe (name `elemNameSet` sigs) f - bindToSig id = do - let name = idName id + bindToSig identifier = do + let name = idName identifier hasSig name $ do env <- tcInitTidyEnv - let (_, ty) = tidyOpenType env (idType id) + let (_, ty) = tidyOpenType env (idType identifier) pure $ GlobalBindingTypeSig name (printName name <> " :: " <> showDoc (pprSigmaType ty)) (name `elemNameSet` exports) patToSig p = do let name = patSynName p 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,6 +30,7 @@ import Development.IDE.Types.Location import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..)) +import Prelude hiding (mod) -- compiler and infrastructure import Development.IDE.Core.PositionMapping @@ -58,7 +59,8 @@ import Data.Version (showVersion) import Development.IDE.Types.Shake (WithHieDb) -import HieDb hiding (pointCommand) +import HieDb hiding (pointCommand, + withHieDb) import System.Directory (doesFileExist) -- | Gives a Uri for the module, given the .hie file location and the the module info @@ -93,11 +95,11 @@ Just (HAR _ hf _ _ _,mapping) -> let names = getNamesAtPoint hf pos mapping adjustedLocs = HM.foldr go [] asts - go (HAR _ _ rf tr _, mapping) xs = refs ++ typerefs ++ xs + go (HAR _ _ rf tr _, goMapping) xs = refs ++ typerefs ++ xs where - refs = mapMaybe (toCurrentLocation mapping . realSrcSpanToLocation . fst) + refs = mapMaybe (toCurrentLocation goMapping . realSrcSpanToLocation . fst) $ concat $ mapMaybe (\n -> M.lookup (Right n) rf) names - typerefs = mapMaybe (toCurrentLocation mapping . realSrcSpanToLocation) + typerefs = mapMaybe (toCurrentLocation goMapping . realSrcSpanToLocation) $ concat $ mapMaybe (`M.lookup` tr) names in (names, adjustedLocs,map fromNormalizedFilePath $ HM.keys asts) @@ -133,8 +135,8 @@ typeRefs <- forM names $ \name -> case nameModule_maybe name of Just mod | isTcClsNameSpace (occNameSpace $ nameOccName name) -> do - refs <- liftIO $ withHieDb (\hieDb -> findTypeRefs hieDb True (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnit mod) exclude) - pure $ mapMaybe typeRowToLoc refs + refs' <- liftIO $ withHieDb (\hieDb -> findTypeRefs hieDb True (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnit mod) exclude) + pure $ mapMaybe typeRowToLoc refs' _ -> pure [] pure $ nubOrd $ foiRefs ++ concat nonFOIRefs ++ concat typeRefs @@ -243,9 +245,9 @@ -- Check for evidence bindings isInternal :: (Identifier, IdentifierDetails a) -> Bool - isInternal (Right _, dets) = + isInternal (Right _, _dets) = -- dets is only used in GHC >= 9.0.1 #if MIN_VERSION_ghc(9,0,1) - any isEvidenceContext $ identInfo dets + any isEvidenceContext $ identInfo _dets #else False #endif @@ -270,7 +272,7 @@ prettyPackageName :: Name -> Maybe T.Text prettyPackageName n = do m <- nameModule_maybe n - pkgTxt <- packageNameWithVersion m env + pkgTxt <- packageNameWithVersion m pure $ "*(" <> pkgTxt <> ")*" -- Return the module text itself and @@ -279,14 +281,14 @@ packageNameForImportStatement mod = do mpkg <- findImportedModule env mod :: IO (Maybe Module) let moduleName = printOutputable mod - case mpkg >>= flip packageNameWithVersion env of + case mpkg >>= packageNameWithVersion of Nothing -> pure moduleName Just pkgWithVersion -> pure $ moduleName <> "\n\n" <> pkgWithVersion -- Return the package name and version of a module. -- For example, given module `Data.List`, it should return something like `base-4.x`. - packageNameWithVersion :: Module -> HscEnv -> Maybe T.Text - packageNameWithVersion m env = do + packageNameWithVersion :: Module -> Maybe T.Text + packageNameWithVersion m = do let pid = moduleUnit m conf <- lookupUnit env pid let pkgName = T.pack $ unitPackageNameString conf @@ -331,20 +333,20 @@ unfold = map (arr A.!) getts x = nodeType ni ++ (mapMaybe identType $ M.elems $ nodeIdentifiers ni) where ni = nodeInfo' x - getTypes ts = flip concatMap (unfold ts) $ \case + getTypes' ts' = flip concatMap (unfold ts') $ \case HTyVarTy n -> [n] - HAppTy a (HieArgs xs) -> getTypes (a : map snd xs) - HTyConApp tc (HieArgs xs) -> ifaceTyConName tc : getTypes (map snd xs) - HForAllTy _ a -> getTypes [a] + HAppTy a (HieArgs xs) -> getTypes' (a : map snd xs) + HTyConApp tc (HieArgs xs) -> ifaceTyConName tc : getTypes' (map snd xs) + HForAllTy _ a -> getTypes' [a] #if MIN_VERSION_ghc(9,0,1) - HFunTy a b c -> getTypes [a,b,c] + HFunTy a b c -> getTypes' [a,b,c] #else - HFunTy a b -> getTypes [a,b] + HFunTy a b -> getTypes' [a,b] #endif - HQualTy a b -> getTypes [a,b] - HCastTy a -> getTypes [a] + HQualTy a b -> getTypes' [a,b] + HCastTy a -> getTypes' [a] _ -> [] - in fmap nubOrd $ concatMapM (fmap (fromMaybe []) . nameToLocation withHieDb lookupModule) (getTypes ts) + in fmap nubOrd $ concatMapM (fmap (fromMaybe []) . nameToLocation withHieDb lookupModule) (getTypes' ts) HieFresh -> let ts = concat $ pointCommand ast pos getts getts x = nodeType ni ++ (mapMaybe identType $ M.elems $ nodeIdentifiers ni) @@ -412,8 +414,8 @@ -- This is a hack to make find definition work better with ghcide's nascent multi-component support, -- where names from a component that has been indexed in a previous session but not loaded in this -- session may end up with different unit ids - erow <- liftIO $ withHieDb (\hieDb -> findDef hieDb (nameOccName name) (Just $ moduleName mod) Nothing) - case erow of + erow' <- liftIO $ withHieDb (\hieDb -> findDef hieDb (nameOccName name) (Just $ moduleName mod) Nothing) + case erow' of [] -> MaybeT $ pure Nothing xs -> lift $ mapMaybeM (runMaybeT . defRowToLocation lookupModule) xs xs -> lift $ mapMaybeM (runMaybeT . defRowToLocation lookupModule) xs 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 @@ -29,13 +29,11 @@ import Development.IDE.GHC.Error import Development.IDE.GHC.Util (printOutputable) import Development.IDE.Spans.Common +import Language.LSP.Protocol.Types (filePathToUri, getUri) +import Prelude hiding (mod) import System.Directory import System.FilePath -import Language.LSP.Protocol.Types (filePathToUri, getUri) -#if MIN_VERSION_ghc(9,3,0) -import GHC.Types.Unique.Map -#endif mkDocMap :: HscEnv @@ -59,17 +57,17 @@ k <- foldrM getType (tcg_type_env this_mod) names pure $ DKMap d k where - getDocs n map - | maybe True (mod ==) $ nameModule_maybe n = pure map -- we already have the docs in this_docs, or they do not exist + getDocs n nameMap + | maybe True (mod ==) $ nameModule_maybe n = pure nameMap -- we already have the docs in this_docs, or they do not exist | otherwise = do doc <- getDocumentationTryGhc env n - pure $ extendNameEnv map n doc - getType n map + pure $ extendNameEnv nameMap n doc + getType n nameMap | isTcOcc $ occName n - , Nothing <- lookupNameEnv map n + , Nothing <- lookupNameEnv nameMap n = do kind <- lookupKind env n - pure $ maybe map (extendNameEnv map n) kind - | otherwise = pure map + pure $ maybe nameMap (extendNameEnv nameMap n) kind + | otherwise = pure nameMap names = rights $ S.toList idents idents = M.keysSet rm mod = tcg_mod this_mod @@ -85,8 +83,8 @@ getDocumentationsTryGhc :: HscEnv -> [Name] -> IO [SpanDoc] getDocumentationsTryGhc env names = do - res <- catchSrcErrors (hsc_dflags env) "docs" $ getDocsBatch env names - case res of + resOr <- catchSrcErrors (hsc_dflags env) "docs" $ getDocsBatch env names + case resOr of Left _ -> return [] Right res -> zipWithM unwrap res names where @@ -123,6 +121,9 @@ => [ParsedModule] -- ^ All of the possible modules it could be defined in. -> name -- ^ The name you want documentation for. -> [T.Text] +#if MIN_VERSION_ghc(9,2,0) +getDocumentation _sources _targetName = [] +#else -- This finds any documentation between the name you want -- documentation for and the one before it. This is only an -- approximately correct algorithm and there are easily constructed @@ -133,10 +134,7 @@ -- TODO : Implement this for GHC 9.2 with in-tree annotations -- (alternatively, just remove it and rely solely on GHC's parsing) getDocumentation sources targetName = fromMaybe [] $ do -#if MIN_VERSION_ghc(9,2,0) - Nothing -#else - -- Find the module the target is defined in. + -- Find the module the target is defined in. targetNameSpan <- realSpan $ getLoc targetName tc <- find ((==) (Just $ srcSpanFile targetNameSpan) . annotationFileName) diff --git a/src/Development/IDE/Spans/Pragmas.hs b/src/Development/IDE/Spans/Pragmas.hs --- a/src/Development/IDE/Spans/Pragmas.hs +++ b/src/Development/IDE/Spans/Pragmas.hs @@ -9,8 +9,8 @@ , insertNewPragma , getFirstPragma ) where +import Control.Lens ((&), (.~)) import Data.Bits (Bits (setBit)) -import Data.Function ((&)) import qualified Data.List as List import qualified Data.Maybe as Maybe import Data.Text (Text, pack) @@ -18,17 +18,18 @@ import Development.IDE (srcSpanToRange, IdeState, NormalizedFilePath, GhcSession (..), getFileContents, hscEnv, runAction) import Development.IDE.GHC.Compat import Development.IDE.GHC.Compat.Util -import qualified Language.LSP.Protocol.Types as LSP -import Control.Monad.IO.Class (MonadIO (..)) -import Control.Monad.Trans.Except (ExceptT) -import Ide.Plugin.Error (PluginError) -import Ide.Types (PluginId(..)) -import qualified Data.Text as T -import Development.IDE.Core.PluginUtils +import qualified Language.LSP.Protocol.Types as LSP +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.Except (ExceptT) +import Ide.Plugin.Error (PluginError) +import Ide.Types (PluginId(..)) +import qualified Data.Text as T +import Development.IDE.Core.PluginUtils +import qualified Language.LSP.Protocol.Lens as L getNextPragmaInfo :: DynFlags -> Maybe Text -> NextPragmaInfo -getNextPragmaInfo dynFlags sourceText = - if | Just sourceText <- sourceText +getNextPragmaInfo dynFlags mbSourceText = + if | Just sourceText <- mbSourceText , let sourceStringBuffer = stringToStringBuffer (Text.unpack sourceText) , POk _ parserState <- parsePreDecl dynFlags sourceStringBuffer -> case parserState of @@ -46,7 +47,7 @@ showExtension ext = pack (show ext) insertNewPragma :: NextPragmaInfo -> Extension -> LSP.TextEdit -insertNewPragma (NextPragmaInfo _ (Just (LineSplitTextEdits ins _))) newPragma = ins { LSP._newText = "{-# LANGUAGE " <> showExtension newPragma <> " #-}\n" } :: LSP.TextEdit +insertNewPragma (NextPragmaInfo _ (Just (LineSplitTextEdits ins _))) newPragma = ins & L.newText .~ "{-# LANGUAGE " <> showExtension newPragma <> " #-}\n" :: LSP.TextEdit insertNewPragma (NextPragmaInfo nextPragmaLine _) newPragma = LSP.TextEdit pragmaInsertRange $ "{-# LANGUAGE " <> showExtension newPragma <> " #-}\n" where pragmaInsertPosition = LSP.Position (fromIntegral nextPragmaLine) 0 @@ -98,8 +99,8 @@ -- need to merge tokens that are deleted/inserted into one TextEdit each -- to work around some weird TextEdits applied in reversed order issue updateLineSplitTextEdits :: LSP.Range -> String -> Maybe LineSplitTextEdits -> LineSplitTextEdits -updateLineSplitTextEdits tokenRange tokenString prevLineSplitTextEdits - | Just prevLineSplitTextEdits <- prevLineSplitTextEdits +updateLineSplitTextEdits tokenRange tokenString mbPrevLineSplitTextEdits + | Just prevLineSplitTextEdits <- mbPrevLineSplitTextEdits , let LineSplitTextEdits { lineSplitInsertTextEdit = prevInsertTextEdit , lineSplitDeleteTextEdit = prevDeleteTextEdit } = prevLineSplitTextEdits @@ -290,8 +291,8 @@ | otherwise = prevParserState where hasDeleteStartedOnSameLine :: Int -> Maybe LineSplitTextEdits -> Bool - hasDeleteStartedOnSameLine line lineSplitTextEdits - | Just lineSplitTextEdits <- lineSplitTextEdits + hasDeleteStartedOnSameLine line mbLineSplitTextEdits + | Just lineSplitTextEdits <- mbLineSplitTextEdits , let LineSplitTextEdits{ lineSplitDeleteTextEdit } = lineSplitTextEdits , let LSP.TextEdit deleteRange _ = lineSplitDeleteTextEdit , let LSP.Range _ deleteEndPosition = deleteRange 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 @@ -23,21 +23,18 @@ import Control.DeepSeq (NFData (..), force, ($!!)) import Control.Monad -import Data.Bifunctor (Bifunctor (second)) import Data.Char (isUpper) import Data.Hashable (Hashable) -import Data.HashMap.Strict (HashMap, elems) -import qualified Data.HashMap.Strict as Map import Data.HashSet (HashSet) import qualified Data.HashSet as Set -import Data.List (foldl', isSuffixOf) +import Data.List (isSuffixOf) import Data.Text (Text, uncons) import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Development.IDE.GHC.Compat import Development.IDE.GHC.Orphans () -import Development.IDE.GHC.Util import GHC.Generics (Generic) -import HieDb +import HieDb hiding (withHieDb) +import Prelude hiding (mod) data ExportsMap = ExportsMap @@ -46,7 +43,7 @@ } instance NFData ExportsMap where - rnf (ExportsMap a b) = foldOccEnv (\a b -> rnf a `seq` b) (seqEltsUFM rnf b) a + rnf (ExportsMap a b) = foldOccEnv (\c d -> rnf c `seq` d) (seqEltsUFM rnf b) a instance Show ExportsMap where show (ExportsMap occs mods) = @@ -63,13 +60,13 @@ updateExportsMap :: ExportsMap -> ExportsMap -> ExportsMap updateExportsMap old new = ExportsMap { getExportsMap = delListFromOccEnv (getExportsMap old) old_occs `plusOccEnv` getExportsMap new -- plusOccEnv is right biased - , getModuleExportsMap = (getModuleExportsMap old) `plusUFM` (getModuleExportsMap new) -- plusUFM is right biased + , getModuleExportsMap = getModuleExportsMap old `plusUFM` getModuleExportsMap new -- plusUFM is right biased } where old_occs = concat [map name $ Set.toList (lookupWithDefaultUFM_Directly (getModuleExportsMap old) mempty m_uniq) | m_uniq <- nonDetKeysUFM (getModuleExportsMap new)] size :: ExportsMap -> Int -size = sum . map (Set.size) . nonDetOccEnvElts . getExportsMap +size = sum . map Set.size . nonDetOccEnvElts . getExportsMap mkVarOrDataOcc :: Text -> OccName mkVarOrDataOcc t = mkOcc $ mkFastStringByteString $ encodeUtf8 t @@ -144,8 +141,8 @@ mkIdentInfos mod (AvailTC parent (n:nn) flds) -- Following the GHC convention that parent == n if parent is exported | n == parent - = [ IdentInfo (nameOccName n) (Just $! nameOccName parent) mod - | n <- nn ++ map flSelector flds + = [ IdentInfo (nameOccName name) (Just $! nameOccName parent) mod + | name <- nn ++ map flSelector flds ] ++ [ IdentInfo (nameOccName n) Nothing mod] @@ -162,7 +159,7 @@ where doOne modIFace = do let getModDetails = unpackAvail $ moduleName $ mi_module modIFace - concatMap (getModDetails) (mi_exports modIFace) + concatMap getModDetails (mi_exports modIFace) createExportsMapMg :: [ModGuts] -> ExportsMap createExportsMapMg modGuts = do @@ -202,7 +199,7 @@ | nonInternalModules mn = map f . mkIdentInfos mn | otherwise = const [] where - f id@IdentInfo {..} = (name, mn, Set.singleton id) + f identInfo@IdentInfo {..} = (name, mn, Set.singleton identInfo) identInfoToKeyVal :: IdentInfo -> (ModuleName, IdentInfo) 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 @@ -22,7 +22,7 @@ import qualified Data.Set as Set import Data.Unique (Unique) import qualified Data.Unique as Unique -import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat hiding (newUnique) import qualified Development.IDE.GHC.Compat.Util as Maybes import Development.IDE.GHC.Error (catchSrcErrors) import Development.IDE.GHC.Util (lookupPackageConfig) 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,18 +31,22 @@ import Data.Hashable (Hashable (hash)) import Data.Maybe (fromMaybe) import Data.String +import Language.LSP.Protocol.Types (Location (..), Position (..), + Range (..)) +import qualified Language.LSP.Protocol.Types as LSP +import Text.ParserCombinators.ReadP as ReadP +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] + +#if !MIN_VERSION_ghc(9,0,0) +import FastString +import SrcLoc as GHC +#endif + #if MIN_VERSION_ghc(9,0,0) import GHC.Data.FastString import GHC.Types.SrcLoc as GHC -#else -import FastString -import SrcLoc as GHC #endif -import Language.LSP.Protocol.Types (Location (..), Position (..), - Range (..)) -import qualified Language.LSP.Protocol.Types as LSP -import Text.ParserCombinators.ReadP as ReadP toNormalizedFilePath' :: FilePath -> LSP.NormalizedFilePath -- We want to keep empty paths instead of normalising them to "." 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 @@ -2,8 +2,7 @@ -- SPDX-License-Identifier: Apache-2.0 -- | Options -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RankNTypes #-} module Development.IDE.Types.Options ( IdeOptions(..) , IdePreprocessedSource(..) @@ -19,6 +18,7 @@ , OptHaddockParse(..) , ProgressReportingStyle(..) ) where + import Control.Lens import qualified Data.Text as T import Data.Typeable @@ -30,6 +30,7 @@ import Ide.Types (DynFlagsModifications) import qualified Language.LSP.Protocol.Lens as L import qualified Language.LSP.Protocol.Types as LSP + data IdeOptions = IdeOptions { optPreprocessor :: GHC.ParsedSource -> IdePreprocessedSource -- ^ Preprocessor to run over all parsed source trees, generating a list of warnings diff --git a/src/Generics/SYB/GHC.hs b/src/Generics/SYB/GHC.hs --- a/src/Generics/SYB/GHC.hs +++ b/src/Generics/SYB/GHC.hs @@ -31,7 +31,7 @@ SrcSpan -> GenericQ (Maybe (Bool, ast)) genericIsSubspan _ dst = mkQ Nothing $ \case - (L span ast :: Located ast) -> Just (dst `isSubspanOf` span, ast) + (L srcSpan ast :: Located ast) -> Just (dst `isSubspanOf` srcSpan, ast) -- | Lift a function that replaces a value with several values into a generic diff --git a/test/exe/AsyncTests.hs b/test/exe/AsyncTests.hs --- a/test/exe/AsyncTests.hs +++ b/test/exe/AsyncTests.hs @@ -35,7 +35,7 @@ , "foo = id" ] void waitForDiagnostics - codeLenses <- getCodeLenses doc + codeLenses <- getAndResolveCodeLenses doc liftIO $ [ _title | CodeLens{_command = Just Command{_title}} <- codeLenses] @=? [ "foo :: a -> a" ] , testSession "request" $ do @@ -47,7 +47,7 @@ , "foo = id" ] void waitForDiagnostics - codeLenses <- getCodeLenses doc + codeLenses <- getAndResolveCodeLenses doc liftIO $ [ _title | CodeLens{_command = Just Command{_title}} <- codeLenses] @=? [ "foo :: a -> a" ] ] diff --git a/test/exe/ClientSettingsTests.hs b/test/exe/ClientSettingsTests.hs --- a/test/exe/ClientSettingsTests.hs +++ b/test/exe/ClientSettingsTests.hs @@ -4,8 +4,9 @@ import Control.Applicative.Combinators import Control.Monad import Data.Aeson (toJSON) -import qualified Data.Aeson as A +import Data.Default import qualified Data.Text as T +import Ide.Types import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..), @@ -19,11 +20,11 @@ tests :: TestTree tests = testGroup "client settings handling" [ testSession "ghcide restarts shake session on config changes" $ do + setIgnoringLogNotifications False void $ skipManyTill anyMessage $ message SMethod_ClientRegisterCapability void $ createDoc "A.hs" "haskell" "module A where" waitForProgressDone - sendNotification SMethod_WorkspaceDidChangeConfiguration - (DidChangeConfigurationParams (toJSON (mempty :: A.Object))) + setConfigSection "haskell" $ toJSON (def :: Config) skipManyTill anyMessage restartingBuildSession ] diff --git a/test/exe/CodeLensTests.hs b/test/exe/CodeLensTests.hs --- a/test/exe/CodeLensTests.hs +++ b/test/exe/CodeLensTests.hs @@ -3,10 +3,13 @@ module CodeLensTests (tests) where import Control.Applicative.Combinators +import Control.Lens ((^.)) +import Control.Monad (void) import Control.Monad.IO.Class (liftIO) import qualified Data.Aeson as A import Data.Maybe import qualified Data.Text as T +import Data.Tuple.Extra import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message @@ -16,9 +19,6 @@ SemanticTokensEdit (..), mkRange) import Language.LSP.Test --- import Test.QuickCheck.Instances () -import Control.Lens ((^.)) -import Data.Tuple.Extra import Test.Tasty import Test.Tasty.HUnit import TestUtils @@ -45,14 +45,19 @@ T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported, def] <> others after' enableGHCWarnings exported (def, sig) others = T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported] <> maybe [] pure sig <> [def] <> others - createConfig mode = A.object ["haskell" A..= A.object ["plugin" A..= A.object ["ghcide-type-lenses" A..= A.object ["config" A..= A.object ["mode" A..= A.String mode]]]]] - sigSession testName enableGHCWarnings mode exported def others = testSession testName $ do + createConfig mode = A.object ["plugin" A..= A.object ["ghcide-type-lenses" A..= A.object ["config" A..= A.object ["mode" A..= A.String mode]]]] + sigSession testName enableGHCWarnings waitForDiags mode exported def others = testSession testName $ do let originalCode = before enableGHCWarnings exported def others let expectedCode = after' enableGHCWarnings exported def others - sendNotification SMethod_WorkspaceDidChangeConfiguration $ DidChangeConfigurationParams $ createConfig mode + setConfigSection "haskell" (createConfig mode) doc <- createDoc "Sigs.hs" "haskell" originalCode - waitForProgressDone - codeLenses <- getCodeLenses doc + -- Because the diagnostics mode is really relying only on diagnostics now + -- to generate the code lens we need to make sure we wait till the file + -- is parsed before asking for codelenses, otherwise we will get nothing. + if waitForDiags + then void waitForDiagnostics + else waitForProgressDone + codeLenses <- getAndResolveCodeLenses doc if not $ null $ snd def then do liftIO $ length codeLenses == 1 @? "Expected 1 code lens, but got: " <> show codeLenses @@ -84,15 +89,16 @@ , ("promotedKindTest = Proxy @Nothing", if ghcVersion >= GHC96 then "promotedKindTest :: Proxy Nothing" else "promotedKindTest :: Proxy 'Nothing") , ("typeOperatorTest = Refl", if ghcVersion >= GHC92 then "typeOperatorTest :: forall {k} {a :: k}. a :~: a" else "typeOperatorTest :: a :~: a") , ("notInScopeTest = mkCharType", "notInScopeTest :: String -> Data.Data.DataType") + , ("aVeryLongSignature a b c d e f g h i j k l m n = a && b && c && d && e && f && g && h && i && j && k && l && m && n", "aVeryLongSignature :: Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool") ] in testGroup "add signature" - [ testGroup "signatures are correct" [sigSession (T.unpack $ T.replace "\n" "\\n" def) False "always" "" (def, Just sig) [] | (def, sig) <- cases] - , sigSession "exported mode works" False "exported" "xyz" ("xyz = True", Just "xyz :: Bool") (fst <$> take 3 cases) + [ testGroup "signatures are correct" [sigSession (T.unpack $ T.replace "\n" "\\n" def) False False "always" "" (def, Just sig) [] | (def, sig) <- cases] + , sigSession "exported mode works" False False "exported" "xyz" ("xyz = True", Just "xyz :: Bool") (fst <$> take 3 cases) , testGroup "diagnostics mode works" - [ sigSession "with GHC warnings" True "diagnostics" "" (second Just $ head cases) [] - , sigSession "without GHC warnings" False "diagnostics" "" (second (const Nothing) $ head cases) [] + [ sigSession "with GHC warnings" True True "diagnostics" "" (second Just $ head cases) [] + , sigSession "without GHC warnings" False False "diagnostics" "" (second (const Nothing) $ head cases) [] ] , testSession "keep stale lens" $ do let content = T.unlines @@ -112,3 +118,5 @@ listOfChar :: T.Text listOfChar | ghcVersion >= GHC90 = "String" | otherwise = "[Char]" + + diff --git a/test/exe/InitializeResponseTests.hs b/test/exe/InitializeResponseTests.hs --- a/test/exe/InitializeResponseTests.hs +++ b/test/exe/InitializeResponseTests.hs @@ -49,7 +49,7 @@ , chk " doc symbol" _documentSymbolProvider (Just $ InL True) , chk " workspace symbol" _workspaceSymbolProvider (Just $ InL True) , chk " code action" _codeActionProvider (Just $ InL False) - , chk " code lens" _codeLensProvider (Just $ CodeLensOptions (Just False) (Just False)) + , chk " code lens" _codeLensProvider (Just $ CodeLensOptions (Just False) (Just True)) , chk "NO doc formatting" _documentFormattingProvider (Just $ InL False) , chk "NO doc range formatting" _documentRangeFormattingProvider (Just $ InL False) diff --git a/test/exe/TestUtils.hs b/test/exe/TestUtils.hs --- a/test/exe/TestUtils.hs +++ b/test/exe/TestUtils.hs @@ -7,8 +7,8 @@ import Control.Applicative.Combinators import Control.Concurrent.Async -import Control.Exception (bracket_, finally) -import Control.Lens ((.~)) +import Control.Exception (bracket_, finally, throw) +import Control.Lens ((.~), (^.)) import qualified Control.Lens as Lens import qualified Control.Lens.Extras as Lens import Control.Monad @@ -47,6 +47,8 @@ import Test.Tasty.HUnit import LogType + +import Data.Traversable (for) -- | Wait for the next progress begin step waitForProgressBegin :: Session () diff --git a/test/src/Development/IDE/Test.hs b/test/src/Development/IDE/Test.hs --- a/test/src/Development/IDE/Test.hs +++ b/test/src/Development/IDE/Test.hs @@ -50,7 +50,7 @@ WaitForIdeRuleResult, ideResultSuccess) import Development.IDE.Test.Diagnostic -import GHC.TypeLits ( symbolVal ) +import GHC.TypeLits (symbolVal) import Ide.Plugin.Config (CheckParents, checkProject) import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message @@ -241,10 +241,7 @@ _ -> Nothing configureCheckProject :: Bool -> Session () -configureCheckProject overrideCheckProject = - sendNotification SMethod_WorkspaceDidChangeConfiguration - (DidChangeConfigurationParams $ toJSON - def{checkProject = overrideCheckProject}) +configureCheckProject overrideCheckProject = setConfigSection "haskell" (toJSON $ def{checkProject = overrideCheckProject}) -- | Pattern match a message from ghcide indicating that a file has been indexed isReferenceReady :: FilePath -> Session ()