ghcide 1.2.0.2 → 1.3.0.0

raw patch · 51 files changed

+1205/−609 lines, 51 filesdep +hls-graphdep ~hls-plugin-apidep ~shakedep ~unordered-containersPVP ok

version bump matches the API change (PVP)

Dependencies added: hls-graph

Dependency ranges changed: hls-plugin-api, shake, unordered-containers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +12/−0
• cbits/getmodtime.c +0/−21
• exe/Main.hs +1/−2
• ghcide.cabal +13/−16
• include/ghc-api-version.h +0/−12
• session-loader/Development/IDE/Session.hs +45/−13
• src/Development/IDE.hs +1/−1
• src/Development/IDE/Core/Actions.hs +1/−1
• src/Development/IDE/Core/Compile.hs +10/−11
• src/Development/IDE/Core/FileExists.hs +2/−1
• src/Development/IDE/Core/FileStore.hs +14/−41
• src/Development/IDE/Core/IdeConfiguration.hs +2/−1
• src/Development/IDE/Core/OfInterest.hs +8/−21
• src/Development/IDE/Core/ProgressReporting.hs +186/−0
• src/Development/IDE/Core/RuleTypes.hs +12/−5
• src/Development/IDE/Core/Rules.hs +6/−15
• src/Development/IDE/Core/Service.hs +1/−1
• src/Development/IDE/Core/Shake.hs +67/−169
• src/Development/IDE/Core/Tracing.hs +2/−4
• src/Development/IDE/Core/UseStale.hs +1/−1
• src/Development/IDE/GHC/CPP.hs +7/−8
• src/Development/IDE/GHC/Compat.hs +20/−21
• src/Development/IDE/GHC/ExactPrint.hs +55/−122
• src/Development/IDE/GHC/Orphans.hs +1/−2
• src/Development/IDE/Import/FindImports.hs +0/−1
• src/Development/IDE/LSP/Notifications.hs +4/−0
• src/Development/IDE/LSP/Outline.hs +1/−2
• src/Development/IDE/Main.hs +4/−2
• src/Development/IDE/Plugin.hs +1/−1
• src/Development/IDE/Plugin/CodeAction.hs +86/−50
• src/Development/IDE/Plugin/CodeAction/ExactPrint.hs +17/−0
• src/Development/IDE/Plugin/Completions.hs +4/−5
• src/Development/IDE/Plugin/Completions/Logic.hs +3/−4
• src/Development/IDE/Plugin/HLS.hs +1/−1
• src/Development/IDE/Plugin/HLS/GhcIde.hs +2/−1
• src/Development/IDE/Plugin/Test.hs +1/−1
• src/Development/IDE/Plugin/TypeLenses.hs +7/−5
• src/Development/IDE/Spans/AtPoint.hs +1/−2
• src/Development/IDE/Spans/Common.hs +0/−1
• src/Development/IDE/Spans/Documentation.hs +0/−1
• src/Development/IDE/Types/Action.hs +1/−1
• src/Development/IDE/Types/HscEnvEq.hs +1/−2
• src/Development/IDE/Types/Options.hs +2/−1
• src/Development/IDE/Types/Shake.hs +2/−2
• src/Generics/SYB/GHC.hs +124/−0
• 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 +50/−0
• test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.2/a-1.0.0/build/autogen/Paths_a.hs +50/−0
• test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/a-1.0.0/build/autogen/Paths_a.hs +50/−0
• test/data/multi/dist-newstyle/build/x86_64-osx/ghc-8.10.3/b-1.0.0/build/autogen/Paths_b.hs +50/−0
• test/exe/Main.hs +248/−37
• test/exe/Progress.hs +28/−0

@@ -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

@@ -1,21 +0,0 @@-// Copyright (c) 2019 The DAML Authors. All rights reserved.-// SPDX-License-Identifier: Apache-2.0--#include <sys/stat.h>-#include <time.h>-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;-}-

@@ -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                 }         }-

@@ -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:

@@ -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

@@ -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

@@ -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)

@@ -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 (..))

@@ -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 ->

@@ -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

@@ -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 ()

@@ -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) 

@@ -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

@@ -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

@@ -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")))

@@ -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") $

@@ -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

@@ -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

@@ -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-

@@ -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

@@ -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)

@@ -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

@@ -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) 

@@ -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

@@ -2,7 +2,6 @@ -- SPDX-License-Identifier: Apache-2.0  {-# LANGUAGE CPP #-}-#include "ghc-api-version.h"  module Development.IDE.Import.FindImports   ( locateModule

@@ -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

@@ -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

@@ -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 

@@ -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

@@ -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 =

@@ -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.

@@ -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 ()

@@ -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

@@ -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

@@ -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}   }  -- ---------------------------------------------------------------------

@@ -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

@@ -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

@@ -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]

@@ -1,7 +1,6 @@ {-# LANGUAGE CPP                #-} {-# LANGUAGE DeriveAnyClass     #-} {-# LANGUAGE DerivingStrategies #-}-#include "ghc-api-version.h"  module Development.IDE.Spans.Common (   showGhc

@@ -3,7 +3,6 @@ -- SPDX-License-Identifier: Apache-2.0  {-# LANGUAGE CPP        #-}-#include "ghc-api-version.h"  module Development.IDE.Spans.Documentation (     getDocumentation

@@ -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

@@ -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)-

@@ -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

@@ -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 

@@ -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)

@@ -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)

@@ -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)

@@ -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)

@@ -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)

@@ -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

@@ -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