diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,15 @@ +### 1.3.0.0 (2021-05-09) +* Replace unsafe getmodtime with unix package (#1778) - Pepe Iborra +* Progress reporting improvements (#1784) - Pepe Iborra +* Unify session loading using implicit-hie (#1783) - fendor +* Fix remove constraint (#1578) - Kostas Dermentzis +* Fix wrong extend import while type constuctor and data constructor have the same name (#1775) - Lei Zhu +* Imporve vscode extension schema generation (#1742) - Potato Hatsue +* Add hls-graph abstracting over shake (#1748) - Neil Mitchell +* Tease apart the custom SYB from ExactPrint (#1746) - Sandy Maguire +* fix class method completion (#1741) - Lei Zhu +* Fix: #1690 - Infix typed holes are now filled using infix notation (#1708) - Oliver Madine + ### 1.2.0.2 (2021-04-13) * Bracketing for snippet completions (#1709) - Oliver Madine * Don't suggest destruct actions for already-destructed terms (#1715) - Sandy Maguire diff --git a/cbits/getmodtime.c b/cbits/getmodtime.c deleted file mode 100644 --- a/cbits/getmodtime.c +++ /dev/null @@ -1,21 +0,0 @@ -// Copyright (c) 2019 The DAML Authors. All rights reserved. -// SPDX-License-Identifier: Apache-2.0 - -#include -#include -int getmodtime(const char* pathname, time_t* sec, long* nsec) { - struct stat s; - int r = stat(pathname, &s); - if (r != 0) { - return r; - } -#ifdef __APPLE__ - *sec = s.st_mtimespec.tv_sec; - *nsec = s.st_mtimespec.tv_nsec; -#else - *sec = s.st_mtim.tv_sec; - *nsec = s.st_mtim.tv_nsec; -#endif - return 0; -} - diff --git a/exe/Main.hs b/exe/Main.hs --- a/exe/Main.hs +++ b/exe/Main.hs @@ -26,7 +26,7 @@ import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde import qualified Development.IDE.Plugin.Test as Test import Development.IDE.Types.Options -import Development.Shake (ShakeOptions (shakeThreads)) +import Development.IDE.Graph (ShakeOptions (shakeThreads)) import Ide.Plugin.Config (Config (checkParents, checkProject)) import Ide.Plugin.ConfigUtils (pluginsToDefaultConfig, pluginsToVSCodeExtensionSchema) @@ -109,4 +109,3 @@ , optCheckProject = pure $ checkProject config } } - diff --git a/ghcide.cabal b/ghcide.cabal --- a/ghcide.cabal +++ b/ghcide.cabal @@ -2,7 +2,7 @@ build-type: Simple category: Development name: ghcide -version: 1.2.0.2 +version: 1.3.0.0 license: Apache-2.0 license-file: LICENSE author: Digital Asset and Ghcide contributors @@ -14,7 +14,7 @@ homepage: https://github.com/haskell/haskell-language-server/tree/master/ghcide#readme bug-reports: https://github.com/haskell/haskell-language-server/issues tested-with: GHC == 8.6.4 || == 8.6.5 || == 8.8.2 || == 8.8.3 || == 8.8.4 || == 8.10.2 || == 8.10.3 || == 8.10.4 -extra-source-files: include/ghc-api-version.h README.md CHANGELOG.md +extra-source-files: README.md CHANGELOG.md test/data/**/*.project test/data/**/*.cabal test/data/**/*.yaml @@ -67,14 +67,13 @@ optparse-applicative, parallel, prettyprinter-ansi-terminal, - prettyprinter-ansi-terminal, prettyprinter, regex-tdfa >= 1.3.1.0, retrie, rope-utf16-splay, safe, safe-exceptions, - shake >= 0.18.4, + hls-graph ^>= 1.3, sorted-list, sqlite-simple, stm, @@ -108,8 +107,6 @@ else build-depends: unix - c-sources: - cbits/getmodtime.c default-extensions: ApplicativeDo @@ -136,10 +133,9 @@ hs-source-dirs: src session-loader - include-dirs: - include exposed-modules: Control.Concurrent.Strict + Generics.SYB.GHC Development.IDE Development.IDE.Main Development.IDE.Core.Actions @@ -149,6 +145,7 @@ Development.IDE.Core.OfInterest Development.IDE.Core.PositionMapping Development.IDE.Core.Preprocessor + Development.IDE.Core.ProgressReporting Development.IDE.Core.Rules Development.IDE.Core.RuleTypes Development.IDE.Core.Service @@ -253,8 +250,6 @@ executable ghcide default-language: Haskell2010 - include-dirs: - include hs-source-dirs: exe ghc-options: -threaded @@ -287,7 +282,7 @@ ghcide, lens, optparse-applicative, - shake, + hls-graph, text, unordered-containers, aeson-pretty @@ -332,9 +327,9 @@ extra, filepath, -------------------------------------------------------------- - -- The MIN_GHC_API_VERSION macro relies on MIN_VERSION pragmas + -- The MIN_VERSION_ghc macro relies on MIN_VERSION pragmas -- which require depending on ghc. So the tests need to depend - -- on ghc if they need to use MIN_GHC_API_VERSION. Maybe a + -- on ghc if they need to use MIN_VERSION_ghc. Maybe a -- better solution can be found, but this is a quick solution -- which works for now. ghc, @@ -357,18 +352,19 @@ safe, safe-exceptions, shake, + hls-graph, tasty, tasty-expected-failure, tasty-hunit, tasty-quickcheck, tasty-rerun, - text + text, + unordered-containers, if (impl(ghc >= 8.6)) build-depends: record-dot-preprocessor, record-hasfield hs-source-dirs: test/cabal test/exe test/src bench/lib - include-dirs: include ghc-options: -threaded -Wall -Wno-name-shadowing -O0 -Wno-unticked-promoted-constructors main-is: Main.hs other-modules: @@ -376,6 +372,7 @@ Development.IDE.Test.Runfiles Experiments Experiments.Types + Progress default-extensions: BangPatterns DeriveFunctor @@ -409,10 +406,10 @@ optparse-applicative, process, safe-exceptions, + hls-graph, shake, text hs-source-dirs: bench/lib bench/exe - include-dirs: include ghc-options: -threaded -Wall -Wno-name-shadowing -rtsopts main-is: Main.hs other-modules: diff --git a/include/ghc-api-version.h b/include/ghc-api-version.h deleted file mode 100644 --- a/include/ghc-api-version.h +++ /dev/null @@ -1,12 +0,0 @@ -#ifndef GHC_API_VERSION_H -#define GHC_API_VERSION_H - -#ifdef GHC_LIB -#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc_lib(x,y,z) -#define GHC_API_VERSION VERSION_ghc_lib -#else -#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc(x,y,z) -#define GHC_API_VERSION VERSION_ghc -#endif - -#endif 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 @@ -1,6 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} -#include "ghc-api-version.h" {-| The logic for setting up a ghcide session by tapping into hie-bios. @@ -48,6 +47,7 @@ TargetFile, TargetModule) import qualified Development.IDE.GHC.Compat as GHC import Development.IDE.GHC.Util +import Development.IDE.Graph (Action) import Development.IDE.Session.VersionCheck import Development.IDE.Types.Diagnostics import Development.IDE.Types.Exports @@ -56,7 +56,6 @@ import Development.IDE.Types.Location import Development.IDE.Types.Logger import Development.IDE.Types.Options -import Development.Shake (Action) import GHC.Check import qualified HIE.Bios as HieBios import HIE.Bios.Environment hiding (getCacheDir) @@ -85,11 +84,10 @@ import Control.Concurrent.STM.TQueue import qualified Data.HashSet as Set import Database.SQLite.Simple -import HIE.Bios.Cradle (yamlConfig) +import GHC.LanguageExtensions (Extension (EmptyCase)) import HieDb.Create import HieDb.Types import HieDb.Utils -import Maybes (MaybeT (runMaybeT)) -- | Bump this version number when making changes to the format of the data stored in hiedb hiedbDataVersion :: String @@ -99,15 +97,18 @@ { hiCacheDir, hieCacheDir, oCacheDir :: Maybe FilePath} data SessionLoadingOptions = SessionLoadingOptions - { findCradle :: FilePath -> IO (Maybe FilePath) - , loadCradle :: FilePath -> IO (HieBios.Cradle Void) + { findCradle :: FilePath -> IO (Maybe FilePath) + -- | Load the cradle with an optional 'hie.yaml' location. + -- If a 'hie.yaml' is given, use it to load the cradle. + -- Otherwise, use the provided project root directory to determine the cradle type. + , loadCradle :: Maybe FilePath -> FilePath -> IO (HieBios.Cradle Void) -- | Given the project name and a set of command line flags, -- return the path for storing generated GHC artifacts, -- or 'Nothing' to respect the cradle setting - , getCacheDirs :: String -> [String] -> IO CacheDirs + , getCacheDirs :: String -> [String] -> IO CacheDirs -- | Return the GHC lib dir to use for the 'unsafeGlobalDynFlags' - , getInitialGhcLibDir :: IO (Maybe LibDir) - , fakeUid :: InstalledUnitId + , getInitialGhcLibDir :: IO (Maybe LibDir) + , fakeUid :: InstalledUnitId -- ^ unit id used to tag the internal component built by ghcide -- To reuse external interface files the unit ids must match, -- thus make sure to build them with `--this-unit-id` set to the @@ -117,17 +118,39 @@ instance Default SessionLoadingOptions where def = SessionLoadingOptions {findCradle = HieBios.findCradle - ,loadCradle = HieBios.loadCradle + ,loadCradle = loadWithImplicitCradle ,getCacheDirs = getCacheDirsDefault ,getInitialGhcLibDir = getInitialGhcLibDirDefault ,fakeUid = toInstalledUnitId (stringToUnitId "main") } +-- | Find the cradle for a given 'hie.yaml' configuration. +-- +-- If a 'hie.yaml' is given, the cradle is read from the config. +-- If this config does not comply to the "hie.yaml" +-- specification, an error is raised. +-- +-- If no location for "hie.yaml" is provided, the implicit config is used +-- using the provided root directory for discovering the project. +-- The implicit config uses different heuristics to determine the type +-- of the project that may or may not be accurate. +loadWithImplicitCradle :: Maybe FilePath + -- ^ Optional 'hie.yaml' location. Will be used if given. + -> FilePath + -- ^ Root directory of the project. Required as a fallback + -- if no 'hie.yaml' location is given. + -> IO (HieBios.Cradle Void) +loadWithImplicitCradle mHieYaml rootDir = do + crdl <- case mHieYaml of + Just yaml -> HieBios.loadCradle yaml + Nothing -> loadImplicitHieCradle $ addTrailingPathSeparator rootDir + return crdl + getInitialGhcLibDirDefault :: IO (Maybe LibDir) getInitialGhcLibDirDefault = do dir <- IO.getCurrentDirectory - hieYaml <- runMaybeT $ yamlConfig dir - cradle <- maybe (loadImplicitHieCradle $ addTrailingPathSeparator dir) HieBios.loadCradle hieYaml + hieYaml <- findCradle def dir + cradle <- loadCradle def hieYaml dir hPutStrLn stderr $ "setInitialDynFlags cradle: " ++ show cradle libDirRes <- getRuntimeGhcLibDir cradle case libDirRes of @@ -399,7 +422,7 @@ when (isNothing hieYaml) $ logWarning logger $ implicitCradleWarning lfp - cradle <- maybe (loadImplicitHieCradle $ addTrailingPathSeparator dir) loadCradle hieYaml + cradle <- loadCradle hieYaml dir when optTesting $ mRunLspT lspEnv $ sendNotification (SCustomMethod "ghcide/cradle/loaded") (toJSON cfp) @@ -771,6 +794,7 @@ setIgnoreInterfacePragmas $ setLinkerOptions $ disableOptimisation $ + allowEmptyCaseButWithWarning $ setUpTypedHoles $ makeDynFlagsAbsolute compRoot dflags' -- initPackages parses the -package flags and @@ -778,6 +802,14 @@ -- Throws if a -package flag cannot be satisfied. (final_df, _) <- liftIO $ wrapPackageSetupException $ initPackages dflags'' return (final_df, targets) + + +-- | Wingman wants to support destructing of empty cases, but these are a parse +-- error by default. So we want to enable 'EmptyCase', but then that leads to +-- silent errors without 'Opt_WarnIncompletePatterns'. +allowEmptyCaseButWithWarning :: DynFlags -> DynFlags +allowEmptyCaseButWithWarning = + flip xopt_set EmptyCase . flip wopt_set Opt_WarnIncompletePatterns -- we don't want to generate object code so we compile to bytecode diff --git a/src/Development/IDE.hs b/src/Development/IDE.hs --- a/src/Development/IDE.hs +++ b/src/Development/IDE.hs @@ -51,5 +51,5 @@ hscEnvWithImportPaths) import Development.IDE.Types.Location as X import Development.IDE.Types.Logger as X -import Development.Shake as X (Action, RuleResult, +import Development.IDE.Graph as X (Action, RuleResult, Rules, action) 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 @@ -30,7 +30,7 @@ writeHieFile) import qualified Development.IDE.Spans.AtPoint as AtPoint import Development.IDE.Types.Location -import Development.Shake hiding (Diagnostic) +import Development.IDE.Graph import qualified HieDb import Language.LSP.Types (DocumentHighlight (..), SymbolInformation (..)) 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 @@ -4,7 +4,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} -#include "ghc-api-version.h" -- | Based on https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/API. -- Given a list of paths to find libraries, and a file to compile, produce a list of 'CoreModule' values. @@ -57,7 +56,7 @@ import Lexer import qualified Parser -#if MIN_GHC_API_VERSION(8,10,0) +#if MIN_VERSION_ghc(8,10,0) import Control.DeepSeq (force, rnf) #else import Control.DeepSeq (rnf) @@ -234,7 +233,7 @@ tcGblEnv = tmrTypechecked tcm details <- makeSimpleDetails hsc_env_tmp tcGblEnv sf <- finalSafeMode (ms_hspp_opts ms) tcGblEnv -#if MIN_GHC_API_VERSION(8,10,0) +#if MIN_VERSION_ghc(8,10,0) iface <- mkIfaceTc hsc_env_tmp sf details tcGblEnv #else (iface, _) <- mkIfaceTc hsc_env_tmp Nothing sf details tcGblEnv @@ -268,7 +267,7 @@ (guts, details) <- tidyProgram session simplified_guts (diags, linkable) <- genLinkable session ms guts pure (linkable, details, diags) -#if MIN_GHC_API_VERSION(8,10,0) +#if MIN_VERSION_ghc(8,10,0) let !partial_iface = force (mkPartialIface session details simplified_guts) final_iface <- mkFullIface session partial_iface #else @@ -330,14 +329,14 @@ (warnings, dot_o_fp) <- withWarnings "object" $ \_tweak -> do let summary' = _tweak summary -#if MIN_GHC_API_VERSION(8,10,0) +#if MIN_VERSION_ghc(8,10,0) target = defaultObjectTarget $ hsc_dflags session #else target = defaultObjectTarget $ targetPlatform $ hsc_dflags session #endif session' = session { hsc_dflags = updOptLevel 0 $ (ms_hspp_opts summary') { outputFile = Just dot_o , hscTarget = target}} (outputFilename, _mStub, _foreign_files) <- hscGenHardCode session' guts -#if MIN_GHC_API_VERSION(8,10,0) +#if MIN_VERSION_ghc(8,10,0) (ms_location summary') #else summary' @@ -360,7 +359,7 @@ let summary' = _tweak summary session = hscEnv { hsc_dflags = ms_hspp_opts summary' } hscInteractive session guts -#if MIN_GHC_API_VERSION(8,10,0) +#if MIN_VERSION_ghc(8,10,0) (ms_location summary') #else summary' @@ -419,7 +418,7 @@ , Opt_WarnUnusedMatches , Opt_WarnUnusedTypePatterns , Opt_WarnUnusedForalls -#if MIN_GHC_API_VERSION(8,10,0) +#if MIN_VERSION_ghc(8,10,0) , Opt_WarnUnusedRecordWildcards #endif , Opt_WarnInaccessibleCode @@ -738,7 +737,7 @@ msrModSummary = ModSummary { ms_mod = modl -#if MIN_GHC_API_VERSION(8,8,0) +#if MIN_VERSION_ghc(8,8,0) , ms_hie_date = Nothing #endif , ms_hs_date = modTime @@ -782,7 +781,7 @@ parseHeader dflags filename contents = do let loc = mkRealSrcLoc (mkFastString filename) 1 1 case unP Parser.parseHeader (mkPState dflags contents loc) of -#if MIN_GHC_API_VERSION(8,10,0) +#if MIN_VERSION_ghc(8,10,0) PFailed pst -> throwE $ diagFromErrMsgs "parser" dflags $ getErrorMessages pst dflags #else @@ -820,7 +819,7 @@ dflags = ms_hspp_opts ms contents = fromJust $ ms_hspp_buf ms case unP Parser.parseModule (mkPState dflags contents loc) of -#if MIN_GHC_API_VERSION(8,10,0) +#if MIN_VERSION_ghc(8,10,0) PFailed pst -> throwE $ diagFromErrMsgs "parser" dflags $ getErrorMessages pst dflags #else PFailed _ locErr msgErr -> 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 @@ -13,6 +13,7 @@ import Control.Concurrent.Strict import Control.Exception import Control.Monad.Extra +import Control.Monad.IO.Class import qualified Data.ByteString as BS import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap @@ -23,7 +24,7 @@ import Development.IDE.Core.Shake import Development.IDE.Types.Location import Development.IDE.Types.Options -import Development.Shake +import Development.IDE.Graph import Language.LSP.Server hiding (getVirtualFile) import Language.LSP.Types import Language.LSP.Types.Capabilities 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 @@ -19,7 +19,8 @@ resetInterfaceStore, getModificationTimeImpl, addIdeGlobal, - getFileContentsImpl + getFileContentsImpl, + getModTime ) where import Control.Concurrent.STM (atomically) @@ -27,25 +28,26 @@ import Control.Concurrent.Strict import Control.Exception import Control.Monad.Extra +import Control.Monad.IO.Class import qualified Data.ByteString as BS import Data.Either.Extra import qualified Data.HashMap.Strict as HM -import Data.Int (Int64) import qualified Data.Map.Strict as Map import Data.Maybe import qualified Data.Rope.UTF16 as Rope import qualified Data.Text as T import Data.Time +import Data.Time.Clock.POSIX import Development.IDE.Core.OfInterest (OfInterestVar (..), getFilesOfInterest) import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake import Development.IDE.GHC.Orphans () +import Development.IDE.Graph import Development.IDE.Import.DependencyInformation import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import Development.IDE.Types.Options -import Development.Shake import HieDb.Create (deleteMissingRealFiles) import Ide.Plugin.Config (CheckParents (..)) import System.IO.Error @@ -53,21 +55,13 @@ #ifdef mingw32_HOST_OS import qualified System.Directory as Dir #else -import Data.Time.Clock.System (SystemTime (MkSystemTime), - systemToUTCTime) -import Foreign.C.String -import Foreign.C.Types -import Foreign.Marshal (alloca) -import Foreign.Ptr -import Foreign.Storable -import qualified System.Posix.Error as Posix +import System.Posix.Files ( getFileStatus, modificationTimeHiRes) #endif import qualified Development.IDE.Types.Logger as L import qualified Data.Binary as B import qualified Data.ByteString.Lazy as LBS -import Development.IDE.Core.IdeConfiguration (isWorkspaceFile) import Language.LSP.Server hiding (getVirtualFile) import qualified Language.LSP.Server as LSP @@ -126,7 +120,7 @@ (Maybe BS.ByteString, ([FileDiagnostic], Maybe FileVersion)) getModificationTimeImpl vfs isWatched missingFileDiags file = do let file' = fromNormalizedFilePath file - let wrap time@(l,s) = (Just $ LBS.toStrict $ B.encode time, ([], Just $ ModificationTime l s)) + let wrap time = (Just $ LBS.toStrict $ B.encode $ toRational time, ([], Just $ ModificationTime time)) mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file case mbVirtual of Just (virtualFileVersion -> ver) -> do @@ -192,38 +186,17 @@ -- We might also want to try speeding this up on Windows at some point. -- TODO leverage DidChangeWatchedFile lsp notifications on clients that -- support them, as done for GetFileExists -getModTime :: FilePath -> IO (Int64, Int64) +getModTime :: FilePath -> IO POSIXTime getModTime f = #ifdef mingw32_HOST_OS - do time <- Dir.getModificationTime f - let !day = fromInteger $ toModifiedJulianDay $ utctDay time - !dayTime = fromInteger $ diffTimeToPicoseconds $ utctDayTime time - pure (day, dayTime) + utcTimeToPOSIXSeconds <$> Dir.getModificationTime f #else - withCString f $ \f' -> - alloca $ \secPtr -> - alloca $ \nsecPtr -> do - Posix.throwErrnoPathIfMinus1Retry_ "getmodtime" f $ c_getModTime f' secPtr nsecPtr - CTime sec <- peek secPtr - CLong nsec <- peek nsecPtr - pure (sec, nsec) - --- Sadly even unix’s getFileStatus + modificationTimeHiRes is still about twice as slow --- as doing the FFI call ourselves :(. -foreign import ccall "getmodtime" c_getModTime :: CString -> Ptr CTime -> Ptr CLong -> IO Int + modificationTimeHiRes <$> getFileStatus f #endif modificationTime :: FileVersion -> Maybe UTCTime -modificationTime VFSVersion{} = Nothing -modificationTime (ModificationTime large small) = Just $ internalTimeToUTCTime large small - -internalTimeToUTCTime :: Int64 -> Int64 -> UTCTime -internalTimeToUTCTime large small = -#ifdef mingw32_HOST_OS - UTCTime (ModifiedJulianDay $ fromIntegral large) (picosecondsToDiffTime $ fromIntegral small) -#else - systemToUTCTime $ MkSystemTime large (fromIntegral small) -#endif +modificationTime VFSVersion{} = Nothing +modificationTime (ModificationTime posix) = Just $ posixSecondsToUTCTime posix getFileContentsRule :: VFSHandle -> Rules () getFileContentsRule vfs = define $ \GetFileContents file -> getFileContentsImpl vfs file @@ -260,8 +233,8 @@ liftIO $ case foi of IsFOI Modified{} -> getCurrentTime _ -> do - (large,small) <- getModTime $ fromNormalizedFilePath f - pure $ internalTimeToUTCTime large small + posix <- getModTime $ fromNormalizedFilePath f + pure $ posixSecondsToUTCTime posix return (modTime, txt) fileStoreRules :: VFSHandle -> (NormalizedFilePath -> Action Bool) -> Rules () 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 @@ -14,13 +14,14 @@ import Control.Concurrent.Strict import Control.Monad +import Control.Monad.IO.Class import Data.Aeson.Types (Value) import Data.HashSet (HashSet, singleton) import Data.Hashable (Hashed, hashed, unhashed) import Data.Text (Text, isPrefixOf) import Development.IDE.Core.Shake import Development.IDE.Types.Location -import Development.Shake +import Development.IDE.Graph import Language.LSP.Types import System.FilePath (isRelative) 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 @@ -14,23 +14,20 @@ ) where import Control.Concurrent.Strict -import Control.DeepSeq -import Control.Exception import Control.Monad +import Control.Monad.IO.Class import Data.Binary import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap -import Data.Hashable import qualified Data.Text as T -import Data.Typeable -import Development.Shake -import GHC.Generics +import Development.IDE.Graph import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe import qualified Data.ByteString.Lazy as LBS import Data.List.Extra (nubOrd) import Data.Maybe (catMaybes) +import Development.IDE.Core.ProgressReporting import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake import Development.IDE.Import.DependencyInformation @@ -42,24 +39,15 @@ newtype OfInterestVar = OfInterestVar (Var (HashMap NormalizedFilePath FileOfInterestStatus)) instance IsIdeGlobal OfInterestVar -type instance RuleResult GetFilesOfInterest = HashMap NormalizedFilePath FileOfInterestStatus - -data GetFilesOfInterest = GetFilesOfInterest - deriving (Eq, Show, Typeable, Generic) -instance Hashable GetFilesOfInterest -instance NFData GetFilesOfInterest -instance Binary GetFilesOfInterest - - -- | The rule that initialises the files of interest state. ofInterestRules :: Rules () ofInterestRules = do addIdeGlobal . OfInterestVar =<< liftIO (newVar HashMap.empty) - defineEarlyCutoff $ RuleNoDiagnostics $ \GetFilesOfInterest _file -> assert (null $ fromNormalizedFilePath _file) $ do + defineEarlyCutOffNoFile $ \GetFilesOfInterest -> do alwaysRerun filesOfInterest <- getFilesOfInterestUntracked let !cutoff = LBS.toStrict $ encode $ HashMap.toList filesOfInterest - pure (Just cutoff, Just filesOfInterest) + pure (cutoff, filesOfInterest) -- | Get the files that are open in the IDE. getFilesOfInterest :: Action (HashMap NormalizedFilePath FileOfInterestStatus) @@ -94,8 +82,8 @@ kick :: Action () kick = do files <- HashMap.keys <$> getFilesOfInterest - ShakeExtras{progressUpdate} <- getShakeExtras - liftIO $ progressUpdate KickStarted + ShakeExtras{progress} <- getShakeExtras + liftIO $ progressUpdate progress KickStarted -- Update the exports map for FOIs results <- uses GenerateCore files <* uses GetHieAst files @@ -115,5 +103,4 @@ !exportsMap'' = maybe mempty createExportsMap ifaces void $ liftIO $ modifyVar' exportsMap $ (exportsMap'' <>) . (exportsMap' <>) - liftIO $ progressUpdate KickCompleted - + liftIO $ progressUpdate progress KickCompleted diff --git a/src/Development/IDE/Core/ProgressReporting.hs b/src/Development/IDE/Core/ProgressReporting.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/Core/ProgressReporting.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE RankNTypes #-} +module Development.IDE.Core.ProgressReporting + ( ProgressEvent(..) + , ProgressReporting(..) + , noProgressReporting + , delayedProgressReporting + -- utilities, reexported for use in Core.Shake + , mRunLspT + , mRunLspTCallback + -- for tests + , recordProgress + , InProgress(..) + ) + where + +import Control.Concurrent.Async +import Control.Concurrent.Strict +import Control.Monad.Extra +import Control.Monad.IO.Class +import Control.Monad.Trans.Class (lift) +import Data.Foldable (for_) +import Data.Functor (($>)) +import qualified Data.HashMap.Strict as HMap +import qualified Data.Text as T +import Data.Unique +import Development.IDE.GHC.Orphans () +import Development.IDE.Graph hiding (ShakeValue) +import Development.IDE.Types.Location +import Development.IDE.Types.Options +import qualified Language.LSP.Server as LSP +import Language.LSP.Types +import qualified Language.LSP.Types as LSP +import System.Time.Extra +import UnliftIO.Exception (bracket_) + +data ProgressEvent + = KickStarted + | KickCompleted + +data ProgressReporting = ProgressReporting + { progressUpdate :: ProgressEvent -> IO () + , inProgress :: forall a. NormalizedFilePath -> Action a -> Action a + , progressStop :: IO () + } + +noProgressReporting :: IO ProgressReporting +noProgressReporting = return $ ProgressReporting + { progressUpdate = const $ pure () + , inProgress = const id + , progressStop = pure () + } + +-- | State used in 'delayedProgressReporting' +data State + = NotStarted + | Stopped + | Running (Async ()) + +-- | State transitions used in 'delayedProgressReporting' +data Transition = Event ProgressEvent | StopProgress + +updateState :: IO () -> Transition -> State -> IO State +updateState _ _ Stopped = pure Stopped +updateState start (Event KickStarted) NotStarted = Running <$> async start +updateState start (Event KickStarted) (Running a) = cancel a >> Running <$> async start +updateState _ (Event KickCompleted) (Running a) = cancel a $> NotStarted +updateState _ (Event KickCompleted) st = pure st +updateState _ StopProgress (Running a) = cancel a $> Stopped +updateState _ StopProgress st = pure st + +-- | Data structure to track progress across the project +data InProgress = InProgress + { todo :: !Int -- ^ Number of files to do + , done :: !Int -- ^ Number of files done + , current :: !(HMap.HashMap NormalizedFilePath Int) + } + +recordProgress :: NormalizedFilePath -> (Int -> Int) -> InProgress -> InProgress +recordProgress file shift InProgress{..} = case HMap.alterF alter file current of + ((prev, new), m') -> + let (done',todo') = + case (prev,new) of + (Nothing,0) -> (done+1, todo+1) + (Nothing,_) -> (done, todo+1) + (Just 0, 0) -> (done , todo) + (Just 0, _) -> (done-1, todo) + (Just _, 0) -> (done+1, todo) + (Just _, _) -> (done , todo) + in InProgress todo' done' m' + where + alter x = let x' = maybe (shift 0) shift x in ((x,x'), Just x') + +-- | A 'ProgressReporting' that enqueues Begin and End notifications in a new +-- thread, with a grace period (nothing will be sent if 'KickCompleted' arrives +-- before the end of the grace period). +delayedProgressReporting + :: Seconds -- ^ Grace period before starting + -> Seconds -- ^ sampling delay + -> Maybe (LSP.LanguageContextEnv c) + -> ProgressReportingStyle + -> IO ProgressReporting +delayedProgressReporting before after lspEnv optProgressStyle = do + inProgressVar <- newVar $ InProgress 0 0 mempty + progressState <- newVar NotStarted + let progressUpdate event = updateStateVar $ Event event + progressStop = updateStateVar StopProgress + updateStateVar = modifyVar_ progressState . updateState (mRunLspT lspEnv $ lspShakeProgress inProgressVar) + + inProgress :: NormalizedFilePath -> Action a -> Action a + inProgress = withProgressVar inProgressVar + return ProgressReporting{..} + where + lspShakeProgress inProgress = do + -- first sleep a bit, so we only show progress messages if it's going to take + -- a "noticable amount of time" (we often expect a thread kill to arrive before the sleep finishes) + liftIO $ sleep before + u <- ProgressTextToken . T.pack . show . hashUnique <$> liftIO newUnique + + b <- liftIO newBarrier + void $ LSP.sendRequest LSP.SWindowWorkDoneProgressCreate + LSP.WorkDoneProgressCreateParams { _token = u } $ liftIO . signalBarrier b + ready <- liftIO $ waitBarrier b + + for_ ready $ const $ bracket_ (start u) (stop u) (loop u 0) + where + start id = LSP.sendNotification LSP.SProgress $ + LSP.ProgressParams + { _token = id + , _value = LSP.Begin $ WorkDoneProgressBeginParams + { _title = "Processing" + , _cancellable = Nothing + , _message = Nothing + , _percentage = Nothing + } + } + stop id = LSP.sendNotification LSP.SProgress + LSP.ProgressParams + { _token = id + , _value = LSP.End WorkDoneProgressEndParams + { _message = Nothing + } + } + loop _ _ | optProgressStyle == NoProgress = + forever $ liftIO $ threadDelay maxBound + loop id prev = do + InProgress{..} <- liftIO $ readVar inProgress + liftIO $ sleep after + if todo == 0 then loop id 0 else do + let next = 100 * fromIntegral done / fromIntegral todo + when (next /= prev) $ + LSP.sendNotification LSP.SProgress $ + LSP.ProgressParams + { _token = id + , _value = LSP.Report $ case optProgressStyle of + Explicit -> LSP.WorkDoneProgressReportParams + { _cancellable = Nothing + , _message = Just $ T.pack $ show done <> "/" <> show todo + , _percentage = Nothing + } + Percentage -> LSP.WorkDoneProgressReportParams + { _cancellable = Nothing + , _message = Nothing + , _percentage = Just next + } + NoProgress -> error "unreachable" + } + loop id next + + withProgressVar var file = actionBracket (f succ) (const $ f pred) . const + -- This functions are deliberately eta-expanded to avoid space leaks. + -- Do not remove the eta-expansion without profiling a session with at + -- least 1000 modifications. + where + f shift = modifyVar' var $ recordProgress file shift + +mRunLspT :: Applicative m => Maybe (LSP.LanguageContextEnv c ) -> LSP.LspT c m () -> m () +mRunLspT (Just lspEnv) f = LSP.runLspT lspEnv f +mRunLspT Nothing _ = pure () + +mRunLspTCallback :: Monad m + => Maybe (LSP.LanguageContextEnv c) + -> (LSP.LspT c m a -> LSP.LspT c m a) + -> m a + -> m a +mRunLspTCallback (Just lspEnv) f g = LSP.runLspT lspEnv $ f (lift g) +mRunLspTCallback Nothing _ g = g 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 @@ -21,14 +21,15 @@ import Data.Binary import Data.Hashable import qualified Data.Map as M +import Data.Time.Clock.POSIX import Data.Typeable import Development.IDE.GHC.Compat hiding (HieFileResult) import Development.IDE.GHC.Util +import Development.IDE.Graph import Development.IDE.Import.DependencyInformation import Development.IDE.Types.HscEnvEq (HscEnvEq) import Development.IDE.Types.KnownTargets -import Development.Shake import GHC.Generics (Generic) import HscTypes (HomeModInfo, @@ -39,7 +40,7 @@ import qualified Data.Binary as B import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as LBS -import Data.Int (Int64) +import Data.HashMap.Strict (HashMap) import Data.Text (Text) import Data.Time import Development.IDE.Import.FindImports (ArtifactsLocation) @@ -295,9 +296,7 @@ data FileVersion = VFSVersion !Int - | ModificationTime - !Int64 -- ^ Large unit (platform dependent, do not make assumptions) - !Int64 -- ^ Small unit (platform dependent, do not make assumptions) + | ModificationTime !POSIXTime deriving (Show, Generic) instance NFData FileVersion @@ -355,6 +354,8 @@ -- | Generate a ModSummary with the timestamps and preprocessed content elided, for more successful early cutoff type instance RuleResult GetModSummaryWithoutTimestamps = ModSummaryResult +type instance RuleResult GetFilesOfInterest = HashMap NormalizedFilePath FileOfInterestStatus + data GetParsedModule = GetParsedModule deriving (Eq, Show, Typeable, Generic) instance Hashable GetParsedModule @@ -511,6 +512,12 @@ instance Hashable GhcSessionIO instance NFData GhcSessionIO instance Binary GhcSessionIO + +data GetFilesOfInterest = GetFilesOfInterest + deriving (Eq, Show, Typeable, Generic) +instance Hashable GetFilesOfInterest +instance NFData GetFilesOfInterest +instance Binary GetFilesOfInterest makeLensesWith (lensRules & lensField .~ mappingNamer (pure . (++ "L"))) 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 @@ -5,7 +5,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} -#include "ghc-api-version.h" -- | A Shake implementation of the compiler service, built -- using the "Shaker" abstraction layer for in-memory use. @@ -123,9 +122,8 @@ import Development.IDE.Types.Location import qualified Development.IDE.Types.Logger as L import Development.IDE.Types.Options -import Development.Shake hiding - (Diagnostic) -import Development.Shake.Classes hiding (get, put) +import Development.IDE.Graph +import Development.IDE.Graph.Classes hiding (get, put) import Fingerprint import GHC.Generics (Generic) import GHC.IO.Encoding @@ -139,6 +137,7 @@ import Language.LSP.Types (SMethod (SCustomMethod)) import Language.LSP.VFS import Module +import System.Directory (canonicalizePath) import TcRnMonad (tcg_dependent_files) import Ide.Plugin.Properties (HasProperty, KeyNameProxy, Properties, ToHsType, useProperty) @@ -153,16 +152,6 @@ toIdeResult :: Either [FileDiagnostic] v -> IdeResult v toIdeResult = either (, Nothing) (([],) . Just) -defineNoFile :: IdeRule k v => (k -> Action v) -> Rules () -defineNoFile f = defineNoDiagnostics $ \k file -> do - if file == emptyFilePath then do res <- f k; return (Just res) else - fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file" - -defineEarlyCutOffNoFile :: IdeRule k v => (k -> Action (BS.ByteString, v)) -> Rules () -defineEarlyCutOffNoFile f = defineEarlyCutoff $ RuleNoDiagnostics $ \k file -> do - if file == emptyFilePath then do (hash, res) <- f k; return (Just hash, Just res) else - fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file" - ------------------------------------------------------------ -- Exposed API ------------------------------------------------------------ @@ -734,10 +723,12 @@ hie_loc = ml_hie_file $ ms_location ms hash <- liftIO $ getFileHash hie_loc mrow <- liftIO $ HieDb.lookupHieFileFromSource hiedb (fromNormalizedFilePath f) + hie_loc' <- liftIO $ traverse (canonicalizePath . HieDb.hieModuleHieFile) mrow case mrow of Just row | hash == HieDb.modInfoHash (HieDb.hieModInfo row) - , hie_loc == HieDb.hieModuleHieFile row -> do + && Just hie_loc == hie_loc' + -> do -- All good, the db has indexed the file when (coerce $ ideTesting se) $ liftIO $ mRunLspT (lspEnv se) $ LSP.sendNotification (SCustomMethod "ghcide/reference/ready") $ 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 @@ -23,7 +23,7 @@ import Development.IDE.Core.OfInterest import Development.IDE.Types.Logger as Logger import Development.IDE.Types.Options (IdeOptions (..)) -import Development.Shake +import Development.IDE.Graph import Ide.Plugin.Config import qualified Language.LSP.Server as LSP import qualified Language.LSP.Types as LSP 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 @@ -3,6 +3,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} @@ -23,7 +24,7 @@ -- always stored as real Haskell values, whereas Shake serialises all 'A' values -- between runs. To deserialise a Shake value, we just consult Values. module Development.IDE.Core.Shake( - IdeState, shakeExtras, + IdeState, shakeSessionInit, shakeExtras, ShakeExtras(..), getShakeExtras, getShakeExtrasRules, KnownTargets, Target(..), toKnownFiles, IdeRule, IdeResult, @@ -32,6 +33,7 @@ shakeRestart, shakeEnqueue, shakeProfile, + newSession, use, useNoFile, uses, useWithStaleFast, useWithStaleFast', delayedAction, FastResult(..), use_, useNoFile_, uses_, @@ -42,6 +44,7 @@ define, defineNoDiagnostics, defineEarlyCutoff, defineOnDisk, needOnDisk, needOnDisks, + defineNoFile, defineEarlyCutOffNoFile, getDiagnostics, mRunLspT, mRunLspTCallback, getHiddenDiagnostics, @@ -83,55 +86,54 @@ import Control.Monad.Extra import Control.Monad.IO.Class import Control.Monad.Reader -import qualified Control.Monad.STM as STM import Control.Monad.Trans.Maybe -import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Char8 as BS import Data.Dynamic -import qualified Data.HashMap.Strict as HMap +import qualified Data.HashMap.Strict as HMap import Data.Hashable -import Data.List.Extra (partition, takeEnd) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map +import Data.List.Extra (partition, takeEnd) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map import Data.Maybe -import qualified Data.Set as Set -import qualified Data.SortedList as SL -import qualified Data.Text as T +import qualified Data.Set as Set +import qualified Data.SortedList as SL +import qualified Data.Text as T import Data.Time import Data.Traversable import Data.Tuple.Extra import Data.Typeable import Data.Unique -import Data.Vector (Vector) -import qualified Data.Vector as Vector +import Data.Vector (Vector) +import qualified Data.Vector as Vector import Development.IDE.Core.Debouncer import Development.IDE.Core.PositionMapping +import Development.IDE.Core.ProgressReporting import Development.IDE.Core.RuleTypes import Development.IDE.Core.Tracing -import Development.IDE.GHC.Compat (NameCacheUpdater (..), - upNameCache) -import Development.IDE.GHC.Orphans () +import Development.IDE.GHC.Compat (NameCacheUpdater (..), + upNameCache) +import Development.IDE.GHC.Orphans () +import Development.IDE.Graph hiding (ShakeValue) +import qualified Development.IDE.Graph as Shake +import Development.IDE.Graph.Classes +import Development.IDE.Graph.Database +import Development.IDE.Graph.Rule import Development.IDE.Types.Action import Development.IDE.Types.Diagnostics import Development.IDE.Types.Exports import Development.IDE.Types.KnownTargets import Development.IDE.Types.Location -import Development.IDE.Types.Logger hiding (Priority) -import qualified Development.IDE.Types.Logger as Logger +import Development.IDE.Types.Logger hiding (Priority) +import qualified Development.IDE.Types.Logger as Logger import Development.IDE.Types.Options import Development.IDE.Types.Shake -import Development.Shake hiding (Info, ShakeValue, - doesFileExist) -import qualified Development.Shake as Shake -import Development.Shake.Classes -import Development.Shake.Database -import Development.Shake.Rule import GHC.Generics import Language.LSP.Diagnostics -import qualified Language.LSP.Server as LSP +import qualified Language.LSP.Server as LSP import Language.LSP.Types -import qualified Language.LSP.Types as LSP +import qualified Language.LSP.Types as LSP import Language.LSP.VFS -import System.FilePath hiding (makeRelative) +import System.FilePath hiding (makeRelative) import System.Time.Extra import Data.IORef @@ -142,13 +144,12 @@ import PrelInfo import UniqSupply -import Control.Exception.Extra hiding (bracket_) +import Control.Exception.Extra hiding (bracket_) import Data.Default import HieDb.Types import Ide.Plugin.Config -import qualified Ide.PluginUtils as HLS -import Ide.Types (PluginId) -import UnliftIO.Exception (bracket_) +import qualified Ide.PluginUtils as HLS +import Ide.Types (PluginId) -- | We need to serialize writes to the database, so we send any function that -- needs to write to the database over the channel, where it will be picked up by @@ -183,13 +184,9 @@ -- positions in a version of that document to positions in the latest version -- First mapping is delta from previous version and second one is an -- accumlation of all previous mappings. - ,inProgress :: Var (HMap.HashMap NormalizedFilePath Int) - -- ^ How many rules are running for each file - ,progressUpdate :: ProgressEvent -> IO () + ,progress :: ProgressReporting ,ideTesting :: IdeTesting -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants - ,session :: MVar ShakeSession - -- ^ Used in the GhcSession rule to forcefully restart the session after adding a new component ,restartShakeSession :: [DelayedAction ()] -> IO () ,ideNc :: IORef NameCache -- | A mapping of module name to known target (or candidate targets, if missing) @@ -214,10 +211,6 @@ type WithIndefiniteProgressFunc = forall a. T.Text -> LSP.ProgressCancellable -> IO a -> IO a -data ProgressEvent - = KickStarted - | KickCompleted - type GetStalePersistent = NormalizedFilePath -> IdeAction (Maybe (Dynamic,PositionDelta,TextDocumentVersion)) getShakeExtras :: Action ShakeExtras @@ -384,12 +377,11 @@ -- | A Shake database plus persistent store. Can be thought of as storing -- mappings from @(FilePath, k)@ to @RuleResult k@. data IdeState = IdeState - {shakeDb :: ShakeDatabase - ,shakeSession :: MVar ShakeSession - ,shakeClose :: IO () - ,shakeExtras :: ShakeExtras - ,shakeDatabaseProfile :: ShakeDatabase -> IO (Maybe FilePath) - ,stopProgressReporting :: IO () + {shakeDb :: ShakeDatabase + ,shakeSession :: MVar ShakeSession + ,shakeClose :: IO () + ,shakeExtras :: ShakeExtras + ,shakeDatabaseProfile :: ShakeDatabase -> IO (Maybe FilePath) } @@ -477,10 +469,9 @@ shakeOpen lspEnv defaultConfig logger debouncer shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) hiedb indexQueue vfs opts rules = mdo - inProgress <- newVar HMap.empty us <- mkSplitUniqSupply 'r' ideNc <- newIORef (initNameCache us knownKeyNames) - (shakeExtras, stopProgressReporting) <- do + shakeExtras <- do globals <- newVar HMap.empty state <- newVar HMap.empty diagnostics <- newVar mempty @@ -489,31 +480,29 @@ positionMapping <- newVar HMap.empty knownTargetsVar <- newVar $ hashed HMap.empty let restartShakeSession = shakeRestart ideState - let session = shakeSession - mostRecentProgressEvent <- newTVarIO KickCompleted persistentKeys <- newVar HMap.empty - let progressUpdate = atomically . writeTVar mostRecentProgressEvent indexPending <- newTVarIO HMap.empty indexCompleted <- newTVarIO 0 indexProgressToken <- newVar Nothing let hiedbWriter = HieDbWriter{..} - progressAsync <- async $ - when reportProgress $ - progressThread optProgressStyle mostRecentProgressEvent inProgress exportsMap <- newVar mempty + progress <- do + let (before, after) = if testing then (0,0.1) else (0.1,0.1) + if reportProgress + then delayedProgressReporting before after lspEnv optProgressStyle + else noProgressReporting actionQueue <- newQueue let clientCapabilities = maybe def LSP.resClientCapabilities lspEnv - pure (ShakeExtras{..}, cancel progressAsync) + pure ShakeExtras{..} (shakeDbM, shakeClose) <- shakeOpenDatabase - opts { shakeExtra = addShakeExtra shakeExtras $ shakeExtra opts } + opts { shakeExtra = newShakeExtra shakeExtras } rules shakeDb <- shakeDbM - initSession <- newSession shakeExtras shakeDb [] - shakeSession <- newMVar initSession + shakeSession <- newEmptyMVar shakeDatabaseProfile <- shakeDatabaseProfileIO shakeProfileDir let ideState = IdeState{..} @@ -524,93 +513,12 @@ startTelemetry otProfilingEnabled logger $ state shakeExtras return ideState - where - -- The progress thread is a state machine with two states: - -- 1. Idle - -- 2. Reporting a kick event - -- And two transitions, modelled by 'ProgressEvent': - -- 1. KickCompleted - transitions from Reporting into Idle - -- 2. KickStarted - transitions from Idle into Reporting - progressThread style mostRecentProgressEvent inProgress = progressLoopIdle - where - progressLoopIdle = do - atomically $ do - v <- readTVar mostRecentProgressEvent - case v of - KickCompleted -> STM.retry - KickStarted -> return () - asyncReporter <- async $ mRunLspT lspEnv lspShakeProgress - progressLoopReporting asyncReporter - progressLoopReporting asyncReporter = do - atomically $ do - v <- readTVar mostRecentProgressEvent - case v of - KickStarted -> STM.retry - KickCompleted -> return () - cancel asyncReporter - progressLoopIdle - lspShakeProgress :: LSP.LspM config () - lspShakeProgress = do - -- first sleep a bit, so we only show progress messages if it's going to take - -- a "noticable amount of time" (we often expect a thread kill to arrive before the sleep finishes) - liftIO $ unless testing $ sleep 0.1 - u <- ProgressTextToken . T.pack . show . hashUnique <$> liftIO newUnique - - void $ LSP.sendRequest LSP.SWindowWorkDoneProgressCreate - LSP.WorkDoneProgressCreateParams { _token = u } $ const (pure ()) - - bracket_ - (start u) - (stop u) - (loop u 0) - where - start id = LSP.sendNotification LSP.SProgress $ - LSP.ProgressParams - { _token = id - , _value = LSP.Begin $ WorkDoneProgressBeginParams - { _title = "Processing" - , _cancellable = Nothing - , _message = Nothing - , _percentage = Nothing - } - } - stop id = LSP.sendNotification LSP.SProgress - LSP.ProgressParams - { _token = id - , _value = LSP.End WorkDoneProgressEndParams - { _message = Nothing - } - } - sample = 0.1 - loop id prev = do - liftIO $ sleep sample - current <- liftIO $ readVar inProgress - let done = length $ filter (== 0) $ HMap.elems current - let todo = HMap.size current - let next = 100 * fromIntegral done / fromIntegral todo - when (next /= prev) $ - LSP.sendNotification LSP.SProgress $ - LSP.ProgressParams - { _token = id - , _value = LSP.Report $ case style of - Explicit -> LSP.WorkDoneProgressReportParams - { _cancellable = Nothing - , _message = Just $ T.pack $ show done <> "/" <> show todo - , _percentage = Nothing - } - Percentage -> LSP.WorkDoneProgressReportParams - { _cancellable = Nothing - , _message = Nothing - , _percentage = Just next - } - NoProgress -> LSP.WorkDoneProgressReportParams - { _cancellable = Nothing - , _message = Nothing - , _percentage = Nothing - } - } - loop id next +-- | Must be called in the 'Initialized' handler and only once +shakeSessionInit :: IdeState -> IO () +shakeSessionInit IdeState{..} = do + initSession <- newSession shakeExtras shakeDb [] + putMVar shakeSession initSession shakeProfile :: IdeState -> FilePath -> IO () shakeProfile IdeState{..} = shakeProfileDatabase shakeDb @@ -621,7 +529,7 @@ -- request so we first abort that. void $ cancelShakeSession runner shakeClose - stopProgressReporting + progressStop $ progress shakeExtras -- | This is a variant of withMVar where the first argument is run unmasked and if it throws @@ -766,18 +674,6 @@ d' = DelayedAction (Just u) s p a' return (b, d') -mRunLspT :: Applicative m => Maybe (LSP.LanguageContextEnv c ) -> LSP.LspT c m () -> m () -mRunLspT (Just lspEnv) f = LSP.runLspT lspEnv f -mRunLspT Nothing _ = pure () - -mRunLspTCallback :: Monad m - => Maybe (LSP.LanguageContextEnv c) - -> (LSP.LspT c m a -> LSP.LspT c m a) - -> m a - -> m a -mRunLspTCallback (Just lspEnv) f g = LSP.runLspT lspEnv $ f (lift g) -mRunLspTCallback Nothing _ g = g - getDiagnostics :: IdeState -> IO [FileDiagnostic] getDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do val <- readVar diagnostics @@ -933,11 +829,21 @@ :: IdeRule k v => RuleBody k v -> Rules () -defineEarlyCutoff (Rule op) = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file isSuccess $ do +defineEarlyCutoff (Rule op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file isSuccess $ do defineEarlyCutoff' True key file old mode $ op key file -defineEarlyCutoff (RuleNoDiagnostics op) = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file isSuccess $ do +defineEarlyCutoff (RuleNoDiagnostics op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file isSuccess $ do defineEarlyCutoff' False key file old mode $ second (mempty,) <$> op key file +defineNoFile :: IdeRule k v => (k -> Action v) -> Rules () +defineNoFile f = defineNoDiagnostics $ \k file -> do + if file == emptyFilePath then do res <- f k; return (Just res) else + fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file" + +defineEarlyCutOffNoFile :: IdeRule k v => (k -> Action (BS.ByteString, v)) -> Rules () +defineEarlyCutOffNoFile f = defineEarlyCutoff $ RuleNoDiagnostics $ \k file -> do + if file == emptyFilePath then do (hash, res) <- f k; return (Just hash, Just res) else + fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file" + defineEarlyCutoff' :: IdeRule k v => Bool -- ^ update diagnostics @@ -948,9 +854,9 @@ -> Action (Maybe BS.ByteString, IdeResult v) -> Action (RunResult (A (RuleResult k))) defineEarlyCutoff' doDiagnostics key file old mode action = do - extras@ShakeExtras{state, inProgress, logger} <- getShakeExtras + extras@ShakeExtras{state, progress, logger} <- getShakeExtras options <- getIdeOptions - (if optSkipProgress options key then id else withProgressVar inProgress file) $ do + (if optSkipProgress options key then id else inProgress progress file) $ do val <- case old of Just old | mode == RunDependenciesSame -> do v <- liftIO $ getValues state key file @@ -997,15 +903,7 @@ (if eq then ChangedRecomputeSame else ChangedRecomputeDiff) (encodeShakeValue bs) $ A res - where - withProgressVar :: (Eq a, Hashable a) => Var (HMap.HashMap a Int) -> a -> Action b -> Action b - withProgressVar var file = actionBracket (f succ) (const $ f pred) . const - -- This functions are deliberately eta-expanded to avoid space leaks. - -- Do not remove the eta-expansion without profiling a session with at - -- least 1000 modifications. - where f shift = void $ modifyVar' var $ HMap.insertWith (\_ x -> shift x) file (shift 0) - isSuccess :: RunResult (A v) -> Bool isSuccess (RunResult _ _ (A Failed{})) = False isSuccess _ = True @@ -1046,7 +944,7 @@ :: (Shake.ShakeValue k, RuleResult k ~ ()) => (k -> NormalizedFilePath -> OnDiskRule) -> Rules () -defineOnDisk act = addBuiltinRule noLint noIdentity $ +defineOnDisk act = addRule $ \(QDisk key file) (mbOld :: Maybe BS.ByteString) mode -> do extras <- getShakeExtras let OnDiskRule{..} = act key file 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,6 +1,5 @@ {-# LANGUAGE NoApplicativeDo #-} {-# LANGUAGE CPP #-} -#include "ghc-api-version.h" module Development.IDE.Core.Tracing ( otTracedHandler , otTracedAction @@ -38,7 +37,7 @@ import Development.IDE.Types.Shake (Key (..), Value, ValueWithDiagnostics (..), Values) -import Development.Shake (Action, actionBracket) +import Development.IDE.Graph (Action, actionBracket) import Foreign.Storable (Storable (sizeOf)) import HeapSize (recursiveSize, runHeapsize) import Ide.PluginUtils (installSigUsr1Handler) @@ -96,7 +95,7 @@ return res) | otherwise = act -#if MIN_GHC_API_VERSION(8,8,0) +#if MIN_VERSION_ghc(8,8,0) otTracedProvider :: MonadUnliftIO m => PluginId -> ByteString -> m a -> m a #else otTracedProvider :: MonadUnliftIO m => PluginId -> String -> m a -> m a @@ -230,4 +229,3 @@ case res of Nothing -> repeatUntilJust (nattempts-1) action Just{} -> return res - diff --git a/src/Development/IDE/Core/UseStale.hs b/src/Development/IDE/Core/UseStale.hs --- a/src/Development/IDE/Core/UseStale.hs +++ b/src/Development/IDE/Core/UseStale.hs @@ -58,7 +58,7 @@ -- change. Use the 'Category' instance to compose 'PositionMapping's in order -- to transform between values of different stale ages. newtype PositionMap (from :: Age) (to :: Age) = PositionMap - { getPositionMapping :: P.PositionMapping + { _getPositionMapping :: P.PositionMapping } instance Category PositionMap where 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 @@ -12,7 +12,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NondecreasingIndentation #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -#include "ghc-api-version.h" ----------------------------------------------------------------------------- -- @@ -31,12 +30,12 @@ import Packages import Panic import SysTools -#if MIN_GHC_API_VERSION(8,8,2) +#if MIN_VERSION_ghc(8,8,2) import LlvmCodeGen (llvmVersionList) -#elif MIN_GHC_API_VERSION(8,8,0) +#elif MIN_VERSION_ghc(8,8,0) import LlvmCodeGen (LlvmVersion (..)) #endif -#if MIN_GHC_API_VERSION (8,10,0) +#if MIN_VERSION_ghc (8,10,0) import Fingerprint import ToolSettings #endif @@ -66,7 +65,7 @@ let verbFlags = getVerbFlags dflags let cpp_prog args | raw = SysTools.runCpp dflags args -#if MIN_GHC_API_VERSION(8,10,0) +#if MIN_VERSION_ghc(8,10,0) | otherwise = SysTools.runCc Nothing #else | otherwise = SysTools.runCc @@ -150,11 +149,11 @@ getBackendDefs dflags | hscTarget dflags == HscLlvm = do llvmVer <- figureLlvmVersion dflags return $ case llvmVer of -#if MIN_GHC_API_VERSION(8,8,2) +#if MIN_VERSION_ghc(8,8,2) Just v | [m] <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, 0) ] | m:n:_ <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, n) ] -#elif MIN_GHC_API_VERSION(8,8,0) +#elif MIN_VERSION_ghc(8,8,0) Just (LlvmVersion n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (n,0) ] Just (LlvmVersionOld m n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ] #else @@ -170,7 +169,7 @@ return [] addOptP :: String -> DynFlags -> DynFlags -#if MIN_GHC_API_VERSION (8,10,0) +#if MIN_VERSION_ghc (8,10,0) addOptP f = alterToolSettings $ \s -> s { toolSettings_opt_P = f : toolSettings_opt_P s , toolSettings_opt_P_fingerprint = fingerprintStrings (f : toolSettings_opt_P s) 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 @@ -6,7 +6,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PatternSynonyms #-} {-# OPTIONS -Wno-dodgy-imports -Wno-incomplete-uni-patterns #-} -#include "ghc-api-version.h" -- | Attempt at hiding the GHC version differences we can. module Development.IDE.GHC.Compat( @@ -23,7 +22,7 @@ supportsHieFiles, setHieDir, dontWriteHieFiles, -#if !MIN_GHC_API_VERSION(8,8,0) +#if !MIN_VERSION_ghc(8,8,0) ml_hie_file, addBootSuffixLocnOut, #endif @@ -44,7 +43,7 @@ tcg_exports, pattern FunTy, -#if MIN_GHC_API_VERSION(8,10,0) +#if MIN_VERSION_ghc(8,10,0) module GHC.Hs.Extension, module LinkerTypes, #else @@ -62,7 +61,7 @@ dropForAll ,isQualifiedImport) where -#if MIN_GHC_API_VERSION(8,10,0) +#if MIN_VERSION_ghc(8,10,0) import LinkerTypes #endif @@ -83,7 +82,7 @@ import Compat.HieTypes import Compat.HieUtils -#if MIN_GHC_API_VERSION(8,10,0) +#if MIN_VERSION_ghc(8,10,0) import GHC.Hs.Extension #else import HsExtension @@ -98,7 +97,7 @@ getLoc ) import Avail -#if MIN_GHC_API_VERSION(8,8,0) +#if MIN_VERSION_ghc(8,8,0) import Data.List (foldl') #else import Data.List (foldl', isSuffixOf) @@ -108,11 +107,11 @@ import Plugins (Plugin(parsedResultAction), withPlugins) import Data.Map.Strict (Map) -#if !MIN_GHC_API_VERSION(8,8,0) +#if !MIN_VERSION_ghc(8,8,0) import System.FilePath ((-<.>)) #endif -#if !MIN_GHC_API_VERSION(8,8,0) +#if !MIN_VERSION_ghc(8,8,0) import qualified EnumSet import System.IO @@ -126,7 +125,7 @@ #endif -#if !MIN_GHC_API_VERSION(8,10,0) +#if !MIN_VERSION_ghc(8,10,0) noExtField :: NoExt noExtField = noExt #endif @@ -137,7 +136,7 @@ hieExportNames :: HieFile -> [(SrcSpan, Name)] hieExportNames = nameListFromAvails . hie_exports -#if !MIN_GHC_API_VERSION(8,8,0) +#if !MIN_VERSION_ghc(8,8,0) ml_hie_file :: GHC.ModLocation -> FilePath ml_hie_file ml | "boot" `isSuffixOf ` ml_hi_file ml = ml_hi_file ml -<.> ".hie-boot" @@ -145,7 +144,7 @@ #endif upNameCache :: IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c -#if !MIN_GHC_API_VERSION(8,8,0) +#if !MIN_VERSION_ghc(8,8,0) upNameCache ref upd_fn = atomicModifyIORef' ref upd_fn #else @@ -179,7 +178,7 @@ pattern ModLocation :: Maybe FilePath -> FilePath -> FilePath -> GHC.ModLocation pattern ModLocation a b c <- -#if MIN_GHC_API_VERSION(8,8,0) +#if MIN_VERSION_ghc(8,8,0) GHC.ModLocation a b c _ where ModLocation a b c = GHC.ModLocation a b c "" #else GHC.ModLocation a b c where ModLocation a b c = GHC.ModLocation a b c @@ -187,7 +186,7 @@ setHieDir :: FilePath -> DynFlags -> DynFlags setHieDir _f d = -#if MIN_GHC_API_VERSION(8,8,0) +#if MIN_VERSION_ghc(8,8,0) d { hieDir = Just _f} #else d @@ -195,7 +194,7 @@ dontWriteHieFiles :: DynFlags -> DynFlags dontWriteHieFiles d = -#if MIN_GHC_API_VERSION(8,8,0) +#if MIN_VERSION_ghc(8,8,0) gopt_unset d Opt_WriteHie #else d @@ -204,7 +203,7 @@ setUpTypedHoles ::DynFlags -> DynFlags setUpTypedHoles df = flip gopt_unset Opt_AbstractRefHoleFits -- too spammy -#if MIN_GHC_API_VERSION(8,8,0) +#if MIN_VERSION_ghc(8,8,0) $ flip gopt_unset Opt_ShowDocsOfHoleFits -- not used #endif $ flip gopt_unset Opt_ShowMatchesOfHoleFits -- nice but broken (forgets module qualifiers) @@ -226,7 +225,7 @@ nameListFromAvails as = map (\n -> (nameSrcSpan n, n)) (concatMap availNames as) -#if MIN_GHC_API_VERSION(8,8,0) +#if MIN_VERSION_ghc(8,8,0) type HasSrcSpan = GHC.HasSrcSpan getLoc :: HasSrcSpan a => a -> SrcSpan @@ -251,7 +250,7 @@ #endif getModuleHash :: ModIface -> Fingerprint -#if MIN_GHC_API_VERSION(8,10,0) +#if MIN_VERSION_ghc(8,10,0) getModuleHash = mi_mod_hash . mi_final_exts #else getModuleHash = mi_mod_hash @@ -264,7 +263,7 @@ disableWarningsAsErrors df = flip gopt_unset Opt_WarnIsError $ foldl' wopt_unset_fatal df [toEnum 0 ..] -#if !MIN_GHC_API_VERSION(8,8,0) +#if !MIN_VERSION_ghc(8,8,0) wopt_unset_fatal :: DynFlags -> WarningFlag -> DynFlags wopt_unset_fatal dfs f = dfs { fatalWarningFlags = EnumSet.delete f (fatalWarningFlags dfs) } @@ -288,21 +287,21 @@ -- | Take AST representation of type signature and drop `forall` part from it (if any), returning just type's body dropForAll :: LHsType pass -> LHsType pass -#if MIN_GHC_API_VERSION(8,10,0) +#if MIN_VERSION_ghc(8,10,0) dropForAll = snd . GHC.splitLHsForAllTyInvis #else dropForAll = snd . GHC.splitLHsForAllTy #endif pattern FunTy :: Type -> Type -> Type -#if MIN_GHC_API_VERSION(8, 10, 0) +#if MIN_VERSION_ghc(8, 10, 0) pattern FunTy arg res <- TyCoRep.FunTy {ft_arg = arg, ft_res = res} #else pattern FunTy arg res <- TyCoRep.FunTy arg res #endif isQualifiedImport :: ImportDecl a -> Bool -#if MIN_GHC_API_VERSION(8,10,0) +#if MIN_VERSION_ghc(8,10,0) isQualifiedImport ImportDecl{ideclQualified = NotQualified} = False isQualifiedImport ImportDecl{} = True #else diff --git a/src/Development/IDE/GHC/ExactPrint.hs b/src/Development/IDE/GHC/ExactPrint.hs --- a/src/Development/IDE/GHC/ExactPrint.hs +++ b/src/Development/IDE/GHC/ExactPrint.hs @@ -12,6 +12,7 @@ annotateDecl, hoistGraft, graftWithM, + graftExprWithM, genericGraftWithSmallestM, genericGraftWithLargestM, graftSmallestDeclsWithM, @@ -27,9 +28,7 @@ TransformT, Anns, Annotate, - mkBindListT, setPrecedingLinesT, - everywhereM', ) where @@ -51,10 +50,11 @@ import Development.IDE.Core.Shake import Development.IDE.GHC.Compat hiding (parseExpr) import Development.IDE.Types.Location -import Development.Shake (RuleResult, Rules) -import Development.Shake.Classes +import Development.IDE.Graph (RuleResult, Rules) +import Development.IDE.Graph.Classes import qualified GHC.Generics as GHC import Generics.SYB +import Generics.SYB.GHC import Ide.PluginUtils import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Parsers @@ -66,11 +66,8 @@ import Data.Traversable (for) import Data.Foldable (Foldable(fold)) import Data.Bool (bool) -import Data.Monoid (All(All), Any(Any)) -import Data.Functor.Compose (Compose(Compose)) -#if __GLASGOW_HASKELL__ == 808 +import Data.Monoid (All(All), getAll) import Control.Arrow -#endif ------------------------------------------------------------------------------ @@ -246,25 +243,64 @@ LHsExpr GhcPs -> Graft (Either String) a graftExpr dst val = Graft $ \dflags a -> do - -- Traverse the tree, looking for our replacement node. But keep track of - -- the context (parent HsExpr constructor) we're in while we do it. This - -- lets us determine wehther or not we need parentheses. - let (All needs_parens, All needs_space) = - everythingWithContext (All True, All True) (<>) - ( mkQ (mempty, ) $ \x s -> case x of - (L src _ :: LHsExpr GhcPs) | src == dst -> - (s, s) - L _ x' -> (mempty, needsParensSpace x') - ) a + let (needs_space, mk_parens) = getNeedsSpaceAndParenthesize dst a runGraft - (graft' needs_space dst $ bool id maybeParensAST needs_parens val) + (graft' needs_space dst $ mk_parens val) dflags a +getNeedsSpaceAndParenthesize :: + (ASTElement ast, Data a) => + SrcSpan -> + a -> + (Bool, Located ast -> Located ast) +getNeedsSpaceAndParenthesize dst a = + -- Traverse the tree, looking for our replacement node. But keep track of + -- the context (parent HsExpr constructor) we're in while we do it. This + -- lets us determine wehther or not we need parentheses. + let (needs_parens, needs_space) = + everythingWithContext (Nothing, Nothing) (<>) + ( mkQ (mempty, ) $ \x s -> case x of + (L src _ :: LHsExpr GhcPs) | src == dst -> + (s, s) + L _ x' -> (mempty, Just *** Just $ needsParensSpace x') + ) a + in ( maybe True getAll needs_space + , bool id maybeParensAST $ maybe False getAll needs_parens + ) + + ------------------------------------------------------------------------------ +graftExprWithM :: + forall m a. + (Fail.MonadFail m, Data a) => + SrcSpan -> + (LHsExpr GhcPs -> TransformT m (Maybe (LHsExpr GhcPs))) -> + Graft m a +graftExprWithM dst trans = Graft $ \dflags a -> do + let (needs_space, mk_parens) = getNeedsSpaceAndParenthesize dst a + + everywhereM' + ( mkM $ + \case + val@(L src _ :: LHsExpr GhcPs) + | src == dst -> do + mval <- trans val + case mval of + Just val' -> do + (anns, val'') <- + hoistTransform (either Fail.fail pure) + (annotate @(HsExpr GhcPs) dflags needs_space (mk_parens val')) + modifyAnnsT $ mappend anns + pure val'' + Nothing -> pure val + l -> pure l + ) + a + graftWithM :: forall ast m a. (Fail.MonadFail m, Data a, ASTElement ast) => @@ -290,21 +326,6 @@ ) a --- | A generic query intended to be used for calling 'smallestM' and --- 'largestM'. If the current node is a 'Located', returns whether or not the --- given 'SrcSpan' is a subspan. For all other nodes, returns 'Nothing', which --- indicates uncertainty. The search strategy in 'smallestM' et al. will --- continue searching uncertain nodes. -genericIsSubspan :: - forall ast. - Typeable ast => - -- | The type of nodes we'd like to consider. - Proxy (Located ast) -> - SrcSpan -> - GenericQ (Maybe Bool) -genericIsSubspan _ dst = mkQ Nothing $ \case - (L span _ :: Located ast) -> Just $ dst `isSubspanOf` span - -- | Run the given transformation only on the smallest node in the tree that -- contains the 'SrcSpan'. genericGraftWithSmallestM :: @@ -332,15 +353,6 @@ largestM (genericIsSubspan proxy dst) (trans dflags) --- | Lift a function that replaces a value with several values into a generic --- function. The result doesn't perform any searching, so should be driven via --- 'everywhereM' or friends. --- --- The 'Int' argument is the index in the list being bound. -mkBindListT :: forall b m. (Data b, Monad m) => (Int -> b -> m [b]) -> GenericM m -mkBindListT f = mkM $ fmap join . traverse (uncurry f) . zip [0..] - - graftDecls :: forall a. (HasDecls a) => @@ -394,12 +406,6 @@ modifyDeclsT (fmap DL.toList . go) a -everywhereM' :: forall m. Monad m => GenericM m -> GenericM m -everywhereM' f = go - where - go :: GenericM m - go = gmapM go <=< f - class (Data ast, Outputable ast) => ASTElement ast where parseAST :: Parser (Located ast) maybeParensAST :: Located ast -> Located ast @@ -508,77 +514,4 @@ -- | Put parentheses around an expression if required. parenthesize :: LHsExpr GhcPs -> LHsExpr GhcPs parenthesize = parenthesizeHsExpr appPrec - - ------------------------------------------------------------------------------- --- Custom SYB machinery ------------------------------------------------------------------------------- - --- | Generic monadic transformations that return side-channel data. -type GenericMQ r m = forall a. Data a => a -> m (r, a) - ------------------------------------------------------------------------------- --- | Apply the given 'GenericM' at all every node whose children fail the --- 'GenericQ', but which passes the query itself. --- --- The query must be a monotonic function when it returns 'Just'. That is, if --- @s@ is a subtree of @t@, @q t@ should return @Just True@ if @q s@ does. It --- is the True-to-false edge of the query that triggers the transformation. --- --- Why is the query a @Maybe Bool@? The GHC AST intersperses 'Located' nodes --- with data nodes, so for any given node we can only definitely return an --- answer if it's a 'Located'. See 'genericIsSubspan' for how this parameter is --- used. -smallestM :: forall m. Monad m => GenericQ (Maybe Bool) -> GenericM m -> GenericM m -smallestM q f = fmap snd . go - where - go :: GenericMQ Any m - go x = do - case q x of - Nothing -> gmapMQ go x - Just True -> do - it@(r, x') <- gmapMQ go x - case r of - Any True -> pure it - Any False -> fmap (Any True,) $ f x' - Just False -> pure (mempty, x) - ------------------------------------------------------------------------------- --- | Apply the given 'GenericM' at every node that passes the 'GenericQ', but --- don't descend into children if the query matches. Because this traversal is --- root-first, this policy will find the largest subtrees for which the query --- holds true. --- --- Why is the query a @Maybe Bool@? The GHC AST intersperses 'Located' nodes --- with data nodes, so for any given node we can only definitely return an --- answer if it's a 'Located'. See 'genericIsSubspan' for how this parameter is --- used. -largestM :: forall m. Monad m => GenericQ (Maybe Bool) -> GenericM m -> GenericM m -largestM q f = go - where - go :: GenericM m - go x = do - case q x of - Just True -> f x - Just False -> pure x - Nothing -> gmapM go x - -newtype MonadicQuery r m a = MonadicQuery - { runMonadicQuery :: m (r, a) - } - deriving stock (Functor) - deriving Applicative via Compose m ((,) r) - - ------------------------------------------------------------------------------- --- | Like 'gmapM', but also returns side-channel data. -gmapMQ :: - forall f r a. (Monoid r, Data a, Applicative f) => - (forall d. Data d => d -> f (r, d)) -> - a -> - f (r, a) -gmapMQ f = runMonadicQuery . gfoldl k pure - where - k :: Data d => MonadicQuery r f (d -> b) -> d -> MonadicQuery r f b - k c x = c <*> MonadicQuery (f x) 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 @@ -4,7 +4,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} -#include "ghc-api-version.h" -- | Orphan instances for GHC. -- Note that the 'NFData' instances may not be law abiding. @@ -64,7 +63,7 @@ instance NFData ModSummary where rnf = rwhnf -#if !MIN_GHC_API_VERSION(8,10,0) +#if !MIN_VERSION_ghc(8,10,0) instance NFData FastString where rnf = rwhnf #endif 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 @@ -2,7 +2,6 @@ -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE CPP #-} -#include "ghc-api-version.h" module Development.IDE.Import.FindImports ( locateModule 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 @@ -104,6 +104,10 @@ setSomethingModified ide , mkPluginNotificationHandler LSP.SInitialized $ \ide _ _ -> do + --------- Initialize Shake session -------------------------------------------------------------------- + liftIO $ shakeSessionInit ide + + --------- Set up file watchers ------------------------------------------------------------------------ clientCapabilities <- LSP.getClientCapabilities let watchSupported = case () of _ | LSP.ClientCapabilities{_workspace} <- clientCapabilities 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 @@ -3,7 +3,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} -#include "ghc-api-version.h" module Development.IDE.LSP.Outline ( moduleOutline @@ -194,7 +193,7 @@ (defDocumentSymbol l :: DocumentSymbol) { _name = "import " <> pprText ideclName , _kind = SkModule -#if MIN_GHC_API_VERSION(8,10,0) +#if MIN_VERSION_ghc(8,10,0) , _detail = case ideclQualified of { NotQualified -> Nothing; _ -> Just "qualified" } #else , _detail = if ideclQualified then Just "qualified" else Nothing 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 @@ -42,8 +42,9 @@ import Development.IDE.Core.Service (initialise, runAction) import Development.IDE.Core.Shake (IdeState (shakeExtras), ShakeExtras (state), - uses) + shakeSessionInit, uses) import Development.IDE.Core.Tracing (measureMemory) +import Development.IDE.Graph (action) import Development.IDE.LSP.LanguageServer (runLanguageServer) import Development.IDE.Plugin (Plugin (pluginHandlers, pluginRules)) import Development.IDE.Plugin.HLS (asGhcIdePlugin) @@ -61,7 +62,6 @@ clientSupportsProgress, defaultIdeOptions) import Development.IDE.Types.Shake (Key (Key)) -import Development.Shake (action) import GHC.IO.Encoding (setLocaleEncoding) import GHC.IO.Handle (hDuplicate) import HIE.Bios.Cradle (findCradle) @@ -261,6 +261,7 @@ , optCheckProject = pure False } ide <- initialise argsDefaultHlsConfig rules Nothing logger debouncer options vfs hiedb hieChan + shakeSessionInit ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) putStrLn "\nStep 4/4: Type checking the files" @@ -309,6 +310,7 @@ optCheckProject = pure False } ide <- initialise argsDefaultHlsConfig rules Nothing logger debouncer options vfs hiedb hieChan + shakeSessionInit ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) c ide diff --git a/src/Development/IDE/Plugin.hs b/src/Development/IDE/Plugin.hs --- a/src/Development/IDE/Plugin.hs +++ b/src/Development/IDE/Plugin.hs @@ -1,7 +1,7 @@ module Development.IDE.Plugin ( Plugin(..) ) where import Data.Default -import Development.Shake +import Development.IDE.Graph import Development.IDE.LSP.Server import qualified Language.LSP.Server as LSP diff --git a/src/Development/IDE/Plugin/CodeAction.hs b/src/Development/IDE/Plugin/CodeAction.hs --- a/src/Development/IDE/Plugin/CodeAction.hs +++ b/src/Development/IDE/Plugin/CodeAction.hs @@ -3,7 +3,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DuplicateRecordFields #-} -#include "ghc-api-version.h" -- | Go to the definition of a variable. @@ -14,7 +13,8 @@ , matchRegExMultipleImports ) where -import Bag (isEmptyBag) +import Bag (bagToList, + isEmptyBag) import Control.Applicative ((<|>)) import Control.Arrow (second, (>>>)) @@ -72,7 +72,6 @@ showSDocUnsafe) import RdrName (GlobalRdrElt (..), lookupGlobalRdrEnv) -import Safe (atMay) import SrcLoc (realSrcSpanEnd, realSrcSpanStart) import TcRnTypes (ImportAvails (..), @@ -162,6 +161,57 @@ any (pred . unLoc) idsSig ] +findSigOfDeclRanged :: Range -> [LHsDecl p] -> Maybe (Sig p) +findSigOfDeclRanged range decls = do + dec <- findDeclContainingLoc (_start range) decls + case dec of + L _ (SigD _ sig@TypeSig {}) -> Just sig + L _ (ValD _ (bind :: HsBind p)) -> findSigOfBind range bind + _ -> Nothing + +findSigOfBind :: Range -> HsBind p -> Maybe (Sig p) +findSigOfBind range bind = + case bind of + FunBind {} -> findSigOfLMatch (unLoc $ mg_alts (fun_matches bind)) + _ -> Nothing + where + findSigOfLMatch :: [LMatch p (LHsExpr p)] -> Maybe (Sig p) + findSigOfLMatch ls = do + match <- findDeclContainingLoc (_start range) ls + findSigOfGRHSs (m_grhss (unLoc match)) + + findSigOfGRHSs :: GRHSs p (LHsExpr p) -> Maybe (Sig p) + findSigOfGRHSs grhs = do + if _start range `isInsideSrcSpan` (getLoc $ grhssLocalBinds grhs) + then findSigOfBinds range (unLoc (grhssLocalBinds grhs)) -- where clause + else do + grhs <- findDeclContainingLoc (_start range) (grhssGRHSs grhs) + case unLoc grhs of + GRHS _ _ bd -> findSigOfExpr (unLoc bd) + _ -> Nothing + + findSigOfExpr :: HsExpr p -> Maybe (Sig p) + findSigOfExpr = go + where + go (HsLet _ binds _) = findSigOfBinds range (unLoc binds) + go (HsDo _ _ stmts) = do + stmtlr <- unLoc <$> findDeclContainingLoc (_start range) (unLoc stmts) + case stmtlr of + LetStmt _ lhsLocalBindsLR -> findSigOfBinds range $ unLoc lhsLocalBindsLR + _ -> Nothing + go _ = Nothing + +findSigOfBinds :: Range -> HsLocalBinds p -> Maybe (Sig p) +findSigOfBinds range = go + where + go (HsValBinds _ (ValBinds _ binds lsigs)) = + case unLoc <$> findDeclContainingLoc (_start range) lsigs of + Just sig' -> Just sig' + Nothing -> do + lHsBindLR <- findDeclContainingLoc (_start range) (bagToList binds) + findSigOfBind range (unLoc lHsBindLR) + go _ = Nothing + findInstanceHead :: (Outputable (HsType p)) => DynFlags -> String -> [LHsDecl p] -> Maybe (LHsType p) findInstanceHead df instanceHead decls = listToMaybe @@ -173,6 +223,7 @@ findDeclContainingLoc :: Position -> [Located a] -> Maybe (Located a) findDeclContainingLoc loc = find (\(L l _) -> loc `isInsideSrcSpan` l) + -- Single: -- This binding for ‘mod’ shadows the existing binding -- imported from ‘Prelude’ at haskell-language-server/ghcide/src/Development/IDE/Plugin/CodeAction.hs:10:8-40 @@ -677,16 +728,24 @@ suggestFillHole :: Diagnostic -> [(T.Text, TextEdit)] suggestFillHole Diagnostic{_range=_range,..} | Just holeName <- extractHoleName _message - , (holeFits, refFits) <- processHoleSuggestions (T.lines _message) - = map (proposeHoleFit holeName False) holeFits - ++ map (proposeHoleFit holeName True) refFits + , (holeFits, refFits) <- processHoleSuggestions (T.lines _message) = + let isInfixHole = _message =~ addBackticks holeName :: Bool in + map (proposeHoleFit holeName False isInfixHole) holeFits + ++ map (proposeHoleFit holeName True isInfixHole) refFits | otherwise = [] where extractHoleName = fmap head . flip matchRegexUnifySpaces "Found hole: ([^ ]*)" - proposeHoleFit holeName parenthise name = + addBackticks text = "`" <> text <> "`" + addParens text = "(" <> text <> ")" + proposeHoleFit holeName parenthise isInfixHole name = + let isInfixOperator = T.head name == '(' + name' = getOperatorNotation isInfixHole isInfixOperator name in ( "replace " <> holeName <> " with " <> name - , TextEdit _range $ if parenthise then parens name else name) - parens x = "(" <> x <> ")" + , TextEdit _range (if parenthise then addParens name' else name') + ) + getOperatorNotation True False name = addBackticks name + getOperatorNotation True True name = T.drop 1 (T.dropEnd 1 name) + getOperatorNotation _isInfixHole _isInfixOperator name = name processHoleSuggestions :: [T.Text] -> ([T.Text], [T.Text]) processHoleSuggestions mm = (holeSuggestions, refSuggestions) @@ -760,7 +819,7 @@ | otherwise = [] where suggestions decls binding mod srcspan - | range <- case [ x | (x,"") <- readSrcSpan (T.unpack srcspan)] of + | range <- case [ x | (x,"") <- readSrcSpan (T.unpack srcspan)] of [s] -> let x = realSrcSpanToRange s in x{_end = (_end x){_character = succ (_character (_end x))}} _ -> error "bug in srcspan parser", @@ -775,8 +834,13 @@ | otherwise = [] lookupExportMap binding mod | Just match <- Map.lookup binding (getExportsMap exportsMap) - , [ident] <- filter (\ident -> moduleNameText ident == mod) (Set.toList match) - = Just ident + -- Only for the situation that data constructor name is same as type constructor name, + -- let ident with parent be in front of the one without. + , sortedMatch <- sortBy (\ident1 ident2 -> parent ident2 `compare` parent ident1) (Set.toList match) + , idents <- filter (\ident -> moduleNameText ident == mod) sortedMatch + , (not . null) idents -- Ensure fallback while `idents` is empty + , ident <- head idents + = Just ident -- fallback to using GHC suggestion even though it is not always correct | otherwise @@ -858,7 +922,7 @@ | otherwise = case mapM toModuleTarget mods of Just targets -> suggestionsImpl symbol (oneAndOthers targets) Nothing -> [] - suggestionsImpl symbol targetsWithRestImports = + suggestionsImpl symbol targetsWithRestImports = sortOn fst [ ( renderUniquify mode modNameText symbol , disambiguateSymbol ps diag symbol mode @@ -1035,10 +1099,6 @@ findTypeSignatureName :: T.Text -> Maybe T.Text findTypeSignatureName t = matchRegexUnifySpaces t "([^ ]+) :: " <&> head -findTypeSignatureLine :: T.Text -> T.Text -> Int -findTypeSignatureLine contents typeSignatureName = - T.splitOn (typeSignatureName <> " :: ") contents & head & T.lines & length - -- | Suggests a constraint for a type signature with any number of existing constraints. suggestFunctionConstraint :: DynFlags -> ParsedSource -> Diagnostic -> T.Text -> [(T.Text, Rewrite)] @@ -1077,31 +1137,26 @@ <> "` to the context of the type signature for `" <> typeSignatureName <> "`" -- | Suggests the removal of a redundant constraint for a type signature. -removeRedundantConstraints :: Maybe T.Text -> Diagnostic -> [(T.Text, TextEdit)] -removeRedundantConstraints mContents Diagnostic{..} +removeRedundantConstraints :: DynFlags -> ParsedSource -> Diagnostic -> [(T.Text, Rewrite)] +removeRedundantConstraints df (L _ HsModule {hsmodDecls}) Diagnostic{..} -- • Redundant constraint: Eq a -- • In the type signature for: -- foo :: forall a. Eq a => a -> a -- • Redundant constraints: (Monoid a, Show a) -- • In the type signature for: -- foo :: forall a. (Num a, Monoid a, Eq a, Show a) => a -> Bool - | Just contents <- mContents -- Account for both "Redundant constraint" and "Redundant constraints". - , True <- "Redundant constraint" `T.isInfixOf` _message + | "Redundant constraint" `T.isInfixOf` _message , Just typeSignatureName <- findTypeSignatureName _message + , Just (TypeSig _ _ HsWC{hswc_body = HsIB {hsib_body = sig}}) + <- findSigOfDeclRanged _range hsmodDecls , Just redundantConstraintList <- findRedundantConstraints _message - , Just constraints <- findConstraints contents typeSignatureName - = let constraintList = parseConstraints constraints - newConstraints = buildNewConstraints constraintList redundantConstraintList - typeSignatureLine = findTypeSignatureLine contents typeSignatureName - typeSignatureFirstChar = T.length $ typeSignatureName <> " :: " - startOfConstraint = Position typeSignatureLine typeSignatureFirstChar - endOfConstraint = Position typeSignatureLine $ - typeSignatureFirstChar + T.length (constraints <> " => ") - range = Range startOfConstraint endOfConstraint - in [(actionTitle redundantConstraintList typeSignatureName, TextEdit range newConstraints)] + , rewrite <- removeConstraint (toRemove df redundantConstraintList) sig + = [(actionTitle redundantConstraintList typeSignatureName, rewrite)] | otherwise = [] where + toRemove df list a = showSDoc df (ppr a) `elem` (T.unpack <$> list) + parseConstraints :: T.Text -> [T.Text] parseConstraints t = t & (T.strip >>> stripConstraintsParens >>> T.splitOn ",") @@ -1121,31 +1176,12 @@ & (`matchRegexUnifySpaces` "Redundant constraints?: (.+)") <&> (head >>> parseConstraints) - -- If the type signature is not formatted as expected (arbitrary number of spaces, - -- line feeds...), just fail. - findConstraints :: T.Text -> T.Text -> Maybe T.Text - findConstraints contents typeSignatureName = do - constraints <- contents - & T.splitOn (typeSignatureName <> " :: ") - & (`atMay` 1) - >>= (T.splitOn " => " >>> (`atMay` 0)) - guard $ not $ "\n" `T.isInfixOf` constraints || T.strip constraints /= constraints - return constraints - formatConstraints :: [T.Text] -> T.Text formatConstraints [] = "" formatConstraints [constraint] = constraint formatConstraints constraintList = constraintList & T.intercalate ", " & \cs -> "(" <> cs <> ")" - - formatConstraintsWithArrow :: [T.Text] -> T.Text - formatConstraintsWithArrow [] = "" - formatConstraintsWithArrow cs = cs & formatConstraints & (<> " => ") - - buildNewConstraints :: [T.Text] -> [T.Text] -> T.Text - buildNewConstraints constraintList redundantConstraintList = - formatConstraintsWithArrow $ constraintList \\ redundantConstraintList actionTitle :: [T.Text] -> T.Text -> T.Text actionTitle constraintList typeSignatureName = diff --git a/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs b/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs --- a/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs +++ b/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs @@ -11,6 +11,7 @@ -- * Utilities appendConstraint, + removeConstraint, extendImport, hideSymbol, liftParseAST, @@ -118,6 +119,22 @@ dropHsParTy :: LHsType pass -> LHsType pass dropHsParTy (L _ (HsParTy _ ty)) = ty dropHsParTy other = other + +removeConstraint :: + -- | Predicate: Which context to drop. + (LHsType GhcPs -> Bool) -> + LHsType GhcPs -> + Rewrite +removeConstraint toRemove = go + where + go (L l it@HsQualTy{hst_ctxt = L l' ctxt, hst_body}) = Rewrite l $ \_ -> do + let ctxt' = L l' $ filter (not . toRemove) ctxt + when ((toRemove <$> headMaybe ctxt) == Just True) $ + setEntryDPT hst_body (DP (0, 0)) + return $ L l $ it{hst_ctxt = ctxt'} + go (L _ (HsParTy _ ty)) = go ty + go (L _ HsForAllTy{hst_body}) = go hst_body + go (L l other) = Rewrite l $ \_ -> return $ L l other -- | Append a constraint at the end of a type context. -- If no context is present, a new one will be created. diff --git a/src/Development/IDE/Plugin/Completions.hs b/src/Development/IDE/Plugin/Completions.hs --- a/src/Development/IDE/Plugin/Completions.hs +++ b/src/Development/IDE/Plugin/Completions.hs @@ -1,7 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} -#include "ghc-api-version.h" module Development.IDE.Plugin.Completions ( descriptor @@ -10,8 +9,8 @@ ) where import Control.Concurrent.Async (concurrently) -import Control.Monad import Control.Monad.Extra +import Control.Monad.IO.Class import Control.Monad.Trans.Maybe import Data.Aeson import Data.List (find) @@ -31,8 +30,8 @@ import Development.IDE.Plugin.Completions.Types import Development.IDE.Types.HscEnvEq (hscEnv) import Development.IDE.Types.Location -import Development.Shake -import Development.Shake.Classes +import Development.IDE.Graph +import Development.IDE.Graph.Classes import GHC.Exts (toList) import GHC.Generics import Ide.Plugin.Config (Config) @@ -47,7 +46,7 @@ { pluginRules = produceCompletions , pluginHandlers = mkPluginHandler STextDocumentCompletion getCompletionsLSP , pluginCommands = [extendImportCommand] - , pluginCustomConfig = mkCustomConfig properties + , pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties} } produceCompletions :: Rules () 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 @@ -2,7 +2,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiWayIf #-} -#include "ghc-api-version.h" -- Mostly taken from "haskell-ide-engine" module Development.IDE.Plugin.Completions.Logic ( @@ -29,7 +28,7 @@ import Name import RdrName import Type -#if MIN_GHC_API_VERSION(8,10,0) +#if MIN_VERSION_ghc(8,10,0) import Coercion import Pair import Predicate (isDictTy) @@ -269,7 +268,7 @@ then getArgs ret else Prelude.filter (not . isDictTy) args | isPiTy t = getArgs $ snd (splitPiTys t) -#if MIN_GHC_API_VERSION(8,10,0) +#if MIN_VERSION_ghc(8,10,0) | Just (Pair _ t) <- coercionKind <$> isCoercionTy_maybe t = getArgs t #else @@ -415,7 +414,7 @@ TyClD _ ClassDecl{tcdLName, tcdSigs} -> mkComp tcdLName CiInterface Nothing : [ mkComp id CiFunction (Just $ ppr typ) - | L _ (TypeSig _ ids typ) <- tcdSigs + | L _ (ClassOpSig _ _ ids typ) <- tcdSigs , id <- ids] TyClD _ x -> let generalCompls = [mkComp id cl Nothing 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 @@ -27,7 +27,7 @@ import Development.IDE.LSP.Server import Development.IDE.Plugin import Development.IDE.Types.Logger -import Development.Shake (Rules) +import Development.IDE.Graph (Rules) import Ide.Plugin.Config import Ide.PluginUtils (getClientConfig) import Ide.Types as HLS 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 @@ -33,7 +33,8 @@ descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler STextDocumentHover hover' - <> mkPluginHandler STextDocumentDocumentSymbol symbolsProvider + <> mkPluginHandler STextDocumentDocumentSymbol symbolsProvider, + pluginConfigDescriptor = defaultConfigDescriptor {configEnableGenericConfig = False} } -- --------------------------------------------------------------------- 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 @@ -30,7 +30,7 @@ import Development.IDE.Types.Action import Development.IDE.Types.HscEnvEq (HscEnvEq (hscEnv)) import Development.IDE.Types.Location (fromUri) -import Development.Shake (Action) +import Development.IDE.Graph (Action) import GHC.Generics (Generic) import GhcPlugins (HscEnv (hsc_dflags)) import Ide.Types 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 @@ -17,8 +17,8 @@ import Control.Monad (mzero) import Control.Monad.Extra (whenMaybe) import Control.Monad.IO.Class (MonadIO (liftIO)) -import qualified Data.Aeson.Types as A import Data.Aeson.Types (Value (..), toJSON) +import qualified Data.Aeson.Types as A import qualified Data.HashMap.Strict as Map import Data.List (find) import Data.Maybe (catMaybes, fromJust) @@ -41,7 +41,7 @@ Range (Range, _end, _start), toNormalizedFilePath', uriToFilePath') -import Development.Shake.Classes +import Development.IDE.Graph.Classes import GHC.Generics (Generic) import GhcPlugins (GlobalRdrEnv, HscEnv (hsc_dflags), SDoc, @@ -60,6 +60,8 @@ PluginCommand (PluginCommand), PluginDescriptor (..), PluginId, + configCustomConfig, + defaultConfigDescriptor, defaultPluginDescriptor, mkCustomConfig, mkPluginHandler) @@ -90,7 +92,7 @@ { pluginHandlers = mkPluginHandler STextDocumentCodeLens codeLensProvider , pluginCommands = [PluginCommand (CommandId typeLensCommandId) "adds a signature" commandHandler] , pluginRules = rules - , pluginCustomConfig = mkCustomConfig properties + , pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties} } properties :: Properties '[ 'PropertyKey "mode" ('TEnum Mode)] @@ -212,8 +214,8 @@ deriving (Eq, Ord, Show, Read, Enum) instance A.ToJSON Mode where - toJSON Always = "always" - toJSON Exported = "exported" + toJSON Always = "always" + toJSON Exported = "exported" toJSON Diagnostics = "diagnostics" instance A.FromJSON Mode where 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 @@ -3,7 +3,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} -#include "ghc-api-version.h" -- | Gives information about symbols at a given point in DAML files. -- These are all pure functions that should execute quickly. @@ -255,7 +254,7 @@ where ni = nodeInfo x getTypes ts = flip concatMap (unfold ts) $ \case HTyVarTy n -> [n] -#if MIN_GHC_API_VERSION(8,8,0) +#if MIN_VERSION_ghc(8,8,0) HAppTy a (HieArgs xs) -> getTypes (a : map snd xs) #else HAppTy a b -> getTypes [a,b] diff --git a/src/Development/IDE/Spans/Common.hs b/src/Development/IDE/Spans/Common.hs --- a/src/Development/IDE/Spans/Common.hs +++ b/src/Development/IDE/Spans/Common.hs @@ -1,7 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} -#include "ghc-api-version.h" module Development.IDE.Spans.Common ( showGhc 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 @@ -3,7 +3,6 @@ -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE CPP #-} -#include "ghc-api-version.h" module Development.IDE.Spans.Documentation ( getDocumentation diff --git a/src/Development/IDE/Types/Action.hs b/src/Development/IDE/Types/Action.hs --- a/src/Development/IDE/Types/Action.hs +++ b/src/Development/IDE/Types/Action.hs @@ -16,7 +16,7 @@ import Data.Hashable (Hashable (..)) import Data.Unique (Unique) import Development.IDE.Types.Logger -import Development.Shake (Action) +import Development.IDE.Graph (Action) import Numeric.Natural data DelayedAction a = DelayedAction 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 @@ -25,7 +25,7 @@ import Development.IDE.GHC.Error (catchSrcErrors) import Development.IDE.GHC.Util (lookupPackageConfig) import Development.IDE.Types.Exports (ExportsMap, createExportsMap) -import Development.Shake.Classes +import Development.IDE.Graph.Classes import GhcPlugins (HscEnv (hsc_dflags), InstalledPackageInfo (exposedModules), Module (..), @@ -164,4 +164,3 @@ pure (OnceRunning x, unmask $ run x) data Once a = OncePending | OnceRunning (Async a) - 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 @@ -23,7 +23,7 @@ import Data.Typeable import Development.IDE.Core.RuleTypes import Development.IDE.Types.Diagnostics -import Development.Shake +import Development.IDE.Graph import GHC hiding (parseModule, typecheckModule) import GhcPlugins as GHC hiding (fst3, (<>)) @@ -110,6 +110,7 @@ = Percentage -- ^ Report using the LSP @_percentage@ field | Explicit -- ^ Report using explicit 123/456 text | NoProgress -- ^ Do not report any percentage + deriving Eq clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress diff --git a/src/Development/IDE/Types/Shake.hs b/src/Development/IDE/Types/Shake.hs --- a/src/Development/IDE/Types/Shake.hs +++ b/src/Development/IDE/Types/Shake.hs @@ -26,9 +26,9 @@ import Development.IDE.Core.PositionMapping import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location -import Development.Shake (RuleResult, +import Development.IDE.Graph (RuleResult, ShakeException (shakeExceptionInner)) -import Development.Shake.Classes +import Development.IDE.Graph.Classes import GHC.Generics import Language.LSP.Types diff --git a/src/Generics/SYB/GHC.hs b/src/Generics/SYB/GHC.hs new file mode 100644 --- /dev/null +++ b/src/Generics/SYB/GHC.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE RankNTypes #-} + +-- | Custom SYB traversals explicitly designed for operating over the GHC AST. +module Generics.SYB.GHC + ( genericIsSubspan, + mkBindListT, + everywhereM', + smallestM, + largestM + ) where + +import Control.Monad +import Data.Functor.Compose (Compose(Compose)) +import Data.Monoid (Any(Any)) +import Development.IDE.GHC.Compat +import Development.IDE.Graph.Classes +import Generics.SYB + + +-- | A generic query intended to be used for calling 'smallestM' and +-- 'largestM'. If the current node is a 'Located', returns whether or not the +-- given 'SrcSpan' is a subspan. For all other nodes, returns 'Nothing', which +-- indicates uncertainty. The search strategy in 'smallestM' et al. will +-- continue searching uncertain nodes. +genericIsSubspan :: + forall ast. + Typeable ast => + -- | The type of nodes we'd like to consider. + Proxy (Located ast) -> + SrcSpan -> + GenericQ (Maybe Bool) +genericIsSubspan _ dst = mkQ Nothing $ \case + (L span _ :: Located ast) -> Just $ dst `isSubspanOf` span + + +-- | Lift a function that replaces a value with several values into a generic +-- function. The result doesn't perform any searching, so should be driven via +-- 'everywhereM' or friends. +-- +-- The 'Int' argument is the index in the list being bound. +mkBindListT :: forall b m. (Data b, Monad m) => (Int -> b -> m [b]) -> GenericM m +mkBindListT f = mkM $ fmap join . traverse (uncurry f) . zip [0..] + + +-- | Apply a monadic transformation everywhere in a top-down manner. +everywhereM' :: forall m. Monad m => GenericM m -> GenericM m +everywhereM' f = go + where + go :: GenericM m + go = gmapM go <=< f + + +------------------------------------------------------------------------------ +-- Custom SYB machinery +------------------------------------------------------------------------------ + +-- | Generic monadic transformations that return side-channel data. +type GenericMQ r m = forall a. Data a => a -> m (r, a) + +------------------------------------------------------------------------------ +-- | Apply the given 'GenericM' at all every node whose children fail the +-- 'GenericQ', but which passes the query itself. +-- +-- The query must be a monotonic function when it returns 'Just'. That is, if +-- @s@ is a subtree of @t@, @q t@ should return @Just True@ if @q s@ does. It +-- is the True-to-false edge of the query that triggers the transformation. +-- +-- Why is the query a @Maybe Bool@? The GHC AST intersperses 'Located' nodes +-- with data nodes, so for any given node we can only definitely return an +-- answer if it's a 'Located'. See 'genericIsSubspan' for how this parameter is +-- used. +smallestM :: forall m. Monad m => GenericQ (Maybe Bool) -> GenericM m -> GenericM m +smallestM q f = fmap snd . go + where + go :: GenericMQ Any m + go x = do + case q x of + Nothing -> gmapMQ go x + Just True -> do + it@(r, x') <- gmapMQ go x + case r of + Any True -> pure it + Any False -> fmap (Any True,) $ f x' + Just False -> pure (mempty, x) + +------------------------------------------------------------------------------ +-- | Apply the given 'GenericM' at every node that passes the 'GenericQ', but +-- don't descend into children if the query matches. Because this traversal is +-- root-first, this policy will find the largest subtrees for which the query +-- holds true. +-- +-- Why is the query a @Maybe Bool@? The GHC AST intersperses 'Located' nodes +-- with data nodes, so for any given node we can only definitely return an +-- answer if it's a 'Located'. See 'genericIsSubspan' for how this parameter is +-- used. +largestM :: forall m. Monad m => GenericQ (Maybe Bool) -> GenericM m -> GenericM m +largestM q f = go + where + go :: GenericM m + go x = do + case q x of + Just True -> f x + Just False -> pure x + Nothing -> gmapM go x + +newtype MonadicQuery r m a = MonadicQuery + { runMonadicQuery :: m (r, a) + } + deriving stock (Functor) + deriving Applicative via Compose m ((,) r) + + +------------------------------------------------------------------------------ +-- | Like 'gmapM', but also returns side-channel data. +gmapMQ :: + forall f r a. (Monoid r, Data a, Applicative f) => + (forall d. Data d => d -> f (r, d)) -> + a -> + f (r, a) +gmapMQ f = runMonadicQuery . gfoldl k pure + where + k :: Data d => MonadicQuery r f (d -> b) -> d -> MonadicQuery r f b + k c x = c <*> MonadicQuery (f x) diff --git a/test/data/cabal-exe/dist-newstyle/build/x86_64-osx/ghc-8.10.3/a-0.1.0.0/x/a/build/a/autogen/Paths_a.hs b/test/data/cabal-exe/dist-newstyle/build/x86_64-osx/ghc-8.10.3/a-0.1.0.0/x/a/build/a/autogen/Paths_a.hs new file mode 100644 --- /dev/null +++ b/test/data/cabal-exe/dist-newstyle/build/x86_64-osx/ghc-8.10.3/a-0.1.0.0/x/a/build/a/autogen/Paths_a.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoRebindableSyntax #-} +{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} +module Paths_a ( + version, + getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, + getDataFileName, getSysconfDir + ) where + +import qualified Control.Exception as Exception +import Data.Version (Version(..)) +import System.Environment (getEnv) +import Prelude + +#if defined(VERSION_base) + +#if MIN_VERSION_base(4,0,0) +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#else +catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a +#endif + +#else +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#endif +catchIO = Exception.catch + +version :: Version +version = Version [0,1,0,0] [] +bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath + +bindir = "/Users/pepeiborra/.cabal/bin" +libdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.3/a-0.1.0.0-inplace-a" +dynlibdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.3" +datadir = "/Users/pepeiborra/.cabal/share/x86_64-osx-ghc-8.10.3/a-0.1.0.0" +libexecdir = "/Users/pepeiborra/.cabal/libexec/x86_64-osx-ghc-8.10.3/a-0.1.0.0" +sysconfdir = "/Users/pepeiborra/.cabal/etc" + +getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath +getBinDir = catchIO (getEnv "a_bindir") (\_ -> return bindir) +getLibDir = catchIO (getEnv "a_libdir") (\_ -> return libdir) +getDynLibDir = catchIO (getEnv "a_dynlibdir") (\_ -> return dynlibdir) +getDataDir = catchIO (getEnv "a_datadir") (\_ -> return datadir) +getLibexecDir = catchIO (getEnv "a_libexecdir") (\_ -> return libexecdir) +getSysconfDir = catchIO (getEnv "a_sysconfdir") (\_ -> return sysconfdir) + +getDataFileName :: FilePath -> IO FilePath +getDataFileName name = do + dir <- getDataDir + return (dir ++ "/" ++ name) diff --git a/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.2/a-1.0.0/build/autogen/Paths_a.hs b/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.2/a-1.0.0/build/autogen/Paths_a.hs new file mode 100644 --- /dev/null +++ b/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.2/a-1.0.0/build/autogen/Paths_a.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoRebindableSyntax #-} +{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} +module Paths_a ( + version, + getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, + getDataFileName, getSysconfDir + ) where + +import qualified Control.Exception as Exception +import Data.Version (Version(..)) +import System.Environment (getEnv) +import Prelude + +#if defined(VERSION_base) + +#if MIN_VERSION_base(4,0,0) +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#else +catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a +#endif + +#else +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#endif +catchIO = Exception.catch + +version :: Version +version = Version [1,0,0] [] +bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath + +bindir = "/Users/pepeiborra/.cabal/bin" +libdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.2/a-1.0.0-inplace" +dynlibdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.2" +datadir = "/Users/pepeiborra/.cabal/share/x86_64-osx-ghc-8.10.2/a-1.0.0" +libexecdir = "/Users/pepeiborra/.cabal/libexec/x86_64-osx-ghc-8.10.2/a-1.0.0" +sysconfdir = "/Users/pepeiborra/.cabal/etc" + +getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath +getBinDir = catchIO (getEnv "a_bindir") (\_ -> return bindir) +getLibDir = catchIO (getEnv "a_libdir") (\_ -> return libdir) +getDynLibDir = catchIO (getEnv "a_dynlibdir") (\_ -> return dynlibdir) +getDataDir = catchIO (getEnv "a_datadir") (\_ -> return datadir) +getLibexecDir = catchIO (getEnv "a_libexecdir") (\_ -> return libexecdir) +getSysconfDir = catchIO (getEnv "a_sysconfdir") (\_ -> return sysconfdir) + +getDataFileName :: FilePath -> IO FilePath +getDataFileName name = do + dir <- getDataDir + return (dir ++ "/" ++ name) diff --git a/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/a-1.0.0/build/autogen/Paths_a.hs b/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/a-1.0.0/build/autogen/Paths_a.hs new file mode 100644 --- /dev/null +++ b/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/a-1.0.0/build/autogen/Paths_a.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoRebindableSyntax #-} +{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} +module Paths_a ( + version, + getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, + getDataFileName, getSysconfDir + ) where + +import qualified Control.Exception as Exception +import Data.Version (Version(..)) +import System.Environment (getEnv) +import Prelude + +#if defined(VERSION_base) + +#if MIN_VERSION_base(4,0,0) +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#else +catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a +#endif + +#else +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#endif +catchIO = Exception.catch + +version :: Version +version = Version [1,0,0] [] +bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath + +bindir = "/Users/pepeiborra/.cabal/bin" +libdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.3/a-1.0.0-inplace" +dynlibdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.3" +datadir = "/Users/pepeiborra/.cabal/share/x86_64-osx-ghc-8.10.3/a-1.0.0" +libexecdir = "/Users/pepeiborra/.cabal/libexec/x86_64-osx-ghc-8.10.3/a-1.0.0" +sysconfdir = "/Users/pepeiborra/.cabal/etc" + +getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath +getBinDir = catchIO (getEnv "a_bindir") (\_ -> return bindir) +getLibDir = catchIO (getEnv "a_libdir") (\_ -> return libdir) +getDynLibDir = catchIO (getEnv "a_dynlibdir") (\_ -> return dynlibdir) +getDataDir = catchIO (getEnv "a_datadir") (\_ -> return datadir) +getLibexecDir = catchIO (getEnv "a_libexecdir") (\_ -> return libexecdir) +getSysconfDir = catchIO (getEnv "a_sysconfdir") (\_ -> return sysconfdir) + +getDataFileName :: FilePath -> IO FilePath +getDataFileName name = do + dir <- getDataDir + return (dir ++ "/" ++ name) diff --git a/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/b-1.0.0/build/autogen/Paths_b.hs b/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/b-1.0.0/build/autogen/Paths_b.hs new file mode 100644 --- /dev/null +++ b/test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/b-1.0.0/build/autogen/Paths_b.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoRebindableSyntax #-} +{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} +module Paths_b ( + version, + getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, + getDataFileName, getSysconfDir + ) where + +import qualified Control.Exception as Exception +import Data.Version (Version(..)) +import System.Environment (getEnv) +import Prelude + +#if defined(VERSION_base) + +#if MIN_VERSION_base(4,0,0) +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#else +catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a +#endif + +#else +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#endif +catchIO = Exception.catch + +version :: Version +version = Version [1,0,0] [] +bindir, libdir, dynlibdir, datadir, libexecdir, sysconfdir :: FilePath + +bindir = "/Users/pepeiborra/.cabal/bin" +libdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.3/b-1.0.0-inplace" +dynlibdir = "/Users/pepeiborra/.cabal/lib/x86_64-osx-ghc-8.10.3" +datadir = "/Users/pepeiborra/.cabal/share/x86_64-osx-ghc-8.10.3/b-1.0.0" +libexecdir = "/Users/pepeiborra/.cabal/libexec/x86_64-osx-ghc-8.10.3/b-1.0.0" +sysconfdir = "/Users/pepeiborra/.cabal/etc" + +getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath +getBinDir = catchIO (getEnv "b_bindir") (\_ -> return bindir) +getLibDir = catchIO (getEnv "b_libdir") (\_ -> return libdir) +getDynLibDir = catchIO (getEnv "b_dynlibdir") (\_ -> return dynlibdir) +getDataDir = catchIO (getEnv "b_datadir") (\_ -> return datadir) +getLibexecDir = catchIO (getEnv "b_libexecdir") (\_ -> return libexecdir) +getSysconfDir = catchIO (getEnv "b_sysconfdir") (\_ -> return sysconfdir) + +getDataFileName :: FilePath -> IO FilePath +getDataFileName name = do + dir <- getDataDir + return (dir ++ "/" ++ name) diff --git a/test/exe/Main.hs b/test/exe/Main.hs --- a/test/exe/Main.hs +++ b/test/exe/Main.hs @@ -11,7 +11,6 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wno-deprecations -Wno-unticked-promoted-constructors #-} -#include "ghc-api-version.h" module Main (main) where @@ -102,6 +101,10 @@ import Data.IORef.Extra (atomicModifyIORef_) import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide import Text.Regex.TDFA ((=~)) +import qualified Progress +import Development.IDE.Core.FileStore (getModTime) +import Control.Concurrent (threadDelay) +import Text.Printf (printf) waitForProgressBegin :: Session () waitForProgressBegin = skipManyTill anyMessage $ satisfyMaybe $ \case @@ -1408,6 +1411,25 @@ , "import A (pattern Some)" , "k (Some x) = x" ]) + , testSession "type constructor name same as data constructor name" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "newtype Foo = Foo Int" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA(Foo)" + , "f :: Foo" + , "f = Foo 1" + ]) + (Range (Position 3 4) (Position 3 6)) + ["Add Foo(Foo) to the import list of ModuleA"] + (T.unlines + [ "module ModuleB where" + , "import ModuleA(Foo (Foo))" + , "f :: Foo" + , "f = Foo 1" + ]) ] where codeActionTitle CodeAction{_title=x} = x @@ -2386,6 +2408,48 @@ executeCodeAction chosen modifiedCode <- documentContents doc liftIO $ mkDoc "E.toException" @=? modifiedCode + , testSession "filling infix type hole uses prefix notation" $ do + let mkDoc x = T.unlines + [ "module Testing where" + , "data A = A" + , "foo :: A -> A -> A" + , "foo A A = A" + , "test :: A -> A -> A" + , "test a1 a2 = a1 " <> x <> " a2" + ] + doc <- createDoc "Test.hs" "haskell" $ mkDoc "`_`" + _ <- waitForDiagnostics + actions <- getCodeActions doc (Range (Position 5 16) (Position 5 19)) + chosen <- liftIO $ pickActionWithTitle "replace _ with foo" actions + executeCodeAction chosen + modifiedCode <- documentContents doc + liftIO $ mkDoc "`foo`" @=? modifiedCode + , testSession "postfix hole uses postfix notation of infix operator" $ do + let mkDoc x = T.unlines + [ "module Testing where" + , "test :: Int -> Int -> Int" + , "test a1 a2 = " <> x <> " a1 a2" + ] + doc <- createDoc "Test.hs" "haskell" $ mkDoc "_" + _ <- waitForDiagnostics + actions <- getCodeActions doc (Range (Position 2 13) (Position 2 14)) + chosen <- liftIO $ pickActionWithTitle "replace _ with (+)" actions + executeCodeAction chosen + modifiedCode <- documentContents doc + liftIO $ mkDoc "(+)" @=? modifiedCode + , testSession "filling infix type hole uses infix operator" $ do + let mkDoc x = T.unlines + [ "module Testing where" + , "test :: Int -> Int -> Int" + , "test a1 a2 = a1 " <> x <> " a2" + ] + doc <- createDoc "Test.hs" "haskell" $ mkDoc "`_`" + _ <- waitForDiagnostics + actions <- getCodeActions doc (Range (Position 2 16) (Position 2 19)) + chosen <- liftIO $ pickActionWithTitle "replace _ with (+)" actions + executeCodeAction chosen + modifiedCode <- documentContents doc + liftIO $ mkDoc "+" @=? modifiedCode ] addInstanceConstraintTests :: TestTree @@ -2624,6 +2688,7 @@ "fCaller :: " <> mkContext contextCaller <> "()", "fCaller = fBase" ] + removeRedundantConstraintsTests :: TestTree removeRedundantConstraintsTests = let header = @@ -2632,6 +2697,13 @@ , "" ] + headerExt :: [T.Text] -> [T.Text] + headerExt exts = + redunt : extTxt ++ ["module Testing where"] + where + redunt = "{-# OPTIONS_GHC -Wredundant-constraints #-}" + extTxt = map (\ext -> "{-# LANGUAGE " <> ext <> " #-}") exts + redundantConstraintsCode :: Maybe T.Text -> T.Text redundantConstraintsCode mConstraint = let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint @@ -2648,19 +2720,107 @@ , "foo x = x == 1" ] - typeSignatureSpaces :: T.Text - typeSignatureSpaces = T.unlines $ header <> - [ "foo :: (Num a, Eq a, Monoid a) => a -> Bool" - , "foo x = x == 1" + typeSignatureSpaces :: Maybe T.Text -> T.Text + typeSignatureSpaces mConstraint = + let constraint = maybe "(Num a, Eq a)" (\c -> "(Num a, Eq a, " <> c <> ")") mConstraint + in T.unlines $ header <> + [ "foo :: " <> constraint <> " => a -> Bool" + , "foo x = x == 1" + ] + + redundantConstraintsForall :: Maybe T.Text -> T.Text + redundantConstraintsForall mConstraint = + let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint + in T.unlines $ headerExt ["RankNTypes"] <> + [ "foo :: forall a. " <> constraint <> "a -> a" + , "foo = id" + ] + + typeSignatureDo :: Maybe T.Text -> T.Text + typeSignatureDo mConstraint = + let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint + in T.unlines $ header <> + [ "f :: Int -> IO ()" + , "f n = do" + , " let foo :: " <> constraint <> "a -> IO ()" + , " foo _ = return ()" + , " r n" + ] + + typeSignatureNested :: Maybe T.Text -> T.Text + typeSignatureNested mConstraint = + let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint + in T.unlines $ header <> + [ "f :: Int -> ()" + , "f = g" + , " where" + , " g :: " <> constraint <> "a -> ()" + , " g _ = ()" + ] + + typeSignatureNested' :: Maybe T.Text -> T.Text + typeSignatureNested' mConstraint = + let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint + in T.unlines $ header <> + [ "f :: Int -> ()" + , "f =" + , " let" + , " g :: Int -> ()" + , " g = h" + , " where" + , " h :: " <> constraint <> "a -> ()" + , " h _ = ()" + , " in g" + ] + + typeSignatureNested'' :: Maybe T.Text -> T.Text + typeSignatureNested'' mConstraint = + let constraint = maybe "" (\c -> "" <> c <> " => ") mConstraint + in T.unlines $ header <> + [ "f :: Int -> ()" + , "f = g" + , " where" + , " g :: Int -> ()" + , " g = " + , " let" + , " h :: " <> constraint <> "a -> ()" + , " h _ = ()" + , " in h" + ] + + typeSignatureLined1 = T.unlines $ header <> + [ "foo :: Eq a =>" + , " a -> Bool" + , "foo _ = True" ] - typeSignatureMultipleLines :: T.Text - typeSignatureMultipleLines = T.unlines $ header <> - [ "foo :: (Num a, Eq a, Monoid a)" - , "=> a -> Bool" - , "foo x = x == 1" + typeSignatureLined2 = T.unlines $ header <> + [ "foo :: (Eq a, Show a)" + , " => a -> Bool" + , "foo _ = True" ] + typeSignatureOneLine = T.unlines $ header <> + [ "foo :: a -> Bool" + , "foo _ = True" + ] + + typeSignatureLined3 = T.unlines $ header <> + [ "foo :: ( Eq a" + , " , Show a" + , " )" + , " => a -> Bool" + , "foo x = x == x" + ] + + typeSignatureLined3' = T.unlines $ header <> + [ "foo :: ( Eq a" + , " )" + , " => a -> Bool" + , "foo x = x == x" + ] + + check :: T.Text -> T.Text -> T.Text -> TestTree check actionTitle originalCode expectedCode = testSession (T.unpack actionTitle) $ do doc <- createDoc "Testing.hs" "haskell" originalCode @@ -2671,13 +2831,6 @@ modifiedCode <- documentContents doc liftIO $ expectedCode @=? modifiedCode - checkPeculiarFormatting :: String -> T.Text -> TestTree - checkPeculiarFormatting title code = testSession title $ do - doc <- createDoc "Testing.hs" "haskell" code - _ <- waitForDiagnostics - actionsOrCommands <- getAllCodeActions doc - liftIO $ assertBool "Found some actions" (null actionsOrCommands) - in testGroup "remove redundant function constraints" [ check "Remove redundant constraint `Eq a` from the context of the type signature for `foo`" @@ -2691,12 +2844,42 @@ "Remove redundant constraints `(Monoid a, Show a)` from the context of the type signature for `foo`" (redundantMixedConstraintsCode $ Just "Monoid a, Show a") (redundantMixedConstraintsCode Nothing) - , checkPeculiarFormatting - "should do nothing when constraints contain an arbitrary number of spaces" - typeSignatureSpaces - , checkPeculiarFormatting - "should do nothing when constraints contain line feeds" - typeSignatureMultipleLines + , check + "Remove redundant constraint `Eq a` from the context of the type signature for `g`" + (typeSignatureNested $ Just "Eq a") + (typeSignatureNested Nothing) + , check + "Remove redundant constraint `Eq a` from the context of the type signature for `h`" + (typeSignatureNested' $ Just "Eq a") + (typeSignatureNested' Nothing) + , check + "Remove redundant constraint `Eq a` from the context of the type signature for `h`" + (typeSignatureNested'' $ Just "Eq a") + (typeSignatureNested'' Nothing) + , check + "Remove redundant constraint `Eq a` from the context of the type signature for `foo`" + (redundantConstraintsForall $ Just "Eq a") + (redundantConstraintsForall Nothing) + , check + "Remove redundant constraint `Eq a` from the context of the type signature for `foo`" + (typeSignatureDo $ Just "Eq a") + (typeSignatureDo Nothing) + , check + "Remove redundant constraints `(Monoid a, Show a)` from the context of the type signature for `foo`" + (typeSignatureSpaces $ Just "Monoid a, Show a") + (typeSignatureSpaces Nothing) + , check + "Remove redundant constraint `Eq a` from the context of the type signature for `foo`" + typeSignatureLined1 + typeSignatureOneLine + , check + "Remove redundant constraints `(Eq a, Show a)` from the context of the type signature for `foo`" + typeSignatureLined2 + typeSignatureOneLine + , check + "Remove redundant constraint `Show a` from the context of the type signature for `foo`" + typeSignatureLined3 + typeSignatureLined3' ] addSigActionTests :: TestTree @@ -3417,7 +3600,7 @@ , test yes yes lclL33 lcb "listcomp lookup" , test yes yes mclL36 mcl "top-level fn 1st clause" , test yes yes mclL37 mcl "top-level fn 2nd clause #1030" -#if MIN_GHC_API_VERSION(8,10,0) +#if MIN_VERSION_ghc(8,10,0) , test yes yes spaceL37 space "top-level fn on space #1002" #else , test yes broken spaceL37 space "top-level fn on space #1002" @@ -3891,7 +4074,20 @@ ,("abcdefg", CiFunction, "abcdefg", True, False, Nothing) ,("abcdefgh", CiFunction, "abcdefgh", True, False, Nothing) ,("abcdefghi", CiFunction, "abcdefghi", True, False, Nothing) + ], + completionTest + "class method" + [ + "class Test a where" + , " abcd :: a -> ()" + , " abcde :: a -> Int" + , "instance Test Int where" + , " abcd = abc" ] + (Position 4 14) + [("abcd", CiFunction, "abcd", True, False, Nothing) + ,("abcde", CiFunction, "abcde", True, False, Nothing) + ] ] nonLocalCompletionTests :: [TestTree] @@ -4148,7 +4344,7 @@ highlights <- getHighlights doc (Position 4 15) liftIO $ highlights @?= List -- Span is just the .. on 8.10, but Rec{..} before -#if MIN_GHC_API_VERSION(8,10,0) +#if MIN_VERSION_ghc(8,10,0) [ DocumentHighlight (R 4 8 4 10) (Just HkWrite) #else [ DocumentHighlight (R 4 4 4 11) (Just HkWrite) @@ -4159,7 +4355,7 @@ liftIO $ highlights @?= List [ DocumentHighlight (R 3 17 3 23) (Just HkWrite) -- Span is just the .. on 8.10, but Rec{..} before -#if MIN_GHC_API_VERSION(8,10,0) +#if MIN_VERSION_ghc(8,10,0) , DocumentHighlight (R 4 8 4 10) (Just HkRead) #else , DocumentHighlight (R 4 4 4 11) (Just HkRead) @@ -4372,7 +4568,7 @@ ignoreInWindowsBecause = if isWindows then ignoreTestBecause else (\_ x -> x) ignoreInWindowsForGHC88And810 :: TestTree -> TestTree -#if MIN_GHC_API_VERSION(8,8,1) && !MIN_GHC_API_VERSION(9,0,0) +#if MIN_VERSION_ghc(8,8,1) && !MIN_VERSION_ghc(9,0,0) ignoreInWindowsForGHC88And810 = ignoreInWindowsBecause "tests are unreliable in windows for ghc 8.8 and 8.10" #else @@ -4380,7 +4576,7 @@ #endif ignoreInWindowsForGHC88 :: TestTree -> TestTree -#if MIN_GHC_API_VERSION(8,8,1) && !MIN_GHC_API_VERSION(8,10,1) +#if MIN_VERSION_ghc(8,8,1) && !MIN_VERSION_ghc(8,10,1) ignoreInWindowsForGHC88 = ignoreInWindowsBecause "tests are unreliable in windows for ghc 8.8" #else @@ -4923,18 +5119,17 @@ clientSettingsTest = testGroup "client settings handling" [ testSession "ghcide restarts shake session on config changes" $ do void $ skipManyTill anyMessage $ message SClientRegisterCapability + void $ createDoc "A.hs" "haskell" "module A where" + waitForProgressDone sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON ("" :: String))) - nots <- skipManyTill anyMessage $ count 3 loggingNotification - isMessagePresent "Restarting build session" (map getLogMessage nots) + skipManyTill anyMessage restartingBuildSession ] - where getLogMessage :: FromServerMessage -> T.Text - getLogMessage (FromServerMess SWindowLogMessage (NotificationMessage _ _ (LogMessageParams _ msg))) = msg - getLogMessage _ = "" - - isMessagePresent expectedMsg actualMsgs = liftIO $ - assertBool ("\"" ++ expectedMsg ++ "\" is not present in: " ++ show actualMsgs) - (any ((expectedMsg `isSubsequenceOf`) . show) actualMsgs) + where + restartingBuildSession :: Session () + restartingBuildSession = do + FromServerMess SWindowLogMessage NotificationMessage{_params = LogMessageParams{..}} <- loggingNotification + guard $ "Restarting build session" `T.isInfixOf` _message referenceTests :: TestTree referenceTests = testGroup "references" @@ -5300,7 +5495,23 @@ actualOrder <- liftIO $ readIORef orderRef liftIO $ actualOrder @?= reverse [(1::Int)..20] + , testCase "timestamps have millisecond resolution" $ do + resolution_us <- findResolution_us 1 + let msg = printf "Timestamps do not have millisecond resolution: %dus" resolution_us + assertBool msg (resolution_us <= 1000) + , Progress.tests ] + +findResolution_us :: Int -> IO Int +findResolution_us delay_us | delay_us >= 1000000 = error "Unable to compute timestamp resolution" +findResolution_us delay_us = withTempFile $ \f -> withTempFile $ \f' -> do + writeFile f "" + threadDelay delay_us + writeFile f' "" + t <- getModTime f + t' <- getModTime f' + if t /= t' then return delay_us else findResolution_us (delay_us * 10) + testIde :: IDE.Arguments -> Session () -> IO () testIde arguments session = do diff --git a/test/exe/Progress.hs b/test/exe/Progress.hs new file mode 100644 --- /dev/null +++ b/test/exe/Progress.hs @@ -0,0 +1,28 @@ +module Progress (tests) where + +import Development.IDE.Core.ProgressReporting +import Test.Tasty +import Test.Tasty.HUnit +import qualified Data.HashMap.Strict as Map + +tests :: TestTree +tests = testGroup "Progress" + [ reportProgressTests + ] + +reportProgressTests :: TestTree +reportProgressTests = testGroup "recordProgress" + [ test "addNew" addNew + , test "increase" increase + , test "decrease" decrease + , test "done" done + ] + where + p0 = InProgress 0 0 mempty + addNew = recordProgress "A" succ p0 + increase = recordProgress "A" succ addNew + decrease = recordProgress "A" succ increase + done = recordProgress "A" pred decrease + model InProgress{..} = + (done, todo) @?= (length (filter (==0) (Map.elems current)), Map.size current) + test name p = testCase name $ model p