ghcide 2.0.0.1 → 2.1.0.0

raw patch · 88 files changed

+5761/−4833 lines, 88 filesdep +row-typesdep ~hls-graphdep ~hls-plugin-apidep ~lspPVP ok

version bump matches the API change (PVP)

Dependencies added: row-types

Dependency ranges changed: hls-graph, hls-plugin-api, lsp, lsp-test, lsp-types

API changes (from Hackage documentation)

Files

• exe/Main.hs +6/−6
• ghcide.cabal +43/−7
• session-loader/Development/IDE/Session.hs +32/−12
• src/Development/IDE.hs +2/−4
• src/Development/IDE/Core/Actions.hs +48/−30
• src/Development/IDE/Core/Compile.hs +116/−83
• src/Development/IDE/Core/FileExists.hs +8/−8
• src/Development/IDE/Core/FileStore.hs +21/−20
• src/Development/IDE/Core/IdeConfiguration.hs +5/−4
• src/Development/IDE/Core/OfInterest.hs +10/−7
• src/Development/IDE/Core/PluginUtils.hs +140/−0
• src/Development/IDE/Core/PositionMapping.hs +13/−8
• src/Development/IDE/Core/Preprocessor.hs +4/−2
• src/Development/IDE/Core/ProgressReporting.hs +22/−16
• src/Development/IDE/Core/RuleTypes.hs +3/−13
• src/Development/IDE/Core/Rules.hs +114/−63
• src/Development/IDE/Core/Service.hs +3/−3
• src/Development/IDE/Core/Shake.hs +44/−26
• src/Development/IDE/Core/Tracing.hs +3/−2
• src/Development/IDE/GHC/Compat/Core.hs +1/−0
• src/Development/IDE/GHC/Compat/Units.hs +47/−21
• src/Development/IDE/GHC/Error.hs +8/−6
• src/Development/IDE/GHC/Orphans.hs +4/−0
• src/Development/IDE/GHC/Warnings.hs +1/−1
• src/Development/IDE/Import/DependencyInformation.hs +34/−15
• src/Development/IDE/Import/FindImports.hs +30/−9
• src/Development/IDE/LSP/HoverDefinition.hs +28/−26
• src/Development/IDE/LSP/LanguageServer.hs +23/−20
• src/Development/IDE/LSP/Notifications.hs +14/−13
• src/Development/IDE/LSP/Outline.hs +38/−37
• src/Development/IDE/LSP/Server.hs +14/−18
• src/Development/IDE/Main.hs +3/−3
• src/Development/IDE/Main/HeapStats.hs +4/−4
• src/Development/IDE/Monitoring/EKG.hs +2/−2
• src/Development/IDE/Plugin/Completions.hs +52/−58
• src/Development/IDE/Plugin/Completions/Logic.hs +55/−46
• src/Development/IDE/Plugin/Completions/Types.hs +8/−8
• src/Development/IDE/Plugin/HLS.hs +145/−85
• src/Development/IDE/Plugin/HLS/GhcIde.hs +10/−16
• src/Development/IDE/Plugin/Test.hs +21/−18
• src/Development/IDE/Plugin/TypeLenses.hs +36/−39
• src/Development/IDE/Spans/AtPoint.hs +65/−20
• src/Development/IDE/Spans/Documentation.hs +1/−1
• src/Development/IDE/Spans/Pragmas.hs +8/−9
• src/Development/IDE/Types/Action.hs +6/−6
• src/Development/IDE/Types/Diagnostics.hs +20/−22
• src/Development/IDE/Types/HscEnvEq.hs +8/−1
• src/Development/IDE/Types/Location.hs +2/−2
• src/Development/IDE/Types/Logger.hs +0/−335
• src/Development/IDE/Types/Options.hs +6/−5
• src/Text/Fuzzy/Parallel.hs +56/−20
• test/exe/AsyncTests.hs +53/−0
• test/exe/BootTests.hs +55/−0
• test/exe/CPPTests.hs +56/−0
• test/exe/ClientSettingsTests.hs +34/−0
• test/exe/CodeLensTests.hs +114/−0
• test/exe/CompletionTests.hs +576/−0
• test/exe/CradleTests.hs +219/−0
• test/exe/DependentFileTest.hs +62/−0
• test/exe/DiagnosticTests.hs +565/−0
• test/exe/ExceptionTests.hs +155/−0
• test/exe/FindDefinitionAndHoverTests.hs +252/−0
• test/exe/FuzzySearch.hs +0/−3
• test/exe/GarbageCollectionTests.hs +94/−0
• test/exe/HaddockTests.hs +90/−0
• test/exe/HieDbRetry.hs +15/−16
• test/exe/HighlightTests.hs +85/−0
• test/exe/IfaceTests.hs +163/−0
• test/exe/InitializeResponseTests.hs +97/−0
• test/exe/LogType.hs +21/−0
• test/exe/Main.hs +99/−3600
• test/exe/NonLspCommandLine.hs +27/−0
• test/exe/OpenCloseTest.hs +18/−0
• test/exe/OutlineTests.hs +189/−0
• test/exe/PluginParsedResultTests.hs +17/−0
• test/exe/PluginSimpleTests.hs +51/−0
• test/exe/PositionMappingTests.hs +199/−0
• test/exe/PreprocessorTests.hs +27/−0
• test/exe/ReferenceTests.hs +199/−0
• test/exe/RootUriTests.hs +26/−0
• test/exe/SafeTests.hs +38/−0
• test/exe/SymlinkTests.hs +27/−0
• test/exe/THTests.hs +194/−0
• test/exe/TestUtils.hs +329/−0
• test/exe/UnitTests.hs +110/−0
• test/exe/WatchedFileTests.hs +83/−0
• test/src/Development/IDE/Test.hs +26/−25
• test/src/Development/IDE/Test/Diagnostic.hs +9/−9

@@ -22,7 +22,9 @@ import qualified Development.IDE.Monitoring.EKG           as EKG import qualified Development.IDE.Monitoring.OpenTelemetry as OpenTelemetry import qualified Development.IDE.Plugin.HLS.GhcIde        as GhcIde-import           Development.IDE.Types.Logger             (Logger (Logger),+import           Development.IDE.Types.Options+import           GHC.Stack                                (emptyCallStack)+import           Ide.Logger                               (Logger (Logger),                                                            LoggingColumn (DataColumn, PriorityColumn),                                                            Pretty (pretty),                                                            Priority (Debug, Error, Info),@@ -33,16 +35,14 @@                                                            layoutPretty,                                                            makeDefaultStderrRecorder,                                                            renderStrict)-import qualified Development.IDE.Types.Logger             as Logger-import           Development.IDE.Types.Options-import           GHC.Stack                                (emptyCallStack)+import qualified Ide.Logger                               as Logger import           Ide.Plugin.Config                        (Config (checkParents, checkProject)) import           Ide.PluginUtils                          (pluginDescToIdePlugins) import           Ide.Types                                (PluginDescriptor (pluginNotificationHandlers),                                                            defaultPluginDescriptor,                                                            mkPluginNotificationHandler)+import           Language.LSP.Protocol.Message            as LSP import           Language.LSP.Server                      as LSP-import           Language.LSP.Types                       as LSP import           Paths_ghcide                             (version) import qualified System.Directory.Extra                   as IO import           System.Environment                       (getExecutablePath)@@ -101,7 +101,7 @@     -- This plugin just installs a handler for the `initialized` notification, which then     -- picks up the LSP environment and feeds it to our recorders     let lspRecorderPlugin = (defaultPluginDescriptor "LSPRecorderCallback")-          { pluginNotificationHandlers = mkPluginNotificationHandler LSP.SInitialized $ \_ _ _ _ -> do+          { pluginNotificationHandlers = mkPluginNotificationHandler LSP.SMethod_Initialized $ \_ _ _ _ -> do               env <- LSP.getLspEnv               liftIO $ (cb1 <> cb2) env           }

@@ -2,7 +2,7 @@ build-type:         Simple category:           Development name:               ghcide-version:            2.0.0.1+version:            2.1.0.0 license:            Apache-2.0 license-file:       LICENSE author:             Digital Asset and Ghcide contributors@@ -65,12 +65,12 @@         haddock-library >= 1.8 && < 1.12,         hashable,         hie-compat ^>= 0.3.0.0,-        hls-plugin-api == 2.0.0.1,+        hls-plugin-api == 2.1.0.0,         lens,         list-t,         hiedb == 0.4.3.*,-        lsp-types ^>= 1.6.0.0,-        lsp ^>= 1.6.0.0 ,+        lsp-types ^>= 2.0.1.0,+        lsp ^>= 2.1.0.0 ,         mtl,         optparse-applicative,         parallel,@@ -78,9 +78,10 @@         prettyprinter >= 1.7,         random,         regex-tdfa >= 1.3.1.0,+        row-types,         text-rope,         safe-exceptions,-        hls-graph == 2.0.0.1,+        hls-graph == 2.1.0.0,         sorted-list,         sqlite-simple,         stm,@@ -153,6 +154,7 @@         Development.IDE.Core.FileUtils         Development.IDE.Core.IdeConfiguration         Development.IDE.Core.OfInterest+        Development.IDE.Core.PluginUtils         Development.IDE.Core.PositionMapping         Development.IDE.Core.Preprocessor         Development.IDE.Core.ProgressReporting@@ -196,7 +198,6 @@         Development.IDE.Types.HscEnvEq         Development.IDE.Types.KnownTargets         Development.IDE.Types.Location-        Development.IDE.Types.Logger         Development.IDE.Types.Monitoring         Development.IDE.Monitoring.OpenTelemetry         Development.IDE.Types.Options@@ -345,7 +346,8 @@         hls-plugin-api,         lens,         list-t,-        lsp-test ^>= 0.14,+        lsp-test ^>= 0.15.0.1,+        mtl,         monoid-subclasses,         network-uri,         QuickCheck,@@ -363,6 +365,7 @@         text,         text-rope,         unordered-containers,+        row-types     if impl(ghc < 9.2)       build-depends:           record-dot-preprocessor,@@ -381,6 +384,39 @@         HieDbRetry         Development.IDE.Test         Development.IDE.Test.Diagnostic+        ExceptionTests+        -- Tests that have been pulled out of the main file+        BootTests+        CodeLensTests+        CompletionTests+        CPPTests+        CradleTests+        DependentFileTest+        DiagnosticTests+        FindDefinitionAndHoverTests+        HaddockTests+        HighlightTests+        IfaceTests+        InitializeResponseTests+        LogType+        NonLspCommandLine+        OutlineTests+        PluginParsedResultTests+        PluginSimpleTests+        PositionMappingTests+        PreprocessorTests+        RootUriTests+        SafeTests+        SymlinkTests+        TestUtils+        THTests+        UnitTests+        WatchedFileTests+        AsyncTests+        ClientSettingsTests+        ReferenceTests+        GarbageCollectionTests+        OpenCloseTest     default-extensions:         BangPatterns         DeriveFunctor

@@ -43,6 +43,7 @@ import           Data.List import qualified Data.Map.Strict                      as Map import           Data.Maybe+import           Data.Proxy import qualified Data.Text                            as T import           Data.Time.Clock import           Data.Version@@ -64,13 +65,6 @@ import           Development.IDE.Types.HscEnvEq       (HscEnvEq, newHscEnvEq,                                                        newHscEnvEqPreserveImportPaths) import           Development.IDE.Types.Location-import           Development.IDE.Types.Logger         (Pretty (pretty),-                                                       Priority (Debug, Error, Info, Warning),-                                                       Recorder, WithPriority,-                                                       cmapWithPrio, logWith,-                                                       nest,-                                                       toCologActionWithPrio,-                                                       vcat, viaShow, (<+>)) import           Development.IDE.Types.Options import           GHC.Check import qualified HIE.Bios                             as HieBios@@ -78,8 +72,15 @@ import           HIE.Bios.Types                       hiding (Log) import qualified HIE.Bios.Types                       as HieBios import           Hie.Implicit.Cradle                  (loadImplicitHieCradle)+import           Ide.Logger                           (Pretty (pretty),+                                                       Priority (Debug, Error, Info, Warning),+                                                       Recorder, WithPriority,+                                                       cmapWithPrio, logWith,+                                                       nest,+                                                       toCologActionWithPrio,+                                                       vcat, viaShow, (<+>))+import           Language.LSP.Protocol.Message import           Language.LSP.Server-import           Language.LSP.Types import           System.Directory import qualified System.Directory.Extra               as IO import           System.FilePath@@ -483,7 +484,25 @@         packageSetup (hieYaml, cfp, opts, libDir) = do           -- Parse DynFlags for the newly discovered component           hscEnv <- emptyHscEnv ideNc libDir-          (df, targets) <- evalGhcEnv hscEnv $ setOptions opts (hsc_dflags hscEnv)+          (df', targets) <- evalGhcEnv hscEnv $ setOptions opts (hsc_dflags hscEnv)+          let df =+#if MIN_VERSION_ghc(9,3,0)+                case unitIdString (homeUnitId_ df') of+                     -- cabal uses main for the unit id of all executable packages+                     -- This makes multi-component sessions confused about what+                     -- options to use for that component.+                     -- Solution: hash the options and use that as part of the unit id+                     -- This works because there won't be any dependencies on the+                     -- executable unit.+                     "main" ->+                       let hash = B.unpack $ B16.encode $ H.finalize $ H.updates H.init (map B.pack $ componentOptions opts)+                           hashed_uid = Compat.toUnitId (Compat.stringToUnit ("main-"++hash))+                       in setHomeUnitId_ hashed_uid df'+                     _ -> df'+#else+                df'+#endif+           let deps = componentDependencies opts ++ maybeToList hieYaml           dep_info <- getDependencyInfo deps           -- Now lookup to see whether we are combining with an existing HscEnv@@ -498,6 +517,7 @@                   -- We will modify the unitId and DynFlags used for                   -- compilation but these are the true source of                   -- information.+                                     new_deps = RawComponentInfo (homeUnitId_ df) df targets cfp opts dep_info                                 : maybe [] snd oldDeps                   -- Get all the unit-ids for things in this component@@ -632,7 +652,7 @@            lfp <- flip makeRelative cfp <$> getCurrentDirectory             when optTesting $ mRunLspT lspEnv $-            sendNotification (SCustomMethod "ghcide/cradle/loaded") (toJSON cfp)+            sendNotification (SMethod_CustomMethod (Proxy @"ghcide/cradle/loaded")) (toJSON cfp)             -- Display a user friendly progress message here: They probably don't know what a cradle is            let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle))@@ -906,7 +926,7 @@  renderCradleError :: NormalizedFilePath -> CradleError -> FileDiagnostic renderCradleError nfp (CradleError _ _ec t) =-  ideErrorWithSource (Just "cradle") (Just DsError) nfp (T.unlines (map T.pack t))+  ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) nfp (T.unlines (map T.pack t))  -- See Note [Multi Cradle Dependency Info] type DependencyInfo = Map.Map FilePath (Maybe UTCTime)@@ -1120,4 +1140,4 @@  renderPackageSetupException :: FilePath -> PackageSetupException -> (NormalizedFilePath, ShowDiagnostic, Diagnostic) renderPackageSetupException fp e =-    ideErrorWithSource (Just "cradle") (Just DsError) (toNormalizedFilePath' fp) (T.pack $ showPackageSetupException e)+    ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) (toNormalizedFilePath' fp) (T.pack $ showPackageSetupException e)

@@ -8,9 +8,7 @@  import           Development.IDE.Core.Actions          as X (getAtPoint,                                                              getDefinition,-                                                             getTypeDefinition,-                                                             useE, useNoFileE,-                                                             usesE)+                                                             getTypeDefinition) import           Development.IDE.Core.FileExists       as X (getFileExists) import           Development.IDE.Core.FileStore        as X (getFileContents) import           Development.IDE.Core.IdeConfiguration as X (IdeConfiguration (..),@@ -55,4 +53,4 @@                                                              hscEnv,                                                              hscEnvWithImportPaths) import           Development.IDE.Types.Location        as X-import           Development.IDE.Types.Logger          as X+import           Ide.Logger                            as X

@@ -6,13 +6,11 @@ , getTypeDefinition , highlightAtPoint , refsAtPoint-, useE-, useNoFileE-, usesE , workspaceSymbols , lookupMod ) where +import           Control.Monad.Extra                  (mapMaybeM) import           Control.Monad.Reader import           Control.Monad.Trans.Maybe import qualified Data.HashMap.Strict                  as HM@@ -20,6 +18,7 @@ import qualified Data.Text                            as T import           Data.Tuple.Extra import           Development.IDE.Core.OfInterest+import           Development.IDE.Core.PluginUtils import           Development.IDE.Core.PositionMapping import           Development.IDE.Core.RuleTypes import           Development.IDE.Core.Service@@ -30,8 +29,10 @@ import           Development.IDE.Types.HscEnvEq       (hscEnv) import           Development.IDE.Types.Location import qualified HieDb-import           Language.LSP.Types                   (DocumentHighlight (..),-                                                       SymbolInformation (..))+import           Language.LSP.Protocol.Types          (DocumentHighlight (..),+                                                       SymbolInformation (..),+                                                       normalizedFilePathToUri,+                                                       uriToNormalizedFilePath)   -- | Eventually this will lookup/generate URIs for files in dependencies, but not in the@@ -46,7 +47,7 @@ lookupMod _dbchan _hie_f _mod _uid _boot = MaybeT $ pure Nothing  --- IMPORTANT NOTE : make sure all rules `useE`d by these have a "Persistent Stale" rule defined,+-- IMPORTANT NOTE : make sure all rules `useWithStaleFastMT`d by these have a "Persistent Stale" rule defined, -- so we can quickly answer as soon as the IDE is opened -- Even if we don't have persistent information on disk for these rules, the persistent rule -- should just return an empty result@@ -59,50 +60,67 @@   ide <- ask   opts <- liftIO $ getIdeOptionsIO ide -  (hf, mapping) <- useE GetHieAst file-  env <- hscEnv . fst <$> useE GhcSession file-  dkMap <- lift $ maybe (DKMap mempty mempty) fst <$> runMaybeT (useE GetDocMap file)+  (hf, mapping) <- useWithStaleFastMT GetHieAst file+  env <- hscEnv . fst <$> useWithStaleFastMT GhcSession file+  dkMap <- lift $ maybe (DKMap mempty mempty) fst <$> runMaybeT (useWithStaleFastMT GetDocMap file)    !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)-  MaybeT $ pure $ first (toCurrentRange mapping =<<) <$> AtPoint.atPoint opts hf dkMap env pos'+  MaybeT $ liftIO $ fmap (first (toCurrentRange mapping =<<)) <$> AtPoint.atPoint opts hf dkMap env pos' -toCurrentLocations :: PositionMapping -> [Location] -> [Location]-toCurrentLocations mapping = mapMaybe go+-- | For each Loacation, determine if we have the PositionMapping+-- for the correct file. If not, get the correct position mapping+-- and then apply the position mapping to the location.+toCurrentLocations+  :: PositionMapping+  -> NormalizedFilePath+  -> [Location]+  -> IdeAction [Location]+toCurrentLocations mapping file = mapMaybeM go   where-    go (Location uri range) = Location uri <$> toCurrentRange mapping range---- | useE is useful to implement functions that aren’t rules but need shortcircuiting--- e.g. getDefinition.-useE :: IdeRule k v => k -> NormalizedFilePath -> MaybeT IdeAction (v, PositionMapping)-useE k = MaybeT . useWithStaleFast k--useNoFileE :: IdeRule k v => IdeState -> k -> MaybeT IdeAction v-useNoFileE _ide k = fst <$> useE k emptyFilePath--usesE :: IdeRule k v => k -> [NormalizedFilePath] -> MaybeT IdeAction [(v,PositionMapping)]-usesE k = MaybeT . fmap sequence . mapM (useWithStaleFast k)+    go :: Location -> IdeAction (Maybe Location)+    go (Location uri range) =+      -- The Location we are going to might be in a different+      -- file than the one we are calling gotoDefinition from.+      -- So we check that the location file matches the file+      -- we are in.+      if nUri == normalizedFilePathToUri file+      -- The Location matches the file, so use the PositionMapping+      -- we have.+      then pure $ Location uri <$> toCurrentRange mapping range+      -- The Location does not match the file, so get the correct+      -- PositionMapping and use that instead.+      else do+        otherLocationMapping <- fmap (fmap snd) $ runMaybeT $ do+          otherLocationFile <- MaybeT $ pure $ uriToNormalizedFilePath nUri+          useWithStaleFastMT GetHieAst otherLocationFile+        pure $ Location uri <$> (flip toCurrentRange range =<< otherLocationMapping)+      where+        nUri :: NormalizedUri+        nUri = toNormalizedUri uri  -- | Goto Definition. getDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location]) getDefinition file pos = runMaybeT $ do     ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask     opts <- liftIO $ getIdeOptionsIO ide-    (HAR _ hf _ _ _, mapping) <- useE GetHieAst file-    (ImportMap imports, _) <- useE GetImportMap file+    (HAR _ hf _ _ _, mapping) <- useWithStaleFastMT GetHieAst file+    (ImportMap imports, _) <- useWithStaleFastMT GetImportMap file     !pos' <- MaybeT (pure $ fromCurrentPosition mapping pos)-    toCurrentLocations mapping <$> AtPoint.gotoDefinition withHieDb (lookupMod hiedbWriter) opts imports hf pos'+    locations <- AtPoint.gotoDefinition withHieDb (lookupMod hiedbWriter) opts imports hf pos'+    MaybeT $ Just <$> toCurrentLocations mapping file locations  getTypeDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location]) getTypeDefinition file pos = runMaybeT $ do     ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask     opts <- liftIO $ getIdeOptionsIO ide-    (hf, mapping) <- useE GetHieAst file+    (hf, mapping) <- useWithStaleFastMT GetHieAst file     !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)-    toCurrentLocations mapping <$> AtPoint.gotoTypeDefinition withHieDb (lookupMod hiedbWriter) opts hf pos'+    locations <- AtPoint.gotoTypeDefinition withHieDb (lookupMod hiedbWriter) opts hf pos'+    MaybeT $ Just <$> toCurrentLocations mapping file locations  highlightAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe [DocumentHighlight]) highlightAtPoint file pos = runMaybeT $ do-    (HAR _ hf rf _ _,mapping) <- useE GetHieAst file+    (HAR _ hf rf _ _,mapping) <- useWithStaleFastMT GetHieAst file     !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)     let toCurrentHighlight (DocumentHighlight range t) = flip DocumentHighlight t <$> toCurrentRange mapping range     mapMaybe toCurrentHighlight <$>AtPoint.documentHighlight hf rf pos'

@@ -34,6 +34,9 @@   , ml_core_file   , coreFileToLinkable   , TypecheckHelpers(..)+  , sourceTypecheck+  , sourceParser+  , shareUsages   ) where  import           Control.Monad.IO.Class@@ -64,6 +67,7 @@ import           Data.List.Extra import           Data.Map                          (Map) import qualified Data.Map.Strict                   as Map+import           Data.Proxy                        (Proxy(Proxy)) import qualified Data.Set                          as Set import           Data.Maybe import qualified Data.Text                         as T@@ -98,8 +102,9 @@ import           GHC.Serialized import           HieDb import qualified Language.LSP.Server               as LSP-import           Language.LSP.Types                (DiagnosticTag (..))-import qualified Language.LSP.Types                as LSP+import           Language.LSP.Protocol.Types                (DiagnosticTag (..))+import qualified Language.LSP.Protocol.Types                as LSP+import qualified Language.LSP.Protocol.Message            as LSP import           System.Directory import           System.FilePath import           System.IO.Extra                   (fixIO, newTempFileWithin)@@ -132,6 +137,7 @@ import qualified GHC                               as G import           GHC.Hs                            (LEpaComment) import qualified GHC.Types.Error                   as Error+import Development.IDE.Import.DependencyInformation #endif  #if MIN_VERSION_ghc(9,5,0)@@ -139,6 +145,12 @@ import GHC.Core.Lint.Interactive #endif +--Simple constansts to make sure the source is consistently named+sourceTypecheck :: T.Text+sourceTypecheck = "typecheck"+sourceParser :: T.Text+sourceParser = "parser"+ -- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'. parseModule     :: IdeOptions@@ -182,13 +194,13 @@         case initialized of           Left errs -> return (errs, Nothing)           Right (modSummary', hsc) -> do-            (warnings, etcm) <- withWarnings "typecheck" $ \tweak ->+            (warnings, etcm) <- withWarnings sourceTypecheck $ \tweak ->                 let                   session = tweak (hscSetFlags dflags hsc)                    -- TODO: maybe settings ms_hspp_opts is unnecessary?                   mod_summary'' = modSummary' { ms_hspp_opts = hsc_dflags session}                 in-                  catchSrcErrors (hsc_dflags hsc) "typecheck" $ do+                  catchSrcErrors (hsc_dflags hsc) sourceTypecheck $ do                     tcRnModule session tc_helpers $ demoteIfDefer pm{pm_mod_summary = mod_summary''}             let errorPipeline = unDefer . hideDiag dflags . tagDiag                 diags = map errorPipeline warnings@@ -351,6 +363,10 @@ #if MIN_VERSION_ghc(9,3,0)     -- TODO: support backpack     nodeKeyToInstalledModule :: NodeKey -> Maybe InstalledModule+    -- We shouldn't get boot files here, but to be safe, never map them to an installed module+    -- because boot files don't have linkables we can load, and we will fail if we try to look+    -- for them+    nodeKeyToInstalledModule (NodeKey_Module (ModNodeKeyWithUid (GWIB mod IsBoot) uid)) = Nothing     nodeKeyToInstalledModule (NodeKey_Module (ModNodeKeyWithUid (GWIB mod _) uid)) = Just $ mkModule uid mod     nodeKeyToInstalledModule _ = Nothing     moduleToNodeKey :: Module -> NodeKey@@ -458,6 +474,8 @@ #endif  -- | Mitigation for https://gitlab.haskell.org/ghc/ghc/-/issues/22744+-- Important to do this immediately after reading the unit before+-- anything else has a chance to read `mi_usages` shareUsages :: ModIface -> ModIface shareUsages iface = iface {mi_usages = usages}   where usages = map go (mi_usages iface)@@ -611,7 +629,7 @@     source = "compile"     catchErrs x = x `catches`       [ Handler $ return . (,Nothing) . diagFromGhcException source dflags-      , Handler $ return . (,Nothing) . diagFromString source DsError (noSpan "<internal>")+      , Handler $ return . (,Nothing) . diagFromString source DiagnosticSeverity_Error (noSpan "<internal>")       . (("Error during " ++ T.unpack source) ++) . show @SomeException       ] @@ -741,7 +759,7 @@  upgradeWarningToError :: FileDiagnostic -> FileDiagnostic upgradeWarningToError (nfp, sh, fd) =-  (nfp, sh, fd{_severity = Just DsError, _message = warn2err $ _message fd}) where+  (nfp, sh, fd{_severity = Just DiagnosticSeverity_Error, _message = warn2err $ _message fd}) where   warn2err :: T.Text -> T.Text   warn2err = T.intercalate ": error:" . T.splitOn ": warning:" @@ -780,18 +798,15 @@ tagDiag (w@(Reason warning), (nfp, sh, fd)) #endif   | Just tag <- requiresTag warning-  = (w, (nfp, sh, fd { _tags = addTag tag (_tags fd) }))+  = (w, (nfp, sh, fd { _tags = Just $ tag : concat (_tags fd) }))   where     requiresTag :: WarningFlag -> Maybe DiagnosticTag     requiresTag Opt_WarnWarningsDeprecations-      = Just DtDeprecated+      = Just DiagnosticTag_Deprecated     requiresTag wflag  -- deprecation was already considered above       | wflag `elem` unnecessaryDeprecationWarningFlags-      = Just DtUnnecessary+      = Just DiagnosticTag_Unnecessary     requiresTag _ = Nothing-    addTag :: DiagnosticTag -> Maybe (List DiagnosticTag) -> Maybe (List DiagnosticTag)-    addTag t Nothing          = Just (List [t])-    addTag t (Just (List ts)) = Just (List (t : ts)) -- other diagnostics are left unaffected tagDiag t = t @@ -901,9 +916,10 @@             -- If the hash in the pending list doesn't match the current hash, then skip             Just pendingHash -> pendingHash /= hash         unless newerScheduled $ do-          pre optProgressStyle-          withHieDb (\db -> HieDb.addRefsFromLoaded db targetPath (HieDb.RealFile $ fromNormalizedFilePath srcPath) hash hf')-          post+          -- Using bracket, so even if an exception happen during withHieDb call,+          -- the `post` (which clean the progress indicator) will still be called.+          bracket_ (pre optProgressStyle) post $+            withHieDb (\db -> HieDb.addRefsFromLoaded db targetPath (HieDb.RealFile $ fromNormalizedFilePath srcPath) hash hf')   where     mod_location    = ms_location mod_summary     targetPath      = Compat.ml_hie_file mod_location@@ -918,12 +934,13 @@           case lspEnv se of             Nothing -> pure Nothing             Just env -> LSP.runLspT env $ do-              u <- LSP.ProgressTextToken . T.pack . show . hashUnique <$> liftIO Unique.newUnique+              u <- LSP.ProgressToken . LSP.InR . T.pack . show . hashUnique <$> liftIO Unique.newUnique               -- TODO: Wait for the progress create response to use the token-              _ <- LSP.sendRequest LSP.SWindowWorkDoneProgressCreate (LSP.WorkDoneProgressCreateParams u) (const $ pure ())-              LSP.sendNotification LSP.SProgress $ LSP.ProgressParams u $-                LSP.Begin $ LSP.WorkDoneProgressBeginParams-                  { _title = "Indexing"+              _ <- LSP.sendRequest LSP.SMethod_WindowWorkDoneProgressCreate (LSP.WorkDoneProgressCreateParams u) (const $ pure ())+              LSP.sendNotification LSP.SMethod_Progress $ LSP.ProgressParams u $+                toJSON $ LSP.WorkDoneProgressBegin+                  { _kind = LSP.AString @"begin"+                  ,  _title = "Indexing"                   , _cancellable = Nothing                   , _message = Nothing                   , _percentage = Nothing@@ -941,22 +958,25 @@         progressPct = floor $ 100 * progressFrac        whenJust (lspEnv se) $ \env -> whenJust tok $ \tok -> LSP.runLspT env $-        LSP.sendNotification LSP.SProgress $ LSP.ProgressParams tok $-          LSP.Report $+        LSP.sendNotification LSP.SMethod_Progress $ LSP.ProgressParams tok $+          toJSON $             case style of-                Percentage -> LSP.WorkDoneProgressReportParams-                    { _cancellable = Nothing+                Percentage -> LSP.WorkDoneProgressReport+                    { _kind = LSP.AString @"report"+                    , _cancellable = Nothing                     , _message = Nothing                     , _percentage = Just progressPct                     }-                Explicit -> LSP.WorkDoneProgressReportParams-                    { _cancellable = Nothing+                Explicit -> LSP.WorkDoneProgressReport+                    { _kind = LSP.AString @"report"+                    , _cancellable = Nothing                     , _message = Just $                         T.pack " (" <> T.pack (show done) <> "/" <> T.pack (show $ done + remaining) <> ")..."                     , _percentage = Nothing                     }-                NoProgress -> LSP.WorkDoneProgressReportParams-                  { _cancellable = Nothing+                NoProgress -> LSP.WorkDoneProgressReport+                  { _kind = LSP.AString @"report"+                  , _cancellable = Nothing                   , _message = Nothing                   , _percentage = Nothing                   }@@ -973,15 +993,17 @@           swapTVar indexCompleted 0       whenJust (lspEnv se) $ \env -> LSP.runLspT env $         when (coerce $ ideTesting se) $-          LSP.sendNotification (LSP.SCustomMethod "ghcide/reference/ready") $+          LSP.sendNotification (LSP.SMethod_CustomMethod (Proxy @"ghcide/reference/ready")) $             toJSON $ fromNormalizedFilePath srcPath       whenJust mdone $ \done ->         modifyVar_ indexProgressToken $ \tok -> do           whenJust (lspEnv se) $ \env -> LSP.runLspT env $             whenJust tok $ \tok ->-              LSP.sendNotification LSP.SProgress $ LSP.ProgressParams tok $-                LSP.End $ LSP.WorkDoneProgressEndParams-                  { _message = Just $ "Finished indexing " <> T.pack (show done) <> " files"+              LSP.sendNotification LSP.SMethod_Progress  $ LSP.ProgressParams tok $+                toJSON $+                LSP.WorkDoneProgressEnd+                  { _kind = LSP.AString @"end"+                  , _message = Just $ "Finished indexing " <> T.pack (show done) <> " files"                   }           -- We are done with the current indexing cycle, so destroy the token           pure Nothing@@ -1013,7 +1035,7 @@ handleGenerationErrors dflags source action =   action >> return [] `catches`     [ Handler $ return . diagFromGhcException source dflags-    , Handler $ return . diagFromString source DsError (noSpan "<internal>")+    , Handler $ return . diagFromString source DiagnosticSeverity_Error (noSpan "<internal>")     . (("Error during " ++ T.unpack source) ++) . show @SomeException     ] @@ -1021,7 +1043,7 @@ handleGenerationErrors' dflags source action =   fmap ([],) action `catches`     [ Handler $ return . (,Nothing) . diagFromGhcException source dflags-    , Handler $ return . (,Nothing) . diagFromString source DsError (noSpan "<internal>")+    , Handler $ return . (,Nothing) . diagFromString source DiagnosticSeverity_Error (noSpan "<internal>")     . (("Error during " ++ T.unpack source) ++) . show @SomeException     ] @@ -1031,25 +1053,19 @@ -- Add the current ModSummary to the graph, along with the -- HomeModInfo's of all direct dependencies (by induction hypothesis all -- transitive dependencies will be contained in envs)+mergeEnvs :: HscEnv -> ModuleGraph -> ModSummary -> [HomeModInfo] -> [HscEnv] -> IO HscEnv+mergeEnvs env mg ms extraMods envs = do #if MIN_VERSION_ghc(9,3,0)-mergeEnvs :: HscEnv -> (ModSummary, [NodeKey]) -> [HomeModInfo] -> [HscEnv] -> IO HscEnv-mergeEnvs env (ms, deps) extraMods envs = do     let im  = Compat.installedModule (toUnitId $ moduleUnit $ ms_mod ms) (moduleName (ms_mod ms))         ifr = InstalledFound (ms_location ms) im         curFinderCache = Compat.extendInstalledModuleEnv Compat.emptyInstalledModuleEnv im ifr-        -- Very important to force this as otherwise the hsc_mod_graph field is not-        -- forced and ends up retaining a reference to all the old hsc_envs we have merged to get-        -- this new one, which in turn leads to the EPS referencing the HPT.-        module_graph_nodes =-          nubOrdOn mkNodeKey (ModuleNode deps ms : concatMap (mgModSummaries' . hsc_mod_graph) envs)-     newFinderCache <- concatFC curFinderCache (map hsc_FC envs)-    liftRnf rwhnf module_graph_nodes `seq` (return $ loadModulesHome extraMods $+    return $! loadModulesHome extraMods $       let newHug = foldl' mergeHUG (hsc_HUG env) (map hsc_HUG envs) in       (hscUpdateHUG (const newHug) env){           hsc_FC = newFinderCache,-          hsc_mod_graph = mkModuleGraph module_graph_nodes-      })+          hsc_mod_graph = mg+      }      where         mergeHUG (UnitEnvGraph a) (UnitEnvGraph b) = UnitEnvGraph $ Map.unionWith mergeHUE a b@@ -1059,39 +1075,32 @@         combineModules a b           | HsSrcFile <- mi_hsc_src (hm_iface a) = a           | otherwise = b++        -- Prefer non-boot files over non-boot files+        -- otherwise we can get errors like https://gitlab.haskell.org/ghc/ghc/-/issues/19816+        -- if a boot file shadows over a non-boot file+        combineModuleLocations a@(InstalledFound ml m) b | Just fp <- ml_hs_file ml, not ("boot" `isSuffixOf` fp) = a+        combineModuleLocations _ b = b+         concatFC :: FinderCacheState -> [FinderCache] -> IO FinderCache         concatFC cur xs = do           fcModules <- mapM (readIORef . fcModuleCache) xs           fcFiles <- mapM (readIORef . fcFileCache) xs-          fcModules' <- newIORef $! foldl' (plusInstalledModuleEnv const) cur fcModules+          fcModules' <- newIORef $! foldl' (plusInstalledModuleEnv combineModuleLocations) cur fcModules           fcFiles' <- newIORef $! Map.unions fcFiles           pure $ FinderCache fcModules' fcFiles'  #else-mergeEnvs :: HscEnv -> ModSummary -> [HomeModInfo] -> [HscEnv] -> IO HscEnv-mergeEnvs env ms extraMods envs = do     prevFinderCache <- concatFC <$> mapM (readIORef . hsc_FC) envs     let im  = Compat.installedModule (toUnitId $ moduleUnit $ ms_mod ms) (moduleName (ms_mod ms))         ifr = InstalledFound (ms_location ms) im-        -- Very important to force this as otherwise the hsc_mod_graph field is not-        -- forced and ends up retaining a reference to all the old hsc_envs we have merged to get-        -- this new one, which in turn leads to the EPS referencing the HPT.-        module_graph_nodes =-#if MIN_VERSION_ghc(9,2,0)-        -- We don't do any instantiation for backpack at this point of time, so it is OK to use-        -- 'extendModSummaryNoDeps'.-        -- This may have to change in the future.-          map extendModSummaryNoDeps $-#endif-          nubOrdOn ms_mod (ms : concatMap (mgModSummaries . hsc_mod_graph) envs)-     newFinderCache <- newIORef $! Compat.extendInstalledModuleEnv prevFinderCache im ifr-    liftRnf rwhnf module_graph_nodes `seq` (return $ loadModulesHome extraMods $+    return $! loadModulesHome extraMods $       env{           hsc_HPT = foldMapBy mergeUDFM emptyUDFM hsc_HPT envs,           hsc_FC = newFinderCache,-          hsc_mod_graph = mkModuleGraph module_graph_nodes-      })+          hsc_mod_graph = mg+      }      where         mergeUDFM = plusUDFM_C combineModules@@ -1248,7 +1257,7 @@    let loc  = mkRealSrcLoc (Util.mkFastString filename) 1 1    case unP Compat.parseHeader (initParserState (initParserOpts dflags) contents loc) of      PFailedWithErrorMessages msgs ->-        throwE $ diagFromErrMsgs "parser" dflags $ msgs dflags+        throwE $ diagFromErrMsgs sourceParser dflags $ msgs dflags      POk pst rdr_module -> do         let (warns, errs) = renderMessages $ getPsMessages pst dflags @@ -1262,9 +1271,9 @@         -- errors are those from which a parse tree just can't         -- be produced.         unless (null errs) $-            throwE $ diagFromErrMsgs "parser" dflags errs+            throwE $ diagFromErrMsgs sourceParser dflags errs -        let warnings = diagFromErrMsgs "parser" dflags warns+        let warnings = diagFromErrMsgs sourceParser dflags warns         return (warnings, rdr_module)  -- | Given a buffer, flags, and file path, produce a@@ -1281,7 +1290,7 @@        dflags = ms_hspp_opts ms        contents = fromJust $ ms_hspp_buf ms    case unP Compat.parseModule (initParserState (initParserOpts dflags) contents loc) of-     PFailedWithErrorMessages msgs -> throwE $ diagFromErrMsgs "parser" dflags $ msgs dflags+     PFailedWithErrorMessages msgs -> throwE $ diagFromErrMsgs sourceParser dflags $ msgs dflags      POk pst rdr_module ->          let              hpm_annotations = mkApiAnns pst@@ -1291,9 +1300,9 @@                let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module                 unless (null errs) $-                  throwE $ diagFromStrings "parser" DsError errs+                  throwE $ diagFromStrings sourceParser DiagnosticSeverity_Error errs -               let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns+               let preproc_warnings = diagFromStrings sourceParser DiagnosticSeverity_Warning preproc_warns                (parsed', msgs) <- liftIO $ applyPluginsParsedResultAction env dflags ms hpm_annotations parsed psMessages                let (warns, errs) = renderMessages msgs @@ -1307,7 +1316,7 @@                -- errors are those from which a parse tree just can't                -- be produced.                unless (null errs) $-                 throwE $ diagFromErrMsgs "parser" dflags errs+                 throwE $ diagFromErrMsgs sourceParser dflags errs                  -- To get the list of extra source files, we take the list@@ -1342,7 +1351,7 @@                srcs2 <- liftIO $ filterM doesFileExist srcs1                 let pm = ParsedModule ms parsed' srcs2 hpm_annotations-                   warnings = diagFromErrMsgs "parser" dflags warns+                   warnings = diagFromErrMsgs sourceParser dflags warns                pure (warnings ++ preproc_warnings, pm)  loadHieFile :: Compat.NameCacheUpdater -> FilePath -> IO GHC.HieFile@@ -1465,11 +1474,28 @@             | source_version <= dest_version -> SourceUnmodified             | otherwise -> SourceModified +    old_iface <- case mb_old_iface of+      Just iface -> pure (Just iface)+      Nothing -> do+        let ncu = hsc_NC sessionWithMsDynFlags+            read_dflags = hsc_dflags sessionWithMsDynFlags+#if MIN_VERSION_ghc(9,3,0)+        read_result <- liftIO $ readIface read_dflags ncu mod iface_file+#else+        read_result <- liftIO $ initIfaceCheck (text "readIface") sessionWithMsDynFlags+                              $ readIface mod iface_file+#endif+        case read_result of+          Util.Failed{} -> return Nothing+          -- important to call `shareUsages` here before checkOldIface+          -- consults `mi_usages`+          Util.Succeeded iface -> return $ Just (shareUsages iface)+     -- If mb_old_iface is nothing then checkOldIface will load it for us     -- given that the source is unmodified     (recomp_iface_reqd, mb_checked_iface) #if MIN_VERSION_ghc(9,3,0)-      <- liftIO $ checkOldIface sessionWithMsDynFlags ms mb_old_iface >>= \case+      <- liftIO $ checkOldIface sessionWithMsDynFlags ms old_iface >>= \case         UpToDateItem x -> pure (UpToDate, Just x)         OutOfDateItem reason x -> pure (NeedsRecompile reason, x) #else@@ -1483,15 +1509,14 @@           regenerate linkableNeeded      case (mb_checked_iface, recomp_iface_reqd) of-      (Just iface', UpToDate) -> do-             let iface = shareUsages iface'+      (Just iface, UpToDate) -> do              details <- liftIO $ mkDetailsFromIface sessionWithMsDynFlags iface              -- parse the runtime dependencies from the annotations              let runtime_deps                    | not (mi_used_th iface) = emptyModuleEnv                    | otherwise = parseRuntimeDeps (md_anns details)-             -- Perform the fine grained recompilation check for TH-             maybe_recomp <- checkLinkableDependencies get_linkable_hashes (hsc_mod_graph sessionWithMsDynFlags) runtime_deps+             -- Peform the fine grained recompilation check for TH+             maybe_recomp <- checkLinkableDependencies session get_linkable_hashes runtime_deps              case maybe_recomp of                Just msg -> do_regenerate msg                Nothing@@ -1528,13 +1553,21 @@ -- the runtime dependencies of the module, to check if any of them are out of date -- Hopefully 'runtime_deps' will be empty if the module didn't actually use TH -- See Note [Recompilation avoidance in the presence of TH]-checkLinkableDependencies :: MonadIO m => ([NormalizedFilePath] -> m [BS.ByteString]) -> ModuleGraph -> ModuleEnv BS.ByteString -> m (Maybe RecompileRequired)-checkLinkableDependencies get_linkable_hashes graph runtime_deps = do-  let hs_files = mapM go (moduleEnvToList runtime_deps)-      go (mod, hash) = do-        ms <- mgLookupModule graph mod-        let hs = fromJust $ ml_hs_file $ ms_location ms-        pure (toNormalizedFilePath' hs, hash)+checkLinkableDependencies :: MonadIO m => HscEnv -> ([NormalizedFilePath] -> m [BS.ByteString]) -> ModuleEnv BS.ByteString -> m (Maybe RecompileRequired)+checkLinkableDependencies hsc_env get_linkable_hashes runtime_deps = do+#if MIN_VERSION_ghc(9,3,0)+  moduleLocs <- liftIO $ readIORef (fcModuleCache $ hsc_FC hsc_env)+#else+  moduleLocs <- liftIO $ readIORef (hsc_FC hsc_env)+#endif+  let go (mod, hash) = do+        ifr <- lookupInstalledModuleEnv moduleLocs $ Compat.installedModule (toUnitId $ moduleUnit mod) (moduleName mod)+        case ifr of+          InstalledFound loc _ -> do+            hs <- ml_hs_file loc+            pure (toNormalizedFilePath' hs,hash)+          _ -> Nothing+      hs_files = mapM go (moduleEnvToList runtime_deps)   case hs_files of     Nothing -> error "invalid module graph"     Just fs -> do

@@ -27,14 +27,14 @@ import qualified Development.IDE.Core.Shake            as Shake import           Development.IDE.Graph import           Development.IDE.Types.Location-import           Development.IDE.Types.Logger          (Pretty (pretty),-                                                        Recorder, WithPriority,-                                                        cmapWithPrio) import           Development.IDE.Types.Options import qualified Focus+import           Ide.Logger                            (Pretty (pretty),+                                                        Recorder, WithPriority,+                                                        cmapWithPrio) import           Ide.Plugin.Config                     (Config)+import           Language.LSP.Protocol.Types import           Language.LSP.Server                   hiding (getVirtualFile)-import           Language.LSP.Types import qualified StmContainers.Map                     as STM import qualified System.Directory                      as Dir import qualified System.FilePath.Glob                  as Glob@@ -117,16 +117,16 @@     -- See Note [Invalidating file existence results]     -- flush previous values     let (fileModifChanges, fileExistChanges) =-            partition ((== FcChanged) . snd) changes+            partition ((== FileChangeType_Changed) . snd) changes     mapM_ (deleteValue (shakeExtras state) GetFileExists . fst) fileExistChanges     io1 <- recordDirtyKeys (shakeExtras state) GetFileExists $ map fst fileExistChanges     io2 <- recordDirtyKeys (shakeExtras state) GetModificationTime $ map fst fileModifChanges     return (io1 <> io2)  fromChange :: FileChangeType -> Maybe Bool-fromChange FcCreated = Just True-fromChange FcDeleted = Just False-fromChange FcChanged = Nothing+fromChange FileChangeType_Created = Just True+fromChange FileChangeType_Deleted = Just False+fromChange FileChangeType_Changed = Nothing  ------------------------------------------------------------------------------------- 

@@ -54,29 +54,29 @@ #else #endif -import qualified Development.IDE.Types.Logger                 as L+import qualified Ide.Logger                                   as L +import           Data.Aeson                                   (ToJSON (toJSON)) import qualified Data.Binary                                  as B import qualified Data.ByteString.Lazy                         as LBS import           Data.List                                    (foldl') import qualified Data.Text                                    as Text import           Development.IDE.Core.IdeConfiguration        (isWorkspaceFile) import qualified Development.IDE.Core.Shake                   as Shake-import           Development.IDE.Types.Logger                 (Pretty (pretty),+import           Ide.Logger                                   (Pretty (pretty),                                                                Priority (Info),                                                                Recorder,                                                                WithPriority,                                                                cmapWithPrio,                                                                logWith, viaShow,                                                                (<+>))-import qualified Language.LSP.Server                          as LSP-import           Language.LSP.Types                           (DidChangeWatchedFilesRegistrationOptions (DidChangeWatchedFilesRegistrationOptions),-                                                               FileChangeType (FcChanged),+import           Language.LSP.Protocol.Message                (toUntypedRegistration)+import qualified Language.LSP.Protocol.Message                as LSP+import           Language.LSP.Protocol.Types                  (DidChangeWatchedFilesRegistrationOptions (DidChangeWatchedFilesRegistrationOptions),                                                                FileSystemWatcher (..),-                                                               WatchKind (..),                                                                _watchers)-import qualified Language.LSP.Types                           as LSP-import qualified Language.LSP.Types.Capabilities              as LSP+import qualified Language.LSP.Protocol.Types                  as LSP+import qualified Language.LSP.Server                          as LSP import           Language.LSP.VFS import           System.FilePath import           System.IO.Unsafe@@ -162,14 +162,14 @@  -- | Reset the GetModificationTime state of watched files --   Assumes the list does not include any FOIs-resetFileStore :: IdeState -> [(NormalizedFilePath, FileChangeType)] -> IO ()+resetFileStore :: IdeState -> [(NormalizedFilePath, LSP.FileChangeType)] -> IO () resetFileStore ideState changes = mask $ \_ -> do     -- we record FOIs document versions in all the stored values     -- so NEVER reset FOIs to avoid losing their versions     -- FOI filtering is done by the caller (LSP Notification handler)     forM_ changes $ \(nfp, c) -> do         case c of-            FcChanged+            LSP.FileChangeType_Changed             --  already checked elsewhere |  not $ HM.member nfp fois               -> atomically $                deleteValue (shakeExtras ideState) GetModificationTime nfp@@ -268,26 +268,27 @@       if watchSupported       then do         let-          regParams    = LSP.RegistrationParams (List [LSP.SomeRegistration registration])+          regParams    = LSP.RegistrationParams  [toUntypedRegistration registration]           -- The registration ID is arbitrary and is only used in case we want to deregister (which we won't).           -- We could also use something like a random UUID, as some other servers do, but this works for           -- our purposes.-          registration = LSP.Registration "globalFileWatches"-                                           LSP.SWorkspaceDidChangeWatchedFiles-                                           regOptions+          registration = LSP.TRegistration { _id ="globalFileWatches"+                                           , _method = LSP.SMethod_WorkspaceDidChangeWatchedFiles+                                           , _registerOptions = Just $ regOptions}           regOptions =-            DidChangeWatchedFilesRegistrationOptions { _watchers = List watchers }+            DidChangeWatchedFilesRegistrationOptions { _watchers = watchers }           -- See Note [File existence cache and LSP file watchers] for why this exists, and the choice of watch kind-          watchKind = WatchKind { _watchCreate = True, _watchChange = True, _watchDelete = True}+          -- WatchKind_Custom 7 is for create, change, and delete+          watchKind = LSP.WatchKind_Custom 7           -- See Note [Which files should we watch?] for an explanation of why the pattern is the way that it is           -- The patterns will be something like "**/.hs", i.e. "any number of directory segments,           -- followed by a file with an extension 'hs'.           watcher glob = FileSystemWatcher { _globPattern = glob, _kind = Just watchKind }           -- We use multiple watchers instead of one using '{}' because lsp-test doesn't           -- support that: https://github.com/bubba/lsp-test/issues/77-          watchers = [ watcher (Text.pack glob) | glob <- globs ]+          watchers = [ watcher (LSP.GlobPattern (LSP.InL (LSP.Pattern (Text.pack glob)))) | glob <- globs ] -        void $ LSP.sendRequest LSP.SClientRegisterCapability regParams (const $ pure ()) -- TODO handle response+        void $ LSP.sendRequest LSP.SMethod_ClientRegisterCapability regParams (const $ pure ()) -- TODO handle response         return True       else return False @@ -311,7 +312,7 @@   atomicModifyIORef' filePathMap $ \km ->     let new_key = HashMap.lookup k km     in case new_key of-          Just v -> (km, v)+          Just v  -> (km, v)           Nothing -> (HashMap.insert k k km, k) {-# NOINLINE shareFilePath  #-}- +

@@ -13,6 +13,7 @@ where  import           Control.Concurrent.Strict+import           Control.Lens                   ((^.)) import           Control.Monad import           Control.Monad.IO.Class import           Data.Aeson.Types               (Value)@@ -22,7 +23,7 @@ import           Development.IDE.Core.Shake import           Development.IDE.Graph import           Development.IDE.Types.Location-import           Language.LSP.Types+import           Language.LSP.Protocol.Types import           System.FilePath                (isRelative)  -- | Lsp client relevant configuration details@@ -49,15 +50,15 @@   IdeConfiguration {..}  where   workspaceFolders =-    foldMap (singleton . toNormalizedUri) _rootUri+    foldMap (singleton . toNormalizedUri) (nullToMaybe _rootUri)       <> (foldMap . foldMap)            (singleton . parseWorkspaceFolder)-           _workspaceFolders+           (nullToMaybe =<< _workspaceFolders)   clientSettings = hashed _initializationOptions  parseWorkspaceFolder :: WorkspaceFolder -> NormalizedUri parseWorkspaceFolder WorkspaceFolder{_uri} =-  toNormalizedUri (Uri _uri)+  toNormalizedUri _uri  modifyWorkspaceFolders   :: IdeState -> (HashSet NormalizedUri -> HashSet NormalizedUri) -> IO ()

@@ -24,6 +24,7 @@ import           Control.Monad.IO.Class import           Data.HashMap.Strict                      (HashMap) import qualified Data.HashMap.Strict                      as HashMap+import           Data.Proxy import qualified Data.Text                                as T import           Development.IDE.Graph @@ -39,14 +40,15 @@ import           Development.IDE.Plugin.Completions.Types import           Development.IDE.Types.Exports import           Development.IDE.Types.Location-import           Development.IDE.Types.Logger             (Pretty (pretty),+import           Development.IDE.Types.Options            (IdeTesting (..))+import           GHC.TypeLits                             (KnownSymbol)+import           Ide.Logger                               (Pretty (pretty),                                                            Recorder,                                                            WithPriority,                                                            cmapWithPrio,                                                            logDebug)-import           Development.IDE.Types.Options            (IdeTesting (..))+import qualified Language.LSP.Protocol.Message            as LSP import qualified Language.LSP.Server                      as LSP-import qualified Language.LSP.Types                       as LSP  data Log = LogShake Shake.Log   deriving Show@@ -130,12 +132,13 @@ kick = do     files <- HashMap.keys <$> getFilesOfInterestUntracked     ShakeExtras{exportsMap, ideTesting = IdeTesting testing, lspEnv, progress} <- getShakeExtras-    let signal msg = when testing $ liftIO $+    let signal :: KnownSymbol s => Proxy s -> Action ()+        signal msg = when testing $ liftIO $             mRunLspT lspEnv $-                LSP.sendNotification (LSP.SCustomMethod msg) $+                LSP.sendNotification (LSP.SMethod_CustomMethod msg) $                 toJSON $ map fromNormalizedFilePath files -    signal "kick/start"+    signal (Proxy @"kick/start")     liftIO $ progressUpdate progress KickStarted      -- Update the exports map@@ -155,4 +158,4 @@         void garbageCollectDirtyKeys         liftIO $ writeVar var False -    signal "kick/done"+    signal (Proxy @"kick/done")

@@ -0,0 +1,140 @@+{-# LANGUAGE GADTs #-}+module Development.IDE.Core.PluginUtils where++import           Control.Monad.Extra+import           Control.Monad.IO.Class+import           Control.Monad.Reader                 (runReaderT)+import           Control.Monad.Trans.Except+import           Control.Monad.Trans.Maybe+import           Data.Functor.Identity+import qualified Data.Text                            as T+import           Development.IDE.Core.PositionMapping+import           Development.IDE.Core.Shake           (IdeAction, IdeRule,+                                                       IdeState (shakeExtras),+                                                       mkDelayedAction,+                                                       shakeEnqueue)+import qualified Development.IDE.Core.Shake           as Shake+import           Development.IDE.GHC.Orphans          ()+import           Development.IDE.Graph                hiding (ShakeValue)+import           Development.IDE.Types.Location       (NormalizedFilePath)+import qualified Development.IDE.Types.Location       as Location+import qualified Ide.Logger                           as Logger+import           Ide.Plugin.Error+import qualified Language.LSP.Protocol.Types          as LSP++-- ----------------------------------------------------------------------------+-- Action wrappers+-- ----------------------------------------------------------------------------++-- |ExceptT version of `runAction`, takes a ExceptT Action+runActionE :: MonadIO m => String -> IdeState -> ExceptT e Action a -> ExceptT e m a+runActionE herald ide act =+  mapExceptT liftIO . ExceptT $+    join $ shakeEnqueue (shakeExtras ide) (mkDelayedAction herald Logger.Debug $ runExceptT act)++-- |MaybeT version of `runAction`, takes a MaybeT Action+runActionMT :: MonadIO m => String -> IdeState -> MaybeT Action a -> MaybeT m a+runActionMT herald ide act =+  mapMaybeT liftIO . MaybeT $+    join $ shakeEnqueue (shakeExtras ide) (mkDelayedAction herald Logger.Debug $ runMaybeT act)++-- |ExceptT version of `use` that throws a PluginRuleFailed upon failure+useE :: IdeRule k v => k -> NormalizedFilePath -> ExceptT PluginError Action v+useE k = maybeToExceptT (PluginRuleFailed (T.pack $ show k)) . useMT k++-- |MaybeT version of `use`+useMT :: IdeRule k v => k -> NormalizedFilePath -> MaybeT Action v+useMT k = MaybeT . Shake.use k++-- |ExceptT version of `uses` that throws a PluginRuleFailed upon failure+usesE :: (Traversable f, IdeRule k v) => k -> f NormalizedFilePath -> ExceptT PluginError Action (f v)+usesE k = maybeToExceptT (PluginRuleFailed (T.pack $ show k)) . usesMT k++-- |MaybeT version of `uses`+usesMT :: (Traversable f, IdeRule k v) => k -> f NormalizedFilePath -> MaybeT Action (f v)+usesMT k xs = MaybeT $ sequence <$> Shake.uses k xs++-- |ExceptT version of `useWithStale` that throws a PluginRuleFailed upon+-- failure+useWithStaleE :: IdeRule k v+    => k -> NormalizedFilePath -> ExceptT PluginError Action (v, PositionMapping)+useWithStaleE key = maybeToExceptT (PluginRuleFailed (T.pack $ show key)) . useWithStaleMT key++-- |MaybeT version of `useWithStale`+useWithStaleMT :: IdeRule k v+    => k -> NormalizedFilePath -> MaybeT Action (v, PositionMapping)+useWithStaleMT key file = MaybeT $ runIdentity <$> Shake.usesWithStale key (Identity file)++-- ----------------------------------------------------------------------------+-- IdeAction wrappers+-- ----------------------------------------------------------------------------++-- |ExceptT version of `runIdeAction`, takes a ExceptT IdeAction+runIdeActionE :: MonadIO m => String -> Shake.ShakeExtras -> ExceptT e IdeAction a -> ExceptT e m a+runIdeActionE _herald s i = ExceptT $ liftIO $ runReaderT (Shake.runIdeActionT $ runExceptT i) s++-- |MaybeT version of `runIdeAction`, takes a MaybeT IdeAction+runIdeActionMT :: MonadIO m => String -> Shake.ShakeExtras -> MaybeT IdeAction a -> MaybeT m a+runIdeActionMT _herald s i = MaybeT $ liftIO $ runReaderT (Shake.runIdeActionT $ runMaybeT i) s++-- |ExceptT version of `useWithStaleFast` that throws a PluginRuleFailed upon+-- failure+useWithStaleFastE :: IdeRule k v => k -> NormalizedFilePath -> ExceptT PluginError IdeAction (v, PositionMapping)+useWithStaleFastE k = maybeToExceptT (PluginRuleFailed (T.pack $ show k)) . useWithStaleFastMT k++-- |MaybeT version of `useWithStaleFast`+useWithStaleFastMT :: IdeRule k v => k -> NormalizedFilePath -> MaybeT IdeAction (v, PositionMapping)+useWithStaleFastMT k = MaybeT . Shake.useWithStaleFast k++-- ----------------------------------------------------------------------------+-- Location wrappers+-- ----------------------------------------------------------------------------++-- |ExceptT version of `uriToFilePath` that throws a PluginInvalidParams upon+-- failure+uriToFilePathE :: Monad m => LSP.Uri -> ExceptT PluginError m FilePath+uriToFilePathE uri = maybeToExceptT (PluginInvalidParams (T.pack $ "uriToFilePath' failed. Uri:" <>  show uri)) $ uriToFilePathMT uri++-- |MaybeT version of `uriToFilePath`+uriToFilePathMT :: Monad m => LSP.Uri -> MaybeT m FilePath+uriToFilePathMT = MaybeT . pure . Location.uriToFilePath'++-- ----------------------------------------------------------------------------+-- PositionMapping wrappers+-- ----------------------------------------------------------------------------++-- |ExceptT version of `toCurrentPosition` that throws a PluginInvalidUserState+-- upon failure+toCurrentPositionE :: Monad m => PositionMapping -> LSP.Position -> ExceptT PluginError m LSP.Position+toCurrentPositionE mapping = maybeToExceptT (PluginInvalidUserState "toCurrentPosition"). toCurrentPositionMT mapping++-- |MaybeT version of `toCurrentPosition`+toCurrentPositionMT :: Monad m => PositionMapping -> LSP.Position -> MaybeT m LSP.Position+toCurrentPositionMT mapping = MaybeT . pure . toCurrentPosition mapping++-- |ExceptT version of `fromCurrentPosition` that throws a+-- PluginInvalidUserState upon failure+fromCurrentPositionE :: Monad m => PositionMapping -> LSP.Position -> ExceptT PluginError m LSP.Position+fromCurrentPositionE mapping = maybeToExceptT (PluginInvalidUserState "fromCurrentPosition") . fromCurrentPositionMT mapping++-- |MaybeT version of `fromCurrentPosition`+fromCurrentPositionMT :: Monad m => PositionMapping -> LSP.Position -> MaybeT m LSP.Position+fromCurrentPositionMT mapping = MaybeT . pure . fromCurrentPosition mapping++-- |ExceptT version of `toCurrentRange` that throws a PluginInvalidUserState+-- upon failure+toCurrentRangeE :: Monad m => PositionMapping -> LSP.Range -> ExceptT PluginError m LSP.Range+toCurrentRangeE mapping = maybeToExceptT (PluginInvalidUserState "toCurrentRange") . toCurrentRangeMT mapping++-- |MaybeT version of `toCurrentRange`+toCurrentRangeMT :: Monad m => PositionMapping -> LSP.Range -> MaybeT m LSP.Range+toCurrentRangeMT mapping = MaybeT . pure . toCurrentRange mapping++-- |ExceptT version of `fromCurrentRange` that throws a PluginInvalidUserState+-- upon failure+fromCurrentRangeE :: Monad m => PositionMapping -> LSP.Range -> ExceptT PluginError m LSP.Range+fromCurrentRangeE mapping = maybeToExceptT (PluginInvalidUserState "fromCurrentRange") . fromCurrentRangeMT mapping++-- |MaybeT version of `fromCurrentRange`+fromCurrentRangeMT :: Monad m => PositionMapping -> LSP.Range -> MaybeT m LSP.Range+fromCurrentRangeMT mapping = MaybeT . pure . fromCurrentRange mapping

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedLabels #-} -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 module Development.IDE.Core.PositionMapping@@ -28,11 +29,13 @@ import           Data.Algorithm.Diff import           Data.Bifunctor import           Data.List-import qualified Data.Text           as T-import qualified Data.Vector.Unboxed as V-import           Language.LSP.Types  (Position (Position), Range (Range),-                                      TextDocumentContentChangeEvent (TextDocumentContentChangeEvent),-                                      UInt)+import           Data.Row+import qualified Data.Text                   as T+import qualified Data.Vector.Unboxed         as V+import           Language.LSP.Protocol.Types (Position (Position),+                                              Range (Range),+                                              TextDocumentContentChangeEvent (TextDocumentContentChangeEvent),+                                              UInt, type (|?) (InL))  -- | Either an exact position, or the range of text that was substituted data PositionResult a@@ -120,10 +123,12 @@ addDelta :: PositionDelta -> PositionMapping -> PositionMapping addDelta delta (PositionMapping pm) = PositionMapping (composeDelta delta pm) +-- TODO: We currently ignore the right hand side (if there is only text), as+-- that was what was done with lsp* 1.6 packages applyChange :: PositionDelta -> TextDocumentContentChangeEvent -> PositionDelta-applyChange PositionDelta{..} (TextDocumentContentChangeEvent (Just r) _ t) = PositionDelta-    { toDelta = toCurrent r t <=< toDelta-    , fromDelta = fromDelta <=< fromCurrent r t+applyChange PositionDelta{..} (TextDocumentContentChangeEvent (InL x)) = PositionDelta+    { toDelta = toCurrent (x .! #range) (x .! #text) <=< toDelta+    , fromDelta = fromDelta <=< fromCurrent (x .! #range) (x .! #text)     } applyChange posMapping _ = posMapping 

@@ -8,9 +8,9 @@  import           Development.IDE.GHC.Compat import qualified Development.IDE.GHC.Compat.Util   as Util-import qualified Development.IDE.GHC.Util          as Util import           Development.IDE.GHC.CPP import           Development.IDE.GHC.Orphans       ()+import qualified Development.IDE.GHC.Util          as Util  import           Control.DeepSeq                   (NFData (rnf)) import           Control.Exception                 (evaluate)@@ -133,7 +133,9 @@           _source = Just "CPP",           _message = T.unlines $ cdMessage d,           _relatedInformation = Nothing,-          _tags = Nothing+          _tags = Nothing,+          _codeDescription = Nothing,+          _data_ = Nothing         }  

@@ -21,6 +21,7 @@ import           Control.Monad.Extra import           Control.Monad.IO.Class import           Control.Monad.Trans.Class      (lift)+import           Data.Aeson                     (ToJSON (toJSON)) import           Data.Foldable                  (for_) import           Data.Functor                   (($>)) import qualified Data.Text                      as T@@ -30,9 +31,10 @@ import           Development.IDE.Types.Location import           Development.IDE.Types.Options import qualified Focus+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types+import qualified Language.LSP.Protocol.Types    as LSP import qualified Language.LSP.Server            as LSP-import           Language.LSP.Types-import qualified Language.LSP.Types             as LSP import qualified StmContainers.Map              as STM import           System.Time.Extra import           UnliftIO.Exception             (bracket_)@@ -125,30 +127,32 @@             -- 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+            u <- ProgressToken . InR . T.pack . show . hashUnique <$> liftIO newUnique              b <- liftIO newBarrier-            void $ LSP.runLspT lspEnv $ LSP.sendRequest LSP.SWindowWorkDoneProgressCreate+            void $ LSP.runLspT lspEnv $ LSP.sendRequest SMethod_WindowWorkDoneProgressCreate                 LSP.WorkDoneProgressCreateParams { _token = u } $ liftIO . signalBarrier b             liftIO $ async $ do                 ready <- waitBarrier b                 LSP.runLspT lspEnv $ for_ ready $ const $ bracket_ (start u) (stop u) (loop u 0)             where-                start id = LSP.sendNotification LSP.SProgress $+                start id = LSP.sendNotification SMethod_Progress $                     LSP.ProgressParams                         { _token = id-                        , _value = LSP.Begin $ WorkDoneProgressBeginParams-                          { _title = "Processing"+                        , _value = toJSON $ WorkDoneProgressBegin+                          { _kind = AString @"begin"+                          ,  _title = "Processing"                           , _cancellable = Nothing                           , _message = Nothing                           , _percentage = Nothing                           }                         }-                stop id = LSP.sendNotification LSP.SProgress+                stop id = LSP.sendNotification SMethod_Progress                     LSP.ProgressParams                         { _token = id-                        , _value = LSP.End WorkDoneProgressEndParams-                          { _message = Nothing+                        , _value = toJSON $ WorkDoneProgressEnd+                          { _kind = AString @"end"+                           , _message = Nothing                           }                         }                 loop _ _ | optProgressStyle == NoProgress =@@ -164,17 +168,19 @@                             nextPct :: UInt                             nextPct = floor $ 100 * nextFrac                         when (nextPct /= prevPct) $-                          LSP.sendNotification LSP.SProgress $+                          LSP.sendNotification SMethod_Progress $                           LSP.ProgressParams                               { _token = id-                              , _value = LSP.Report $ case optProgressStyle of-                                  Explicit -> LSP.WorkDoneProgressReportParams-                                    { _cancellable = Nothing+                              , _value = case optProgressStyle of+                                  Explicit -> toJSON $ WorkDoneProgressReport+                                    { _kind = AString @"report"+                                    , _cancellable = Nothing                                     , _message = Just $ T.pack $ show done <> "/" <> show todo                                     , _percentage = Nothing                                     }-                                  Percentage -> LSP.WorkDoneProgressReportParams-                                    { _cancellable = Nothing+                                  Percentage -> toJSON $ WorkDoneProgressReport+                                    { _kind = AString @"report"+                                    , _cancellable = Nothing                                     , _message = Nothing                                     , _percentage = Just nextPct                                     }

@@ -42,7 +42,7 @@ import           Development.IDE.Spans.LocalBindings import           Development.IDE.Types.Diagnostics import           GHC.Serialized                               (Serialized)-import           Language.LSP.Types                           (Int32,+import           Language.LSP.Protocol.Types                  (Int32,                                                                NormalizedFilePath)  data LinkableType = ObjectLinkable | BCOLinkable@@ -69,11 +69,6 @@ -- all comments included using Opt_KeepRawTokenStream type instance RuleResult GetParsedModuleWithComments = ParsedModule --- | The dependency information produced by following the imports recursively.--- This rule will succeed even if there is an error, e.g., a module could not be located,--- a module could not be parsed or an import cycle.-type instance RuleResult GetDependencyInformation = DependencyInformation- type instance RuleResult GetModuleGraph = DependencyInformation  data GetKnownTargets = GetKnownTargets@@ -262,8 +257,8 @@ -- | Resolve the imports in a module to the file path of a module in the same package type instance RuleResult GetLocatedImports = [(Located ModuleName, Maybe ArtifactsLocation)] --- | This rule is used to report import cycles. It depends on GetDependencyInformation.--- We cannot report the cycles directly from GetDependencyInformation since+-- | This rule is used to report import cycles. It depends on GetModuleGraph.+-- We cannot report the cycles directly from GetModuleGraph since -- we can only report diagnostics for the current file. type instance RuleResult ReportImportCycles = () @@ -400,11 +395,6 @@     deriving (Eq, Show, Typeable, Generic) instance Hashable NeedsCompilation instance NFData   NeedsCompilation--data GetDependencyInformation = GetDependencyInformation-    deriving (Eq, Show, Typeable, Generic)-instance Hashable GetDependencyInformation-instance NFData   GetDependencyInformation  data GetModuleGraph = GetModuleGraph     deriving (Eq, Show, Typeable, Generic)

@@ -23,7 +23,6 @@     defineEarlyCutOffNoFile,     mainRule,     RulesConfig(..),-    getDependencies,     getParsedModule,     getParsedModuleWithComments,     getClientConfigAction,@@ -34,7 +33,6 @@     getParsedModuleRule,     getParsedModuleWithCommentsRule,     getLocatedImportsRule,-    getDependencyInformationRule,     reportImportCyclesRule,     typeCheckRule,     getDocMapRule,@@ -68,6 +66,7 @@ import           Control.Concurrent.Strict import           Control.DeepSeq import           Control.Exception.Safe+import           Control.Exception                            (evaluate) import           Control.Monad.Extra import           Control.Monad.Reader import           Control.Monad.State@@ -90,8 +89,10 @@ import           Data.IntMap.Strict                           (IntMap) import qualified Data.IntMap.Strict                           as IntMap import           Data.List+import           Data.List.Extra                              (nubOrdOn) import qualified Data.Map                                     as M import           Data.Maybe+import           Data.Proxy import qualified Data.Text.Utf16.Rope                         as Rope import qualified Data.Set                                     as Set import qualified Data.Text                                    as T@@ -135,7 +136,8 @@ import qualified HieDb import           Ide.Plugin.Config import qualified Language.LSP.Server                          as LSP-import           Language.LSP.Types                           (SMethod (SCustomMethod, SWindowShowMessage), ShowMessageParams (ShowMessageParams), MessageType (MtInfo))+import           Language.LSP.Protocol.Types                  (ShowMessageParams (ShowMessageParams), MessageType (MessageType_Info))+import           Language.LSP.Protocol.Message                (SMethod (SMethod_CustomMethod, SMethod_WindowShowMessage)) import           Language.LSP.VFS import           System.Directory                             (makeAbsolute, doesFileExist) import           Data.Default                                 (def, Default)@@ -151,13 +153,14 @@ import Language.LSP.Server (LspT) import System.Info.Extra (isWindows) import HIE.Bios.Ghc.Gap (hostIsDynamic)-import Development.IDE.Types.Logger (Recorder, logWith, cmapWithPrio, WithPriority, Pretty (pretty), (<+>), nest, vcat)+import Ide.Logger (Recorder, logWith, cmapWithPrio, WithPriority, Pretty (pretty), (<+>), nest, vcat) import qualified Development.IDE.Core.Shake as Shake-import qualified Development.IDE.Types.Logger as Logger+import qualified Ide.Logger as Logger import qualified Development.IDE.Types.Shake as Shake import           Development.IDE.GHC.CoreFile import           Data.Time.Clock.POSIX             (posixSecondsToUTCTime) import Control.Monad.IO.Unlift+import qualified Data.IntMap as IM #if MIN_VERSION_ghc(9,3,0) import GHC.Unit.Module.Graph import GHC.Unit.Env@@ -165,6 +168,8 @@ #if MIN_VERSION_ghc(9,5,0) import GHC.Unit.Home.ModInfo #endif+import GHC (mgModSummaries)+import GHC.Fingerprint  data Log   = LogShake Shake.Log@@ -210,12 +215,6 @@ ------------------------------------------------------------ -- Exposed API --------------------------------------------------------------- | Get all transitive file dependencies of a given module.--- Does not include the file itself.-getDependencies :: NormalizedFilePath -> Action (Maybe [NormalizedFilePath])-getDependencies file =-    fmap transitiveModuleDeps . (`transitiveDeps` file) <$> use_ GetDependencyInformation file- getSourceFileSource :: NormalizedFilePath -> Action BS.ByteString getSourceFileSource nfp = do     (_, msource) <- getFileContents nfp@@ -314,7 +313,7 @@ --   Ignore Haddock errors that are in both. Demote Haddock-only errors to warnings. mergeParseErrorsHaddock :: [FileDiagnostic] -> [FileDiagnostic] -> [FileDiagnostic] mergeParseErrorsHaddock normal haddock = normal ++-    [ (a,b,c{_severity = Just DsWarning, _message = fixMessage $ _message c})+    [ (a,b,c{_severity = Just DiagnosticSeverity_Warning, _message = fixMessage $ _message c})     | (a,b,c) <- haddock, Diag._range c `Set.notMember` locations]   where     locations = Set.fromList $ map (Diag._range . thd3) normal@@ -420,17 +419,17 @@ execRawDepM :: Monad m => StateT (RawDependencyInformation, IntMap a1) m a2 -> m (RawDependencyInformation, IntMap a1) execRawDepM act =     execStateT act-        ( RawDependencyInformation IntMap.empty emptyPathIdMap IntMap.empty IntMap.empty+        ( RawDependencyInformation IntMap.empty emptyPathIdMap IntMap.empty         , IntMap.empty         )  -- | Given a target file path, construct the raw dependency results by following -- imports recursively.-rawDependencyInformation :: [NormalizedFilePath] -> Action RawDependencyInformation+rawDependencyInformation :: [NormalizedFilePath] -> Action (RawDependencyInformation, BootIdMap) rawDependencyInformation fs = do     (rdi, ss) <- execRawDepM (goPlural fs)     let bm = IntMap.foldrWithKey (updateBootMap rdi) IntMap.empty ss-    return (rdi { rawBootMap = bm })+    return (rdi, bm)   where     goPlural ff = do         mss <- lift $ (fmap.fmap) msrModSummary <$> uses GetModSummaryWithoutTimestamps ff@@ -449,9 +448,9 @@           fId <- getFreshFid al           -- Record this module and its location           whenJust msum $ \ms ->-            modifyRawDepInfo (\rd -> rd { rawModuleNameMap = IntMap.insert (getFilePathId fId)-                                                                           (ShowableModuleName (moduleName $ ms_mod ms))-                                                                           (rawModuleNameMap rd)})+            modifyRawDepInfo (\rd -> rd { rawModuleMap = IntMap.insert (getFilePathId fId)+                                                                           (ShowableModule $ ms_mod ms)+                                                                           (rawModuleMap rd)})           -- Adding an edge to the bootmap so we can make sure to           -- insert boot nodes before the real files.           addBootMap al fId@@ -523,38 +522,37 @@     dropBootSuffix :: FilePath -> FilePath     dropBootSuffix hs_src = reverse . drop (length @[] "-boot") . reverse $ hs_src -getDependencyInformationRule :: Recorder (WithPriority Log) -> Rules ()-getDependencyInformationRule recorder =-    define (cmapWithPrio LogShake recorder) $ \GetDependencyInformation file -> do-       rawDepInfo <- rawDependencyInformation [file]-       pure ([], Just $ processDependencyInformation rawDepInfo)- reportImportCyclesRule :: Recorder (WithPriority Log) -> Rules () reportImportCyclesRule recorder =-    define (cmapWithPrio LogShake recorder) $ \ReportImportCycles file -> fmap (\errs -> if null errs then ([], Just ()) else (errs, Nothing)) $ do-        DependencyInformation{..} <- use_ GetDependencyInformation file-        let fileId = pathToId depPathIdMap file-        case IntMap.lookup (getFilePathId fileId) depErrorNodes of-            Nothing -> pure []-            Just errs -> do-                let cycles = mapMaybe (cycleErrorInFile fileId) (toList errs)-                -- Convert cycles of files into cycles of module names-                forM cycles $ \(imp, files) -> do-                    modNames <- forM files $ \fileId -> do-                        let file = idToPath depPathIdMap fileId-                        getModuleName file-                    pure $ toDiag imp $ sort modNames+    defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \ReportImportCycles file -> fmap (\errs -> if null errs then (Just "1",([], Just ())) else (Nothing, (errs, Nothing))) $ do+        DependencyInformation{..} <- useNoFile_ GetModuleGraph+        case pathToId depPathIdMap file of+          -- The header of the file does not parse, so it can't be part of any import cycles.+          Nothing -> pure []+          Just fileId ->+            case IntMap.lookup (getFilePathId fileId) depErrorNodes of+              Nothing -> pure []+              Just errs -> do+                  let cycles = mapMaybe (cycleErrorInFile fileId) (toList errs)+                  -- Convert cycles of files into cycles of module names+                  forM cycles $ \(imp, files) -> do+                      modNames <- forM files $ \fileId -> do+                          let file = idToPath depPathIdMap fileId+                          getModuleName file+                      pure $ toDiag imp $ sort modNames     where cycleErrorInFile f (PartOfCycle imp fs)             | f `elem` fs = Just (imp, fs)           cycleErrorInFile _ _ = Nothing           toDiag imp mods = (fp , ShowDiag , ) $ Diagnostic             { _range = rng-            , _severity = Just DsError+            , _severity = Just DiagnosticSeverity_Error             , _source = Just "Import cycle detection"             , _message = "Cyclic module dependency between " <> showCycle mods             , _code = Nothing             , _relatedInformation = Nothing             , _tags = Nothing+            , _codeDescription = Nothing+            , _data_ = Nothing             }             where rng = fromMaybe noRange $ srcSpanToRange (getLoc imp)                   fp = toNormalizedFilePath' $ fromMaybe noFilePath $ srcSpanToFilename (getLoc imp)@@ -591,7 +589,7 @@   diagsWrite <- case isFoi of     IsFOI Modified{firstOpen = False} -> do       when (coerce $ ideTesting se) $ liftIO $ mRunLspT (lspEnv se) $-        LSP.sendNotification (SCustomMethod "ghcide/reference/ready") $+        LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/reference/ready")) $           toJSON $ fromNormalizedFilePath f       pure []     _ | Just asts <- masts -> do@@ -677,11 +675,38 @@   pure (LBS.toStrict $ B.encode $ hash fs, unhashed fs)  getModuleGraphRule :: Recorder (WithPriority Log) -> Rules ()-getModuleGraphRule recorder = defineNoFile (cmapWithPrio LogShake recorder) $ \GetModuleGraph -> do+getModuleGraphRule recorder = defineEarlyCutOffNoFile (cmapWithPrio LogShake recorder) $ \GetModuleGraph -> do   fs <- toKnownFiles <$> useNoFile_ GetKnownTargets-  rawDepInfo <- rawDependencyInformation (HashSet.toList fs)-  pure $ processDependencyInformation rawDepInfo+  dependencyInfoForFiles (HashSet.toList fs) +dependencyInfoForFiles :: [NormalizedFilePath] -> Action (BS.ByteString, DependencyInformation)+dependencyInfoForFiles fs = do+  (rawDepInfo, bm) <- rawDependencyInformation fs+  let (all_fs, _all_ids) = unzip $ HM.toList $ pathToIdMap $ rawPathIdMap rawDepInfo+  msrs <- uses GetModSummaryWithoutTimestamps all_fs+  let mss = map (fmap msrModSummary) msrs+#if MIN_VERSION_ghc(9,3,0)+  let deps = map (\i -> IM.lookup (getFilePathId i) (rawImports rawDepInfo)) _all_ids+      nodeKeys = IM.fromList $ catMaybes $ zipWith (\fi mms -> (getFilePathId fi,) . NodeKey_Module . msKey <$> mms) _all_ids mss+      mns = catMaybes $ zipWith go mss deps+      go (Just ms) (Just (Right (ModuleImports xs))) = Just $ ModuleNode this_dep_keys ms+        where this_dep_ids = mapMaybe snd xs+              this_dep_keys = mapMaybe (\fi -> IM.lookup (getFilePathId fi) nodeKeys) this_dep_ids+      go (Just ms) _ = Just $ ModuleNode [] ms+      go _ _ = Nothing+      mg = mkModuleGraph mns+#else+  let mg = mkModuleGraph $+#if MIN_VERSION_ghc(9,2,0)+        -- We don't do any instantiation for backpack at this point of time, so it is OK to use+        -- 'extendModSummaryNoDeps'.+        -- This may have to change in the future.+          map extendModSummaryNoDeps $+#endif+          (catMaybes mss)+#endif+  pure (fingerprintToBS $ Util.fingerprintFingerprints $ map (maybe fingerprint0 msrFingerprint) msrs, processDependencyInformation rawDepInfo bm mg)+ -- This is factored out so it can be directly called from the GetModIface -- rule. Directly calling this rule means that on the initial load we can -- garbage collect all the intermediate typechecked modules rather than@@ -750,11 +775,11 @@         ghcSessionDepsDefinition fullModSummary ghcSessionDepsConfig env file  newtype GhcSessionDepsConfig = GhcSessionDepsConfig-    { checkForImportCycles :: Bool+    { fullModuleGraph :: Bool     } instance Default GhcSessionDepsConfig where   def = GhcSessionDepsConfig-    { checkForImportCycles = True+    { fullModuleGraph = True     }  -- | Note [GhcSessionDeps]@@ -773,7 +798,7 @@     case mbdeps of         Nothing -> return Nothing         Just deps -> do-            when checkForImportCycles $ void $ uses_ ReportImportCycles deps+            when fullModuleGraph $ void $ use_ ReportImportCycles file             ms <- msrModSummary <$> if fullModSummary                 then use_ GetModSummary file                 else use_ GetModSummaryWithoutTimestamps file@@ -781,21 +806,40 @@             depSessions <- map hscEnv <$> uses_ (GhcSessionDeps_ fullModSummary) deps             ifaces <- uses_ GetModIface deps             let inLoadOrder = map (\HiFileResult{..} -> HomeModInfo hirModIface hirModDetails emptyHomeModInfoLinkable) ifaces+            mg <- do+              if fullModuleGraph+              then depModuleGraph <$> useNoFile_ GetModuleGraph+              else do+                let mgs = map hsc_mod_graph depSessions #if MIN_VERSION_ghc(9,3,0)-            -- On GHC 9.4+, the module graph contains not only ModSummary's but each `ModuleNode` in the graph-            -- also points to all the direct descendants of the current module. To get the keys for the descendants-            -- we must get their `ModSummary`s-            !final_deps <- do-              dep_mss <- map msrModSummary <$> uses_ GetModSummaryWithoutTimestamps deps-             -- Don't want to retain references to the entire ModSummary when just the key will do-              return $!! map (NodeKey_Module . msKey) dep_mss-            let moduleNode = (ms, final_deps)+                -- On GHC 9.4+, the module graph contains not only ModSummary's but each `ModuleNode` in the graph+                -- also points to all the direct descendants of the current module. To get the keys for the descendants+                -- we must get their `ModSummary`s+                !final_deps <- do+                  dep_mss <- map msrModSummary <$> uses_ GetModSummaryWithoutTimestamps deps+                  return $!! map (NodeKey_Module . msKey) dep_mss+                let module_graph_nodes =+                      nubOrdOn mkNodeKey (ModuleNode final_deps ms : concatMap mgModSummaries' mgs) #else-            let moduleNode = ms+                let module_graph_nodes =+#if MIN_VERSION_ghc(9,2,0)+                      -- We don't do any instantiation for backpack at this point of time, so it is OK to use+                      -- 'extendModSummaryNoDeps'.+                      -- This may have to change in the future.+                      map extendModSummaryNoDeps $ #endif-            session' <- liftIO $ mergeEnvs hsc moduleNode inLoadOrder depSessions+                      nubOrdOn ms_mod (ms : concatMap mgModSummaries mgs)+#endif+                liftIO $ evaluate $ liftRnf rwhnf module_graph_nodes+                return $ mkModuleGraph module_graph_nodes+            session' <- liftIO $ mergeEnvs hsc mg ms inLoadOrder depSessions -            Just <$> liftIO (newHscEnvEqWithImportPaths (envImportPaths env) session' [])+            -- Here we avoid a call to to `newHscEnvEqWithImportPaths`, which creates a new+            -- ExportsMap when it is called. We only need to create the ExportsMap once per+            -- session, while `ghcSessionDepsDefinition` will be called for each file we need+            -- to compile. `updateHscEnvEq` will refresh the HscEnv (session') and also+            -- generate a new Unique.+            Just <$> liftIO (updateHscEnvEq env session')  -- | Load a iface from disk, or generate it if there isn't one or it is out of date -- This rule also ensures that the `.hie` and `.o` (if needed) files are written out.@@ -855,7 +899,7 @@       -> do       -- All good, the db has indexed the file       when (coerce $ ideTesting se) $ liftIO $ mRunLspT (lspEnv se) $-        LSP.sendNotification (SCustomMethod "ghcide/reference/ready") $+        LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/reference/ready")) $           toJSON $ fromNormalizedFilePath f     -- Not in db, must re-index     _ -> do@@ -1192,8 +1236,16 @@ instance IsIdeGlobal CompiledLinkables  data RulesConfig = RulesConfig-    { -- | Disable import cycle checking for improved performance in large codebases-      checkForImportCycles :: Bool+    { -- | Share the computation for the entire module graph+      -- We usually compute the full module graph for the project+      -- and share it for all files.+      -- However, in large projects it might not be desirable to wait+      -- for computing the entire module graph before starting to+      -- typecheck a particular file.+      -- Disabling this drastically decreases sharing and is likely to+      -- increase memory usage if you have multiple files open+      -- Disabling this also disables checking for import cycles+      fullModuleGraph :: Bool     -- | Disable TH for improved performance in large codebases     , enableTemplateHaskell :: Bool     -- | Warning to show when TH is not supported by the current HLS binary@@ -1206,8 +1258,8 @@         displayTHWarning :: LspT c IO ()         displayTHWarning             | not isWindows && not hostIsDynamic = do-                LSP.sendNotification SWindowShowMessage $-                    ShowMessageParams MtInfo thWarningMessage+                LSP.sendNotification SMethod_WindowShowMessage $+                    ShowMessageParams MessageType_Info thWarningMessage             | otherwise = return ()  thWarningMessage :: T.Text@@ -1227,11 +1279,10 @@     getParsedModuleRule recorder     getParsedModuleWithCommentsRule recorder     getLocatedImportsRule recorder-    getDependencyInformationRule recorder     reportImportCyclesRule recorder     typeCheckRule recorder     getDocMapRule recorder-    loadGhcSession recorder def{checkForImportCycles}+    loadGhcSession recorder def{fullModuleGraph}     getModIfaceFromDiskRule recorder     getModIfaceFromDiskAndIndexRule recorder     getModIfaceRule recorder

@@ -23,16 +23,16 @@ import           Development.IDE.Core.FileExists  (fileExistsRules) import           Development.IDE.Core.OfInterest  hiding (Log, LogShake) import           Development.IDE.Graph-import           Development.IDE.Types.Logger     as Logger (Logger,+import           Development.IDE.Types.Options    (IdeOptions (..))+import           Ide.Logger                       as Logger (Logger,                                                              Pretty (pretty),                                                              Priority (Debug),                                                              Recorder,                                                              WithPriority,                                                              cmapWithPrio)-import           Development.IDE.Types.Options    (IdeOptions (..)) import           Ide.Plugin.Config+import qualified Language.LSP.Protocol.Types      as LSP import qualified Language.LSP.Server              as LSP-import qualified Language.LSP.Types               as LSP  import           Control.Monad import qualified Development.IDE.Core.FileExists  as FileExists

@@ -77,7 +77,7 @@     garbageCollectDirtyKeys,     garbageCollectDirtyKeysOlderThan,     Log(..),-    VFSModified(..), getClientConfigAction+    VFSModified(..), getClientConfigAction,     ) where  import           Control.Concurrent.Async@@ -152,8 +152,6 @@ import qualified Development.IDE.Types.Exports          as ExportsMap 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.Monitoring       (Monitoring (..)) import           Development.IDE.Types.Options import           Development.IDE.Types.Shake@@ -161,16 +159,18 @@ import           GHC.Fingerprint import           GHC.Stack                              (HasCallStack) import           HieDb.Types+import           Ide.Logger                             hiding (Priority)+import qualified Ide.Logger                             as Logger import           Ide.Plugin.Config import qualified Ide.PluginUtils                        as HLS import           Ide.Types                              (IdePlugins (IdePlugins),                                                          PluginDescriptor (pluginId),                                                          PluginId) import           Language.LSP.Diagnostics+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types+import qualified Language.LSP.Protocol.Types            as LSP import qualified Language.LSP.Server                    as LSP-import           Language.LSP.Types-import qualified Language.LSP.Types                     as LSP-import           Language.LSP.Types.Capabilities import           Language.LSP.VFS                       hiding (start) import qualified "list-t" ListT import           OpenTelemetry.Eventlog@@ -303,7 +303,7 @@ type WithIndefiniteProgressFunc = forall a.     T.Text -> LSP.ProgressCancellable -> IO a -> IO a -type GetStalePersistent = NormalizedFilePath -> IdeAction (Maybe (Dynamic,PositionDelta,TextDocumentVersion))+type GetStalePersistent = NormalizedFilePath -> IdeAction (Maybe (Dynamic,PositionDelta,Maybe Int32))  getShakeExtras :: Action ShakeExtras getShakeExtras = do@@ -344,7 +344,7 @@ -- This is called when we don't already have a result, or computing the rule failed. -- The result of this function will always be marked as 'stale', and a 'proper' rebuild of the rule will -- be queued if the rule hasn't run before.-addPersistentRule :: IdeRule k v => k -> (NormalizedFilePath -> IdeAction (Maybe (v,PositionDelta,TextDocumentVersion))) -> Rules ()+addPersistentRule :: IdeRule k v => k -> (NormalizedFilePath -> IdeAction (Maybe (v,PositionDelta,Maybe Int32))) -> Rules () addPersistentRule k getVal = do   ShakeExtras{persistentKeys} <- getShakeExtrasRules   void $ liftIO $ atomically $ modifyTVar' persistentKeys $ insertKeyMap (newKey k) (fmap (fmap (first3 toDyn)) . getVal)@@ -639,7 +639,6 @@         actionQueue <- newQueue          let clientCapabilities = maybe def LSP.resClientCapabilities lspEnv-         dirtyKeys <- newTVarIO mempty         -- Take one VFS snapshot at the start         vfsVar <- newTVarIO =<< vfsSnapshot lspEnv@@ -900,7 +899,7 @@         logDebug logger $ T.pack $             label <> " of " <> show n <> " keys (took " <> showDuration t <> ")"     when (coerce ideTesting) $ liftIO $ mRunLspT lspEnv $-        LSP.sendNotification (SCustomMethod "ghcide/GC")+        LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/GC"))                              (toJSON $ mapMaybe (fmap showKey . fromKeyType) garbage)     return garbage @@ -962,13 +961,23 @@     => k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping)) useWithStale key file = runIdentity <$> usesWithStale key (Identity file) --- | Request a Rule result, it not available return the last computed result which may be stale.---   Errors out if none available.+-- |Request a Rule result, it not available return the last computed result+--  which may be stale.+--+-- Throws an `BadDependency` exception which is caught by the rule system if+-- none available.+--+-- WARNING: Not suitable for PluginHandlers. Use `useWithStaleE` instead. useWithStale_ :: IdeRule k v     => k -> NormalizedFilePath -> Action (v, PositionMapping) useWithStale_ key file = runIdentity <$> usesWithStale_ key (Identity file) --- | Plural version of 'useWithStale_'+-- |Plural version of 'useWithStale_'+--+-- Throws an `BadDependency` exception which is caught by the rule system if+-- none available.+--+-- WARNING: Not suitable for PluginHandlers. usesWithStale_ :: (Traversable f, IdeRule k v) => k -> f NormalizedFilePath -> Action (f (v, PositionMapping)) usesWithStale_ key files = do     res <- usesWithStale key files@@ -1042,12 +1051,24 @@ useNoFile :: IdeRule k v => k -> Action (Maybe v) useNoFile key = use key emptyFilePath +-- Requests a rule if available.+--+-- Throws an `BadDependency` exception which is caught by the rule system if+-- none available.+--+-- WARNING: Not suitable for PluginHandlers. Use `useE` instead. use_ :: IdeRule k v => k -> NormalizedFilePath -> Action v use_ key file = runIdentity <$> uses_ key (Identity file)  useNoFile_ :: IdeRule k v => k -> Action v useNoFile_ key = use_ key emptyFilePath +-- |Plural version of `use_`+--+-- Throws an `BadDependency` exception which is caught by the rule system if+-- none available.+--+-- WARNING: Not suitable for PluginHandlers. Use `usesE` instead. uses_ :: (Traversable f, IdeRule k v) => k -> f NormalizedFilePath -> Action (f v) uses_ key files = do     res <- uses key files@@ -1128,7 +1149,7 @@  defineEarlyCutoff'     :: forall k v. IdeRule k v-    => (TextDocumentVersion -> [FileDiagnostic] -> Action ()) -- ^ update diagnostics+    => (Maybe Int32 -> [FileDiagnostic] -> Action ()) -- ^ update diagnostics     -- | compare current and previous for freshness     -> (BS.ByteString -> BS.ByteString -> Bool)     -> k@@ -1220,7 +1241,7 @@ updateFileDiagnostics :: MonadIO m   => Recorder (WithPriority Log)   -> NormalizedFilePath-  -> TextDocumentVersion+  -> Maybe Int32   -> Key   -> ShakeExtras   -> [(ShowDiagnostic,Diagnostic)] -- ^ current results@@ -1254,15 +1275,15 @@                         Just env -> LSP.runLspT env $ do                             liftIO $ tag "count" (show $ Prelude.length newDiags)                             liftIO $ tag "key" (show k)-                            LSP.sendNotification LSP.STextDocumentPublishDiagnostics $-                                LSP.PublishDiagnosticsParams (fromNormalizedUri uri) (fmap fromIntegral ver) (List newDiags)+                            LSP.sendNotification SMethod_TextDocumentPublishDiagnostics $+                                LSP.PublishDiagnosticsParams (fromNormalizedUri uri) (fmap fromIntegral ver) ( newDiags)                  return action     where         diagsFromRule :: Diagnostic -> Diagnostic         diagsFromRule c@Diagnostic{_range}             | coerce ideTesting = c                 {_relatedInformation =-                    Just $ List [+                    Just $  [                         DiagnosticRelatedInformation                             (Location                                 (filePathToUri $ fromNormalizedFilePath fp)@@ -1297,7 +1318,7 @@   (forall a. String -> String -> a -> a) ->   STMDiagnosticStore ->   NormalizedUri ->-  TextDocumentVersion ->+  Maybe Int32 ->   DiagnosticsBySource ->   STM [LSP.Diagnostic] updateSTMDiagnostics addTag store uri mv newDiagsBySource =@@ -1314,7 +1335,7 @@ setStageDiagnostics     :: (forall a. String -> String -> a -> a)     -> NormalizedUri-    -> TextDocumentVersion -- ^ the time that the file these diagnostics originate from was last edited+    -> Maybe Int32 -- ^ the time that the file these diagnostics originate from was last edited     -> T.Text     -> [LSP.Diagnostic]     -> STMDiagnosticStore@@ -1329,8 +1350,8 @@ getAllDiagnostics =     fmap (concatMap (\(k,v) -> map (fromUri k,ShowDiag,) $ getDiagnosticsFromStore v)) . ListT.toList . STM.listT -updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> STM ()-updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} (List changes) =+updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> STM ()+updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} changes =     STM.focus (Focus.alter f) uri positionMapping       where         uri = toNormalizedUri _uri@@ -1341,8 +1362,5 @@                 -- used which is evident in long running sessions.                 EM.mapAccumRWithKey (\acc _k (delta, _) -> let new = addDelta delta acc in (new, (delta, acc)))                   zeroMapping-                  (EM.insert actual_version (shared_change, zeroMapping) mappingForUri)+                  (EM.insert _version (shared_change, zeroMapping) mappingForUri)         shared_change = mkDelta changes-        actual_version = case _version of-          Nothing -> error "Nothing version from server" -- This is a violation of the spec-          Just v  -> v

@@ -2,6 +2,7 @@ {-# LANGUAGE PackageImports  #-} {-# LANGUAGE PatternSynonyms #-} {-# HLINT ignore #-}+ module Development.IDE.Core.Tracing     ( otTracedHandler     , otTracedAction@@ -29,9 +30,9 @@ import           Development.IDE.Types.Diagnostics (FileDiagnostic,                                                     showDiagnostics) import           Development.IDE.Types.Location    (Uri (..))-import           Development.IDE.Types.Logger      (Logger (Logger))+import           Ide.Logger                        (Logger (Logger)) import           Ide.Types                         (PluginId (..))-import           Language.LSP.Types                (NormalizedFilePath,+import           Language.LSP.Protocol.Types       (NormalizedFilePath,                                                     fromNormalizedFilePath) import           OpenTelemetry.Eventlog            (SpanInFlight (..), addEvent,                                                     beginSpan, endSpan, setTag,

@@ -39,6 +39,7 @@     lookupType,     needWiredInHomeIface,     loadWiredInHomeIface,+    readIface,     loadSysInterface,     importDecl, #if MIN_VERSION_ghc(8,8,0)

@@ -50,50 +50,54 @@     filterInplaceUnits,     FinderCache,     showSDocForUser',+    findImportedModule,     ) where  import           Control.Monad-import qualified Data.List.NonEmpty              as NE-import qualified Data.Map.Strict                 as Map+import qualified Data.List.NonEmpty                    as NE+import qualified Data.Map.Strict                       as Map #if MIN_VERSION_ghc(9,3,0) import           GHC.Unit.Home.ModInfo #endif #if MIN_VERSION_ghc(9,0,0) #if MIN_VERSION_ghc(9,2,0)-import qualified GHC.Data.ShortText              as ST+import qualified GHC.Data.ShortText                    as ST #if !MIN_VERSION_ghc(9,3,0)-import           GHC.Driver.Env                  (hsc_unit_dbs)+import           GHC.Driver.Env                        (hsc_unit_dbs) #endif import           GHC.Driver.Ppr import           GHC.Unit.Env import           GHC.Unit.External-import           GHC.Unit.Finder+import           GHC.Unit.Finder                       hiding+                                                       (findImportedModule) #else import           GHC.Driver.Types #endif import           GHC.Data.FastString-import qualified GHC.Driver.Session              as DynFlags+import qualified GHC.Driver.Session                    as DynFlags import           GHC.Types.Unique.Set-import qualified GHC.Unit.Info                   as UnitInfo-import           GHC.Unit.State                  (LookupResult, UnitInfo,-                                                  UnitState (unitInfoMap))-import qualified GHC.Unit.State                  as State-import           GHC.Unit.Types                  hiding (moduleUnit, toUnitId)-import qualified GHC.Unit.Types                  as Unit+import qualified GHC.Unit.Info                         as UnitInfo+import           GHC.Unit.State                        (LookupResult, UnitInfo,+                                                        UnitState (unitInfoMap))+import qualified GHC.Unit.State                        as State+import           GHC.Unit.Types                        hiding (moduleUnit,+                                                        toUnitId)+import qualified GHC.Unit.Types                        as Unit import           GHC.Utils.Outputable #else import qualified DynFlags import           FastString-import           GhcPlugins                      (SDoc, showSDocForUser)+import           GhcPlugins                            (SDoc, showSDocForUser) import           HscTypes-import           Module                          hiding (moduleUnitId)+import           Module                                hiding (moduleUnitId) import qualified Module-import           Packages                        (InstalledPackageInfo (haddockInterfaces, packageName),-                                                  LookupResult, PackageConfig,-                                                  PackageConfigMap,-                                                  PackageState,-                                                  getPackageConfigMap,-                                                  lookupPackage')+import           Packages                              (InstalledPackageInfo (haddockInterfaces, packageName),+                                                        LookupResult,+                                                        PackageConfig,+                                                        PackageConfigMap,+                                                        PackageState,+                                                        getPackageConfigMap,+                                                        lookupPackage') import qualified Packages #endif @@ -101,12 +105,23 @@ import           Development.IDE.GHC.Compat.Env import           Development.IDE.GHC.Compat.Outputable #if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0)-import           Data.Map                        (Map)+import           Data.Map                              (Map) #endif import           Data.Either import           Data.Version import qualified GHC +#if MIN_VERSION_ghc(9,3,0)+import           GHC.Types.PkgQual                     (PkgQual (NoPkgQual))+#endif+#if MIN_VERSION_ghc(9,1,0)+import qualified GHC.Unit.Finder                       as GHC+#elif MIN_VERSION_ghc(9,0,0)+import qualified GHC.Driver.Finder                     as GHC+#else+import qualified Finder                                as GHC+#endif+ #if MIN_VERSION_ghc(9,0,0) type PreloadUnitClosure = UniqSet UnitId #if MIN_VERSION_ghc(9,2,0)@@ -407,3 +422,14 @@ #else showSDocForUser' env = showSDocForUser (hsc_dflags env) #endif++findImportedModule :: HscEnv -> ModuleName -> IO (Maybe Module)+findImportedModule env mn = do+#if MIN_VERSION_ghc(9,3,0)+    res <- GHC.findImportedModule env mn NoPkgQual+#else+    res <- GHC.findImportedModule env mn Nothing+#endif+    case res of+        Found _ mod -> pure . pure $ mod+        _           -> pure Nothing

@@ -44,7 +44,7 @@ import           Development.IDE.Types.Diagnostics as D import           Development.IDE.Types.Location import           GHC-import           Language.LSP.Types                (isSubrangeOf)+import           Language.LSP.Protocol.Types       (isSubrangeOf)   diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> FileDiagnostic@@ -57,6 +57,8 @@     , _code     = Nothing     , _relatedInformation = Nothing     , _tags     = Nothing+    , _codeDescription = Nothing+    , _data_   = Nothing     }  -- | Produce a GHC-style error from a source span and a message.@@ -132,13 +134,13 @@ toDSeverity SevOutput      = Nothing toDSeverity SevInteractive = Nothing toDSeverity SevDump        = Nothing-toDSeverity SevInfo        = Just DsInfo-toDSeverity SevFatal       = Just DsError+toDSeverity SevInfo        = Just DiagnosticSeverity_Information+toDSeverity SevFatal       = Just DiagnosticSeverity_Error #else toDSeverity SevIgnore      = Nothing #endif-toDSeverity SevWarning     = Just DsWarning-toDSeverity SevError       = Just DsError+toDSeverity SevWarning     = Just DiagnosticSeverity_Warning+toDSeverity SevError       = Just DiagnosticSeverity_Error   -- | Produce a bag of GHC-style errors (@ErrorMessages@) from the given@@ -186,7 +188,7 @@   diagFromGhcException :: T.Text -> DynFlags -> GhcException -> [FileDiagnostic]-diagFromGhcException diagSource dflags exc = diagFromString diagSource DsError (noSpan "<Internal>") (showGHCE dflags exc)+diagFromGhcException diagSource dflags exc = diagFromString diagSource DiagnosticSeverity_Error (noSpan "<Internal>") (showGHCE dflags exc)  showGHCE :: DynFlags -> GhcException -> String showGHCE dflags exc = case exc of

@@ -40,6 +40,7 @@ import           Data.Text                  (unpack) #if MIN_VERSION_ghc(9,0,0) import           GHC.ByteCode.Types+import GHC (ModuleGraph) #else import           ByteCodeTypes #endif@@ -215,6 +216,9 @@ instance Hashable OccName where hashWithSalt s n = hashWithSalt s (getKey $ getUnique n)  instance Show HomeModInfo where show = show . mi_module . hm_iface++instance Show ModuleGraph where show _ = "ModuleGraph {..}"+instance NFData ModuleGraph where rnf = rwhnf  instance NFData HomeModInfo where   rnf (HomeModInfo iface dets link) = rwhnf iface `seq` rnf dets `seq` rnf link

@@ -12,7 +12,7 @@ import           Development.IDE.GHC.Compat import           Development.IDE.GHC.Error import           Development.IDE.Types.Diagnostics-import           Language.LSP.Types                (type (|?) (..))+import           Language.LSP.Protocol.Types       (type (|?) (..))   -- | Take a GHC monadic action (e.g. @typecheckModule pm@ for some

@@ -10,8 +10,9 @@   , TransitiveDependencies(..)   , FilePathId(..)   , NamedModuleDep(..)-  , ShowableModuleName(..)-  , PathIdMap+  , ShowableModule(..)+  , ShowableModuleEnv(..)+  , PathIdMap (..)   , emptyPathIdMap   , getPathId   , lookupPathToId@@ -23,7 +24,7 @@   , transitiveDeps   , transitiveReverseDependencies   , immediateReverseDependencies-+  , lookupModuleFile   , BootIdMap   , insertBootId   ) where@@ -53,6 +54,7 @@ import           Development.IDE.Types.Location  import           GHC+import Development.IDE.GHC.Compat  -- | The imports for a given module. newtype ModuleImports = ModuleImports@@ -103,8 +105,8 @@ insertImport :: FilePathId -> Either ModuleParseError ModuleImports -> RawDependencyInformation -> RawDependencyInformation insertImport (FilePathId k) v rawDepInfo = rawDepInfo { rawImports = IntMap.insert k v (rawImports rawDepInfo) } -pathToId :: PathIdMap -> NormalizedFilePath -> FilePathId-pathToId PathIdMap{pathToIdMap} path = pathToIdMap HMS.! path+pathToId :: PathIdMap -> NormalizedFilePath -> Maybe FilePathId+pathToId PathIdMap{pathToIdMap} path = pathToIdMap HMS.!? path  lookupPathToId :: PathIdMap -> NormalizedFilePath -> Maybe FilePathId lookupPathToId PathIdMap{pathToIdMap} path = HMS.lookup path pathToIdMap@@ -128,15 +130,14 @@     -- corresponding hs file. It is used when topologically sorting as we     -- need to add edges between .hs-boot and .hs so that the .hs files     -- appear later in the sort.-    , rawBootMap   :: !BootIdMap-    , rawModuleNameMap :: !(FilePathIdMap ShowableModuleName)+    , rawModuleMap :: !(FilePathIdMap ShowableModule)     } deriving Show  data DependencyInformation =   DependencyInformation     { depErrorNodes        :: !(FilePathIdMap (NonEmpty NodeError))     -- ^ Nodes that cannot be processed correctly.-    , depModuleNames       :: !(FilePathIdMap ShowableModuleName)+    , depModules       :: !(FilePathIdMap ShowableModule)     , depModuleDeps        :: !(FilePathIdMap FilePathIdSet)     -- ^ For a non-error node, this contains the set of module immediate dependencies     -- in the same package.@@ -146,14 +147,25 @@     -- ^ Map from FilePath to FilePathId     , depBootMap           :: !BootIdMap     -- ^ Map from hs-boot file to the corresponding hs file+    , depModuleFiles       :: !(ShowableModuleEnv FilePathId)+    -- ^ Map from Module to the corresponding non-boot hs file+    , depModuleGraph       :: !ModuleGraph     } deriving (Show, Generic) -newtype ShowableModuleName =-  ShowableModuleName {showableModuleName :: ModuleName}+newtype ShowableModule =+  ShowableModule {showableModule :: Module}   deriving NFData -instance Show ShowableModuleName where show = moduleNameString . showableModuleName+newtype ShowableModuleEnv a =+  ShowableModuleEnv {showableModuleEnv :: ModuleEnv a} +instance Show a => Show (ShowableModuleEnv a) where+  show (ShowableModuleEnv x) = show (moduleEnvToList x)+instance NFData a => NFData (ShowableModuleEnv a) where+  rnf = rwhnf++instance Show ShowableModule where show = moduleNameString . moduleName . showableModule+ reachableModules :: DependencyInformation -> [NormalizedFilePath] reachableModules DependencyInformation{..} =     map (idToPath depPathIdMap . FilePathId) $ IntMap.keys depErrorNodes <> IntMap.keys depModuleDeps@@ -215,15 +227,17 @@    SuccessNode _ <> ErrorNode errs   = ErrorNode errs    SuccessNode a <> SuccessNode _    = SuccessNode a -processDependencyInformation :: RawDependencyInformation -> DependencyInformation-processDependencyInformation RawDependencyInformation{..} =+processDependencyInformation :: RawDependencyInformation -> BootIdMap -> ModuleGraph -> DependencyInformation+processDependencyInformation RawDependencyInformation{..} rawBootMap mg =   DependencyInformation     { depErrorNodes = IntMap.fromList errorNodes     , depModuleDeps = moduleDeps     , depReverseModuleDeps = reverseModuleDeps-    , depModuleNames = rawModuleNameMap+    , depModules = rawModuleMap     , depPathIdMap = rawPathIdMap     , depBootMap = rawBootMap+    , depModuleFiles = ShowableModuleEnv reverseModuleMap+    , depModuleGraph = mg     }   where resultGraph = buildResultGraph rawImports         (errorNodes, successNodes) = partitionNodeResults $ IntMap.toList resultGraph@@ -240,6 +254,7 @@           foldr (\(p, cs) res ->             let new = IntMap.fromList (map (, IntSet.singleton (coerce p)) (coerce cs))             in IntMap.unionWith IntSet.union new res ) IntMap.empty successEdges+        reverseModuleMap = mkModuleEnv $ map (\(i,sm) -> (showableModule sm, FilePathId i)) $ IntMap.toList rawModuleMap   -- | Given a dependency graph, buildResultGraph detects and propagates errors in that graph as follows:@@ -328,7 +343,7 @@ -- | returns all transitive dependencies in topological order. transitiveDeps :: DependencyInformation -> NormalizedFilePath -> Maybe TransitiveDependencies transitiveDeps DependencyInformation{..} file = do-  let !fileId = pathToId depPathIdMap file+  !fileId <- pathToId depPathIdMap file   reachableVs <-       -- Delete the starting node       IntSet.delete (getFilePathId fileId) .@@ -350,6 +365,10 @@     boot_edge f = [getFilePathId f' | Just f' <- [IntMap.lookup f depBootMap]]      vs = topSort g++lookupModuleFile :: Module -> DependencyInformation -> Maybe NormalizedFilePath+lookupModuleFile mod DependencyInformation{..}+  = idToPath depPathIdMap <$> lookupModuleEnv (showableModuleEnv depModuleFiles) mod  newtype TransitiveDependencies = TransitiveDependencies   { transitiveModuleDeps :: [NormalizedFilePath]

@@ -29,6 +29,7 @@ import           System.FilePath #if MIN_VERSION_ghc(9,3,0) import           GHC.Types.PkgQual+import           GHC.Unit.State #endif  data Import@@ -135,25 +136,45 @@ #else     Nothing -> do #endif++      mbFile <- locateModuleFile ((homeUnitId_ dflags, importPaths dflags) : other_imports) exts targetFor isSource $ unLoc modName+      case mbFile of+        Nothing          -> lookupInPackageDB env+        Just (uid, file) -> toModLocation uid file+  where+    dflags = hsc_dflags env+    import_paths = mapMaybe (mkImportDirs env) comp_info+    other_imports =+#if MIN_VERSION_ghc(9,4,0)+      -- On 9.4+ instead of bringing all the units into scope, only bring into scope the units+      -- this one depends on+      -- This way if you have multiple units with the same module names, we won't get confused+      -- For example if unit a imports module M from unit B, when there is also a module M in unit C,+      -- and unit a only depends on unit b, without this logic there is the potential to get confused+      -- about which module unit a imports.+      -- Without multi-component support it is hard to recontruct the dependency environment so+      -- unit a will have both unit b and unit c in scope.+      map (\uid -> (uid, importPaths (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue)))) hpt_deps+    ue = hsc_unit_env env+    units = homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId_ dflags) ue+    hpt_deps :: [UnitId]+    hpt_deps = homeUnitDepends units+#else+      import_paths'+#endif+       -- first try to find the module as a file. If we can't find it try to find it in the package       -- database.       -- Here the importPaths for the current modules are added to the front of the import paths from the other components.       -- This is particularly important for Paths_* modules which get generated for every component but unless you use it in       -- each component will end up being found in the wrong place and cause a multi-cradle match failure.-      let import_paths' =+    import_paths' = #if MIN_VERSION_ghc(9,3,0)             import_paths #else             map snd import_paths #endif -      mbFile <- locateModuleFile ((homeUnitId_ dflags, importPaths dflags) : import_paths') exts targetFor isSource $ unLoc modName-      case mbFile of-        Nothing          -> lookupInPackageDB env-        Just (uid, file) -> toModLocation uid file-  where-    dflags = hsc_dflags env-    import_paths = mapMaybe (mkImportDirs env) comp_info     toModLocation uid file = liftIO $ do         loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file) #if MIN_VERSION_ghc(9,0,0)@@ -180,7 +201,7 @@   mkError' $ ppr' $ cannotFindModule env modName0 $ lookupToFindResult reason   where     dfs = hsc_dflags env-    mkError' = diagFromString "not found" DsError (Compat.getLoc modName)+    mkError' = diagFromString "not found" DiagnosticSeverity_Error (Compat.getLoc modName)     modName0 = unLoc modName     ppr' = showSDoc dfs     -- We convert the lookup result to a find result to reuse GHC's cannotFindModule pretty printer.

@@ -15,45 +15,47 @@     , wsSymbols     ) where +import           Control.Monad.Except           (ExceptT) import           Control.Monad.IO.Class+import           Data.Maybe                     (fromMaybe) import           Development.IDE.Core.Actions import           Development.IDE.Core.Rules import           Development.IDE.Core.Shake import           Development.IDE.Types.Location-import           Development.IDE.Types.Logger+import           Ide.Logger+import           Ide.Plugin.Error+import           Ide.Types+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types import qualified Language.LSP.Server            as LSP-import           Language.LSP.Types  import qualified Data.Text                      as T -gotoDefinition :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (ResponseResult TextDocumentDefinition))-hover          :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (Maybe Hover))-gotoTypeDefinition :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (ResponseResult TextDocumentTypeDefinition))-documentHighlight :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (List DocumentHighlight))-gotoDefinition = request "Definition" getDefinition (InR $ InL $ List []) (InR . InL . List)-gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InL $ List []) (InR . InL . List)-hover          = request "Hover"      getAtPoint     Nothing      foundHover-documentHighlight = request "DocumentHighlight" highlightAtPoint (List []) List+gotoDefinition :: IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (MessageResult Method_TextDocumentDefinition)+hover          :: IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (Hover |? Null)+gotoTypeDefinition :: IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (MessageResult Method_TextDocumentTypeDefinition)+documentHighlight :: IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) ([DocumentHighlight] |? Null)+gotoDefinition = request "Definition" getDefinition (InR $ InR Null) (InL . Definition. InR)+gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InR Null) (InL . Definition. InR)+hover          = request "Hover"      getAtPoint     (InR Null)     foundHover+documentHighlight = request "DocumentHighlight" highlightAtPoint (InR Null) InL -references :: IdeState -> ReferenceParams -> LSP.LspM c (Either ResponseError (List Location))-references ide (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = liftIO $-  case uriToFilePath' uri of-    Just path -> do-      let filePath = toNormalizedFilePath' path-      logDebug (ideLogger ide) $+references :: PluginMethodHandler IdeState 'Method_TextDocumentReferences+references ide _ (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = do+  nfp <- getNormalizedFilePathE uri+  liftIO $ logDebug (ideLogger ide) $         "References request at position " <> T.pack (showPosition pos) <>-        " in file: " <> T.pack path-      Right . List <$> (runAction "references" ide $ refsAtPoint filePath pos)-    Nothing -> pure $ Left $ ResponseError InvalidParams ("Invalid URI " <> T.pack (show uri)) Nothing+        " in file: " <> T.pack (show nfp)+  InL <$> (liftIO $ runAction "references" ide $ refsAtPoint nfp pos) -wsSymbols :: IdeState -> WorkspaceSymbolParams -> LSP.LspM c (Either ResponseError (List SymbolInformation))-wsSymbols ide (WorkspaceSymbolParams _ _ query) = liftIO $ do+wsSymbols :: PluginMethodHandler IdeState 'Method_WorkspaceSymbol+wsSymbols ide _ (WorkspaceSymbolParams _ _ query) = liftIO $ do   logDebug (ideLogger ide) $ "Workspace symbols request: " <> query-  runIdeAction "WorkspaceSymbols" (shakeExtras ide) $ Right . maybe (List []) List <$> workspaceSymbols query+  runIdeAction "WorkspaceSymbols" (shakeExtras ide) $ InL . fromMaybe [] <$> workspaceSymbols query -foundHover :: (Maybe Range, [T.Text]) -> Maybe Hover+foundHover :: (Maybe Range, [T.Text]) -> Hover |? Null foundHover (mbRange, contents) =-  Just $ Hover (HoverContents $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator contents) mbRange+  InL $ Hover (InL $ MarkupContent MarkupKind_Markdown $ T.intercalate sectionSeparator contents) mbRange  -- | Respond to and log a hover or go-to-definition request request@@ -63,12 +65,12 @@   -> (a -> b)   -> IdeState   -> TextDocumentPositionParams-  -> LSP.LspM c (Either ResponseError b)+  -> ExceptT PluginError (LSP.LspM c) b request label getResults notFound found ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = liftIO $ do     mbResult <- case uriToFilePath' uri of         Just path -> logAndRunRequest label getResults ide pos path         Nothing   -> pure Nothing-    pure $ Right $ maybe notFound found mbResult+    pure $ maybe notFound found mbResult  logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> IdeAction b) -> IdeState -> Position -> String -> IO b logAndRunRequest label getResults ide pos path = do

@@ -1,12 +1,12 @@       -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE DuplicateRecordFields     #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GADTs                     #-} {-# LANGUAGE PolyKinds                 #-} {-# LANGUAGE RankNTypes                #-} {-# LANGUAGE StarIsType                #-}- -- WARNING: A copy of DA.Daml.LanguageServer, try to keep them in sync -- This version removes the daml: handling module Development.IDE.LSP.LanguageServer@@ -26,8 +26,9 @@ import           Development.IDE.LSP.Server import           Development.IDE.Session               (runWithDb) import           Ide.Types                             (traceWithSpan)+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types import qualified Language.LSP.Server                   as LSP-import           Language.LSP.Types import           System.IO import           UnliftIO.Async import           UnliftIO.Concurrent@@ -40,14 +41,13 @@ import           Development.IDE.Core.Shake            hiding (Log, Priority) import           Development.IDE.Core.Tracing import qualified Development.IDE.Session               as Session-import           Development.IDE.Types.Logger-import qualified Development.IDE.Types.Logger          as Logger import           Development.IDE.Types.Shake           (WithHieDb)+import           Ide.Logger+import qualified Ide.Logger                            as Logger import           Language.LSP.Server                   (LanguageContextEnv,                                                         LspServerLog,                                                         type (<~>)) import           System.IO.Unsafe                      (unsafeInterleaveIO)- data Log   = LogRegisteringIdeConfig !IdeConfiguration   | LogReactorThreadException !SomeException@@ -92,7 +92,7 @@     -> config     -> (config -> Value -> Either T.Text config)     -> (MVar ()-        -> IO (LSP.LanguageContextEnv config -> RequestMessage Initialize -> IO (Either ResponseError (LSP.LanguageContextEnv config, a)),+        -> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either ResponseError (LSP.LanguageContextEnv config, a)),                LSP.Handlers (m config),                (LanguageContextEnv config, a) -> m config <~> IO))     -> IO ()@@ -107,7 +107,7 @@             { LSP.onConfigurationChange = onConfigurationChange             , LSP.defaultConfig = defaultConfig             , LSP.doInitialize = doInitialize-            , LSP.staticHandlers = staticHandlers+            , LSP.staticHandlers = (const staticHandlers)             , LSP.interpretHandler = interpretHandler             , LSP.options = modifyOptions options             }@@ -133,7 +133,7 @@   -> LSP.Handlers (ServerM config)   -> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState)   -> MVar ()-  -> IO (LSP.LanguageContextEnv config -> RequestMessage Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)),+  -> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)),          LSP.Handlers (ServerM config),          (LanguageContextEnv config, IdeState) -> ServerM config <~> IO) setupLSP  recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do@@ -195,8 +195,8 @@     -> (SomeLspId -> IO ())     -> (SomeLspId -> IO ())     -> Chan ReactorMessage-    -> LSP.LanguageContextEnv config -> RequestMessage Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState))-handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (RequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do+    -> LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState))+handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (TRequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do     traceWithSpan sp params     let root = LSP.resRootPath env     dir <- maybe getCurrentDirectory return root@@ -233,11 +233,11 @@                     case cancelOrRes of                         Left () -> do                             log Debug $ LogCancelledRequest _id-                            k $ ResponseError RequestCancelled "" Nothing+                            k $ ResponseError (InL LSPErrorCodes_RequestCancelled) "" Nothing                         Right res -> pure res                 ) $ \(e :: SomeException) -> do                     exceptionInHandler e-                    k $ ResponseError InternalError (T.pack $ show e) Nothing+                    k $ ResponseError (InR ErrorCodes_InternalError) (T.pack $ show e) Nothing     _ <- flip forkFinally handleServerException $ do         untilMVar lifetime $ runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \withHieDb hieChan -> do             putMVar dbMVar (WithHieDbShield withHieDb,hieChan)@@ -263,27 +263,30 @@     waitAnyCancel =<< traverse async [ io , readMVar mvar ]  cancelHandler :: (SomeLspId -> IO ()) -> LSP.Handlers (ServerM c)-cancelHandler cancelRequest = LSP.notificationHandler SCancelRequest $ \NotificationMessage{_params=CancelParams{_id}} ->-  liftIO $ cancelRequest (SomeLspId _id)+cancelHandler cancelRequest = LSP.notificationHandler SMethod_CancelRequest $ \TNotificationMessage{_params=CancelParams{_id}} ->+  liftIO $ cancelRequest (SomeLspId (toLspId _id))+  where toLspId :: (Int32 |? T.Text) -> LspId a+        toLspId (InL x) = IdInt x+        toLspId (InR y) = IdString y  shutdownHandler :: IO () -> LSP.Handlers (ServerM c)-shutdownHandler stopReactor = LSP.requestHandler SShutdown $ \_ resp -> do+shutdownHandler stopReactor = LSP.requestHandler SMethod_Shutdown $ \_ resp -> do     (_, ide) <- ask     liftIO $ logDebug (ideLogger ide) "Received shutdown message"     -- stop the reactor to free up the hiedb connection     liftIO stopReactor     -- flush out the Shake session to record a Shake profile if applicable     liftIO $ shakeShut ide-    resp $ Right Empty+    resp $ Right Null  exitHandler :: IO () -> LSP.Handlers (ServerM c)-exitHandler exit = LSP.notificationHandler SExit $ const $ liftIO exit+exitHandler exit = LSP.notificationHandler SMethod_Exit $ const $ liftIO exit  modifyOptions :: LSP.Options -> LSP.Options-modifyOptions x = x{ LSP.textDocumentSync   = Just $ tweakTDS origTDS+modifyOptions x = x{ LSP.optTextDocumentSync   = Just $ tweakTDS origTDS                    }     where-        tweakTDS tds = tds{_openClose=Just True, _change=Just TdSyncIncremental, _save=Just $ InR $ SaveOptions Nothing}-        origTDS = fromMaybe tdsDefault $ LSP.textDocumentSync x+        tweakTDS tds = tds{_openClose=Just True, _change=Just TextDocumentSyncKind_Incremental, _save=Just $ InR $ SaveOptions Nothing}+        origTDS = fromMaybe tdsDefault $ LSP.optTextDocumentSync x         tdsDefault = TextDocumentSyncOptions Nothing Nothing Nothing Nothing Nothing 

@@ -13,8 +13,9 @@     , ghcideNotificationsPluginPriority     ) where -import           Language.LSP.Types-import qualified Language.LSP.Types                    as LSP+import qualified Language.LSP.Protocol.Message         as LSP+import           Language.LSP.Protocol.Types+import qualified Language.LSP.Protocol.Types           as LSP  import           Control.Concurrent.STM.Stats          (atomically) import           Control.Monad.Extra@@ -36,8 +37,8 @@ import           Development.IDE.Core.Shake            hiding (Log, Priority) import qualified Development.IDE.Core.Shake            as Shake import           Development.IDE.Types.Location-import           Development.IDE.Types.Logger import           Development.IDE.Types.Shake           (toKey)+import           Ide.Logger import           Ide.Types import           Numeric.Natural @@ -56,9 +57,9 @@  descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId) { pluginNotificationHandlers = mconcat-  [ mkPluginNotificationHandler LSP.STextDocumentDidOpen $+  [ mkPluginNotificationHandler LSP.SMethod_TextDocumentDidOpen $       \ide vfs _ (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> liftIO $ do-      atomically $ updatePositionMapping ide (VersionedTextDocumentIdentifier _uri (Just _version)) (List [])+      atomically $ updatePositionMapping ide (VersionedTextDocumentIdentifier _uri _version) []       whenUriFile _uri $ \file -> do           -- We don't know if the file actually exists, or if the contents match those on disk           -- For example, vscode restores previously unsaved contents on open@@ -66,7 +67,7 @@           setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False file           logDebug (ideLogger ide) $ "Opened text document: " <> getUri _uri -  , mkPluginNotificationHandler LSP.STextDocumentDidChange $+  , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidChange $       \ide vfs _ (DidChangeTextDocumentParams identifier@VersionedTextDocumentIdentifier{_uri} changes) -> liftIO $ do         atomically $ updatePositionMapping ide identifier changes         whenUriFile _uri $ \file -> do@@ -74,14 +75,14 @@           setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False file         logDebug (ideLogger ide) $ "Modified text document: " <> getUri _uri -  , mkPluginNotificationHandler LSP.STextDocumentDidSave $+  , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidSave $       \ide vfs _ (DidSaveTextDocumentParams TextDocumentIdentifier{_uri} _) -> liftIO $ do         whenUriFile _uri $ \file -> do             addFileOfInterest ide file OnDisk             setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide True file         logDebug (ideLogger ide) $ "Saved text document: " <> getUri _uri -  , mkPluginNotificationHandler LSP.STextDocumentDidClose $+  , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidClose $         \ide vfs _ (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do           whenUriFile _uri $ \file -> do               deleteFileOfInterest ide file@@ -90,8 +91,8 @@               setSomethingModified (VFSModified vfs) ide [] $ Text.unpack msg               logDebug (ideLogger ide) msg -  , mkPluginNotificationHandler LSP.SWorkspaceDidChangeWatchedFiles $-      \ide vfs _ (DidChangeWatchedFilesParams (List fileEvents)) -> liftIO $ do+  , mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeWatchedFiles $+      \ide vfs _ (DidChangeWatchedFilesParams fileEvents) -> liftIO $ do         -- See Note [File existence cache and LSP file watchers] which explains why we get these notifications and         -- what we do with them         -- filter out files of interest, since we already know all about those@@ -110,7 +111,7 @@             resetFileStore ide fileEvents'             setSomethingModified (VFSModified vfs) ide [] msg -  , mkPluginNotificationHandler LSP.SWorkspaceDidChangeWorkspaceFolders $+  , mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeWorkspaceFolders $       \ide _ _ (DidChangeWorkspaceFoldersParams events) -> liftIO $ do         let add       = S.union             substract = flip S.difference@@ -118,14 +119,14 @@           $ add       (foldMap (S.singleton . parseWorkspaceFolder) (_added   events))           . substract (foldMap (S.singleton . parseWorkspaceFolder) (_removed events)) -  , mkPluginNotificationHandler LSP.SWorkspaceDidChangeConfiguration $+  , mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeConfiguration $       \ide vfs _ (DidChangeConfigurationParams cfg) -> liftIO $ do         let msg = Text.pack $ show cfg         logDebug (ideLogger ide) $ "Configuration changed: " <> msg         modifyClientSettings ide (const $ Just cfg)         setSomethingModified (VFSModified vfs) ide [toKey GetClientSettings emptyFilePath] "config change" -  , mkPluginNotificationHandler LSP.SInitialized $ \ide _ _ _ -> do+  , mkPluginNotificationHandler LSP.SMethod_Initialized $ \ide _ _ _ -> do       --------- Initialize Shake session --------------------------------------------------------------------       liftIO $ shakeSessionInit (cmapWithPrio LogShake recorder) ide 

@@ -22,26 +22,25 @@                                                  realSrcSpanToRange) import           Development.IDE.Types.Location import           Development.IDE.GHC.Util       (printOutputable)-import           Language.LSP.Server            (LspM)-import           Language.LSP.Types             (DocumentSymbol (..),+import           Ide.Types+import           Language.LSP.Protocol.Types             (DocumentSymbol (..),                                                  DocumentSymbolParams (DocumentSymbolParams, _textDocument),-                                                 List (..), ResponseError,-                                                 SymbolInformation,-                                                 SymbolKind (SkConstructor, SkField, SkFile, SkFunction, SkInterface, SkMethod, SkModule, SkObject, SkStruct, SkTypeParameter, SkUnknown),+                                                 SymbolKind (..),                                                  TextDocumentIdentifier (TextDocumentIdentifier),-                                                 type (|?) (InL), uriToFilePath)+                                                 type (|?) (InL, InR), uriToFilePath)+import          Language.LSP.Protocol.Message #if MIN_VERSION_ghc(9,2,0) import Data.List.NonEmpty (nonEmpty) #endif  moduleOutline-  :: IdeState -> DocumentSymbolParams -> LspM c (Either ResponseError (List DocumentSymbol |? List SymbolInformation))-moduleOutline ideState DocumentSymbolParams{ _textDocument = TextDocumentIdentifier uri }+  :: PluginMethodHandler IdeState 'Method_TextDocumentDocumentSymbol+moduleOutline ideState _ DocumentSymbolParams{ _textDocument = TextDocumentIdentifier uri }   = liftIO $ case uriToFilePath uri of     Just (toNormalizedFilePath' -> fp) -> do       mb_decls <- fmap fst <$> runAction "Outline" ideState (useWithStale GetParsedModule fp)-      pure $ Right $ case mb_decls of-        Nothing -> InL (List [])+      pure $ case mb_decls of+        Nothing -> InL []         Just ParsedModule { pm_parsed_source = L _ltop HsModule { hsmodName, hsmodDecls, hsmodImports } }           -> let                declSymbols  = mapMaybe documentSymbolForDecl hsmodDecls@@ -49,7 +48,7 @@                  (L (locA -> (RealSrcSpan l _)) m) -> Just $                    (defDocumentSymbol l :: DocumentSymbol)                      { _name  = printOutputable m-                     , _kind  = SkFile+                     , _kind  = SymbolKind_File                      , _range = Range (Position 0 0) (Position maxBound 0) -- _ltop is 0 0 0 0                      }                  _ -> Nothing@@ -59,14 +58,14 @@                allSymbols    = case moduleSymbol of                  Nothing -> importSymbols <> declSymbols                  Just x ->-                   [ x { _children = Just (List (importSymbols <> declSymbols))+                   [ x { _children = Just (importSymbols <> declSymbols)                        }                    ]              in-               InL (List allSymbols)+               InR (InL allSymbols)  -    Nothing -> pure $ Right $ InL (List [])+    Nothing -> pure $ InL []  documentSymbolForDecl :: LHsDecl GhcPs -> Maybe DocumentSymbol documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } }))@@ -77,7 +76,7 @@                        t  -> " " <> t                      )     , _detail = Just $ printOutputable fdInfo-    , _kind   = SkFunction+    , _kind   = SymbolKind_Function     } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ ClassDecl { tcdLName = L _ name, tcdSigs, tcdTyVars }))   = Just (defDocumentSymbol l :: DocumentSymbol)@@ -86,13 +85,13 @@                          "" -> ""                          t  -> " " <> t                        )-    , _kind     = SkInterface+    , _kind     = SymbolKind_Interface     , _detail   = Just "class"     , _children =-      Just $ List+      Just $         [ (defDocumentSymbol l :: DocumentSymbol)             { _name           = printOutputable n-            , _kind           = SkMethod+            , _kind           = SymbolKind_Method             , _selectionRange = realSrcSpanToRange l'             }         | L (locA -> (RealSrcSpan l _))  (ClassOpSig _ False names _) <- tcdSigs@@ -102,15 +101,15 @@ documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ DataDecl { tcdLName = L _ name, tcdDataDefn = HsDataDefn { dd_cons } }))   = Just (defDocumentSymbol l :: DocumentSymbol)     { _name     = printOutputable name-    , _kind     = SkStruct+    , _kind     = SymbolKind_Struct     , _children =-      Just $ List+      Just $         [ (defDocumentSymbol l :: DocumentSymbol)             { _name           = printOutputable n-            , _kind           = SkConstructor+            , _kind           = SymbolKind_Constructor             , _selectionRange = realSrcSpanToRange l' #if MIN_VERSION_ghc(9,2,0)-            , _children       = List . toList <$> nonEmpty childs+            , _children       = toList <$> nonEmpty childs             }         | con <- extract_cons dd_cons         , let (cs, flds) = hsConDeclsBinders con@@ -133,7 +132,7 @@ #else                 { _name = printOutputable (unLoc (rdrNameFieldOcc n)) #endif-                , _kind = SkField+                , _kind = SymbolKind_Field                 }     cvtFld _  = Nothing #else@@ -145,10 +144,10 @@     }   where     -- | Extract the record fields of a constructor-    conArgRecordFields (RecCon (L _ lcdfs)) = Just $ List+    conArgRecordFields (RecCon (L _ lcdfs)) = Just       [ (defDocumentSymbol l :: DocumentSymbol)           { _name = printOutputable n-          , _kind = SkField+          , _kind = SymbolKind_Field           }       | L _ cdf <- lcdfs       , L (locA -> (RealSrcSpan l _)) n <- rdrNameFieldOcc . unLoc <$> cd_fld_names cdf@@ -157,12 +156,12 @@ #endif documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ SynDecl { tcdLName = L (locA -> (RealSrcSpan l' _)) n })) = Just   (defDocumentSymbol l :: DocumentSymbol) { _name           = printOutputable n-                                          , _kind           = SkTypeParameter+                                          , _kind           = SymbolKind_TypeParameter                                           , _selectionRange = realSrcSpanToRange l'                                           } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (InstD _ ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } }))   = Just (defDocumentSymbol l :: DocumentSymbol) { _name = printOutputable cid_poly_ty-                                                 , _kind = SkInterface+                                                 , _kind = SymbolKind_Interface                                                  } #if MIN_VERSION_ghc(9,2,0) documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (InstD _ DataFamInstD { dfid_inst = DataFamInstDecl FamEqn { feqn_tycon, feqn_pats } }))@@ -177,7 +176,7 @@         printOutputable (unLoc feqn_tycon) <> " " <> T.unwords                 (map printOutputable feqn_pats) #endif-    , _kind = SkInterface+    , _kind = SymbolKind_Interface     } #if MIN_VERSION_ghc(9,2,0) documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (InstD _ TyFamInstD { tfid_inst = TyFamInstDecl _ FamEqn { feqn_tycon, feqn_pats } }))@@ -192,23 +191,23 @@         printOutputable (unLoc feqn_tycon) <> " " <> T.unwords                 (map printOutputable feqn_pats) #endif-    , _kind = SkInterface+    , _kind = SymbolKind_Interface     } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (DerivD _ DerivDecl { deriv_type })) =   gfindtype deriv_type <&> \(L (_ :: SrcSpan) name) ->     (defDocumentSymbol l :: DocumentSymbol) { _name = printOutputable @(HsType GhcPs)                                               name-                                            , _kind = SkInterface+                                            , _kind = SymbolKind_Interface                                             } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (ValD _ FunBind{fun_id = L _ name})) = Just     (defDocumentSymbol l :: DocumentSymbol)       { _name   = printOutputable name-      , _kind   = SkFunction+      , _kind   = SymbolKind_Function       } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (ValD _ PatBind{pat_lhs})) = Just     (defDocumentSymbol l :: DocumentSymbol)       { _name   = printOutputable pat_lhs-      , _kind   = SkFunction+      , _kind   = SymbolKind_Function       }  documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (ForD _ x)) = Just@@ -217,7 +216,7 @@                   ForeignImport{} -> name                   ForeignExport{} -> name                   XForeignDecl{}  -> "?"-    , _kind   = SkObject+    , _kind   = SymbolKind_Object     , _detail = case x of                   ForeignImport{} -> Just "import"                   ForeignExport{} -> Just "export"@@ -240,15 +239,15 @@     in       Just (defDocumentSymbol (rangeToRealSrcSpan "" importRange))           { _name = "imports"-          , _kind = SkModule-          , _children = Just (List importSymbols)+          , _kind = SymbolKind_Module+          , _children = Just importSymbols           }  documentSymbolForImport :: LImportDecl GhcPs -> Maybe DocumentSymbol documentSymbolForImport (L (locA -> (RealSrcSpan l _)) ImportDecl { ideclName, ideclQualified }) = Just   (defDocumentSymbol l :: DocumentSymbol)     { _name   = "import " <> printOutputable ideclName-    , _kind   = SkModule+    , _kind   = SymbolKind_Module     , _detail = case ideclQualified of { NotQualified -> Nothing; _ -> Just "qualified" }     } documentSymbolForImport _ = Nothing@@ -258,7 +257,9 @@   _detail         = Nothing   _deprecated     = Nothing   _name           = ""-  _kind           = SkUnknown 0+  -- This used to be SkUnknown 0, which is invalid, as SymbolKinds start at 1,+  -- therefore, I am replacing it with SymbolKind_File, which is the type for 1+  _kind           = SymbolKind_File   _range          = realSrcSpanToRange l   _selectionRange = realSrcSpanToRange l   _children       = Nothing

@@ -1,12 +1,8 @@-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE UndecidableInstances  #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE UndecidableInstances #-} -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE GADTs                 #-}-{-# LANGUAGE KindSignatures        #-}-{-# LANGUAGE RankNTypes            #-} module Development.IDE.LSP.Server   ( ReactorMessage(..)   , ReactorChan@@ -14,15 +10,14 @@   , requestHandler   , notificationHandler   ) where--import           Control.Monad.IO.Unlift      (MonadUnliftIO)+import           Control.Monad.IO.Unlift       (MonadUnliftIO) import           Control.Monad.Reader import           Development.IDE.Core.Shake import           Development.IDE.Core.Tracing-import           Ide.Types                    (HasTracing, traceWithSpan)-import           Language.LSP.Server          (Handlers, LspM)-import qualified Language.LSP.Server          as LSP-import           Language.LSP.Types+import           Ide.Types                     (HasTracing, traceWithSpan)+import           Language.LSP.Protocol.Message+import           Language.LSP.Server           (Handlers, LspM)+import qualified Language.LSP.Server           as LSP import           Language.LSP.VFS import           UnliftIO.Chan @@ -35,25 +30,26 @@   deriving (Functor, Applicative, Monad, MonadReader (ReactorChan, IdeState), MonadIO, MonadUnliftIO, LSP.MonadLsp c)  requestHandler-  :: forall (m :: Method FromClient Request) c. (HasTracing (MessageParams m)) =>+  :: forall (m :: Method ClientToServer Request) c. (HasTracing (MessageParams m)) =>      SMethod m-  -> (IdeState -> MessageParams m -> LspM c (Either ResponseError (ResponseResult m)))+  -> (IdeState -> MessageParams m -> LspM c (Either ResponseError (MessageResult m)))   -> Handlers (ServerM c)-requestHandler m k = LSP.requestHandler m $ \RequestMessage{_method,_id,_params} resp -> do+requestHandler m k = LSP.requestHandler m $ \TRequestMessage{_method,_id,_params} resp -> do   st@(chan,ide) <- ask   env <- LSP.getLspEnv-  let resp' = flip (runReaderT . unServerM) st . resp+  let resp' :: Either ResponseError (MessageResult m) -> LspM c ()+      resp' = flip (runReaderT . unServerM) st . resp       trace x = otTracedHandler "Request" (show _method) $ \sp -> do         traceWithSpan sp _params         x   writeChan chan $ ReactorRequest (SomeLspId _id) (trace $ LSP.runLspT env $ resp' =<< k ide _params) (LSP.runLspT env . resp' . Left)  notificationHandler-  :: forall (m :: Method FromClient Notification) c. (HasTracing (MessageParams m)) =>+  :: forall (m :: Method ClientToServer Notification) c. (HasTracing (MessageParams m)) =>      SMethod m   -> (IdeState -> VFS -> MessageParams m -> LspM c ())   -> Handlers (ServerM c)-notificationHandler m k = LSP.notificationHandler m $ \NotificationMessage{_params,_method}-> do+notificationHandler m k = LSP.notificationHandler m $ \TNotificationMessage{_params,_method}-> do   (chan,ide) <- ask   env <- LSP.getLspEnv   -- Take a snapshot of the VFS state on every notification

@@ -77,7 +77,7 @@ import qualified Development.IDE.Session                  as Session import           Development.IDE.Types.Location           (NormalizedUri,                                                            toNormalizedFilePath')-import           Development.IDE.Types.Logger             (Logger,+import           Ide.Logger             (Logger,                                                            Pretty (pretty),                                                            Priority (Info, Warning),                                                            Recorder,@@ -235,7 +235,7 @@             { optCheckProject = pure $ checkProject config             , optCheckParents = pure $ checkParents config             }-        , argsLspOptions = def {LSP.completionTriggerCharacters = Just "."}+        , argsLspOptions = def {LSP.optCompletionTriggerCharacters = Just "."}         , argsDefaultHlsConfig = def         , argsGetHieDbLoc = getHieDbLoc         , argsDebouncer = newAsyncDebouncer@@ -293,7 +293,7 @@     let hlsPlugin = asGhcIdePlugin (cmapWithPrio LogPluginHLS recorder) argsHlsPlugins         hlsCommands = allLspCmdIds' pid argsHlsPlugins         plugins = hlsPlugin <> argsGhcidePlugin-        options = argsLspOptions { LSP.executeCommandCommands = LSP.executeCommandCommands argsLspOptions <> Just hlsCommands }+        options = argsLspOptions { LSP.optExecuteCommandCommands = LSP.optExecuteCommandCommands argsLspOptions <> Just hlsCommands }         argsOnConfigChange = getConfigFromNotification argsHlsPlugins         rules = argsRules >> pluginRules plugins 

@@ -6,11 +6,11 @@ import           Control.Concurrent.Async import           Control.Monad import           Data.Word-import           Development.IDE.Types.Logger (Pretty (pretty), Priority (Info),-                                               Recorder, WithPriority, hsep,-                                               logWith, (<+>)) import           GHC.Stats-import           Text.Printf                  (printf)+import           Ide.Logger               (Pretty (pretty), Priority (Info),+                                           Recorder, WithPriority, hsep,+                                           logWith, (<+>))+import           Text.Printf              (printf)  data Log   = LogHeapStatsPeriod !Int

@@ -1,14 +1,14 @@ {-# LANGUAGE CPP #-} module Development.IDE.Monitoring.EKG(monitoring) where -import           Development.IDE.Types.Logger     (Logger) import           Development.IDE.Types.Monitoring (Monitoring (..))+import           Ide.Logger                       (Logger) #ifdef MONITORING_EKG import           Control.Concurrent               (killThread) import           Control.Concurrent.Async         (async, waitCatch) import           Control.Monad                    (forM_) import           Data.Text                        (pack)-import           Development.IDE.Types.Logger     (logInfo)+import           Ide.Logger                       (logInfo) import qualified System.Metrics                   as Monitoring import qualified System.Remote.Monitoring.Wai     as Monitoring 

@@ -11,15 +11,18 @@  import           Control.Concurrent.Async                 (concurrently) import           Control.Concurrent.STM.Stats             (readTVarIO)+import           Control.Lens                             ((&), (.~)) import           Control.Monad.IO.Class-import           Control.Lens                            ((&), (.~))+import           Control.Monad.Trans.Except               (ExceptT (ExceptT),+                                                           withExceptT)+import           Data.Aeson import qualified Data.HashMap.Strict                      as Map import qualified Data.HashSet                             as Set-import           Data.Aeson import           Data.Maybe import qualified Data.Text                                as T-import           Development.IDE.Core.PositionMapping import           Development.IDE.Core.Compile+import           Development.IDE.Core.PluginUtils+import           Development.IDE.Core.PositionMapping import           Development.IDE.Core.RuleTypes import           Development.IDE.Core.Service             hiding (Log, LogShake) import           Development.IDE.Core.Shake               hiding (Log)@@ -27,24 +30,25 @@ import           Development.IDE.GHC.Compat import           Development.IDE.GHC.Util import           Development.IDE.Graph-import           Development.IDE.Spans.Common-import           Development.IDE.Spans.Documentation import           Development.IDE.Plugin.Completions.Logic import           Development.IDE.Plugin.Completions.Types+import           Development.IDE.Spans.Common+import           Development.IDE.Spans.Documentation import           Development.IDE.Types.Exports import           Development.IDE.Types.HscEnvEq           (HscEnvEq (envPackageExports, envVisibleModuleNames),                                                            hscEnv) import qualified Development.IDE.Types.KnownTargets       as KT import           Development.IDE.Types.Location-import           Development.IDE.Types.Logger             (Pretty (pretty),+import           Ide.Logger                               (Pretty (pretty),                                                            Recorder,                                                            WithPriority,                                                            cmapWithPrio)+import           Ide.Plugin.Error import           Ide.Types+import qualified Language.LSP.Protocol.Lens               as L+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types import qualified Language.LSP.Server                      as LSP-import           Language.LSP.Types-import qualified Language.LSP.Types.Lens         as J-import qualified Language.LSP.VFS                         as VFS import           Numeric.Natural import           Text.Fuzzy.Parallel                      (Scored (..)) @@ -64,8 +68,8 @@ descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId)   { pluginRules = produceCompletions recorder-  , pluginHandlers = mkPluginHandler STextDocumentCompletion getCompletionsLSP-                  <> mkPluginHandler SCompletionItemResolve resolveCompletion+  , pluginHandlers = mkPluginHandler SMethod_TextDocumentCompletion getCompletionsLSP+                     <> mkResolveHandler SMethod_CompletionItemResolve resolveCompletion   , pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties}   , pluginPriority = ghcideCompletionsPluginPriority   }@@ -118,59 +122,50 @@     f x = x     in f <$> iDecl -resolveCompletion :: IdeState -> PluginId -> CompletionItem -> LSP.LspM Config (Either ResponseError CompletionItem)-resolveCompletion ide _ comp@CompletionItem{_detail,_documentation,_xdata}-  | Just resolveData <- _xdata-  , Success (CompletionResolveData uri needType (NameDetails mod occ)) <- fromJSON resolveData-  , Just file <- uriToNormalizedFilePath $ toNormalizedUri uri-  = liftIO $ runIdeAction "Completion resolve" (shakeExtras ide) $ do-    msess <- useWithStaleFast GhcSessionDeps file-    case msess of-      Nothing -> pure (Right comp) -- File doesn't compile, return original completion item-      Just (sess,_) -> do-        let nc = ideNc $ shakeExtras ide+resolveCompletion :: ResolveFunction IdeState CompletionResolveData 'Method_CompletionItemResolve+resolveCompletion ide _pid comp@CompletionItem{_detail,_documentation,_data_} uri (CompletionResolveData _ needType (NameDetails mod occ)) =+  do+    file <- getNormalizedFilePathE uri+    (sess,_) <- withExceptT (const PluginStaleResolve)+                  $ runIdeActionE "CompletionResolve.GhcSessionDeps" (shakeExtras ide)+                  $ useWithStaleFastE GhcSessionDeps file+    let nc = ideNc $ shakeExtras ide #if MIN_VERSION_ghc(9,3,0)-        name <- liftIO $ lookupNameCache nc mod occ+    name <- liftIO $ lookupNameCache nc mod occ #else-        name <- liftIO $ upNameCache nc (lookupNameCache mod occ)+    name <- liftIO $ upNameCache nc (lookupNameCache mod occ) #endif-        mdkm <- useWithStaleFast GetDocMap file-        let (dm,km) = case mdkm of-              Just (DKMap dm km, _) -> (dm,km)-              Nothing -> (mempty, mempty)-        doc <- case lookupNameEnv dm name of-          Just doc -> pure $ spanDocToMarkdown doc-          Nothing -> liftIO $ spanDocToMarkdown <$> getDocumentationTryGhc (hscEnv sess) name-        typ <- case lookupNameEnv km name of-          _ | not needType -> pure Nothing-          Just ty -> pure (safeTyThingType ty)-          Nothing -> do-            (safeTyThingType =<<) <$> liftIO (lookupName (hscEnv sess) name)-        let det1 = case typ of-              Just ty -> Just (":: " <> printOutputable (stripForall ty) <> "\n")-              Nothing -> Nothing-            doc1 = case _documentation of-              Just (CompletionDocMarkup (MarkupContent MkMarkdown old)) ->-                CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator (old:doc)-              _ -> CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator doc-        pure (Right $ comp & J.detail .~ (det1 <> _detail)-                           & J.documentation .~ Just doc1-                           )+    mdkm <- liftIO $ runIdeAction "CompletionResolve.GetDocMap" (shakeExtras ide) $ useWithStaleFast GetDocMap file+    let (dm,km) = case mdkm of+          Just (DKMap dm km, _) -> (dm,km)+          Nothing               -> (mempty, mempty)+    doc <- case lookupNameEnv dm name of+      Just doc -> pure $ spanDocToMarkdown doc+      Nothing -> liftIO $ spanDocToMarkdown <$> getDocumentationTryGhc (hscEnv sess) name+    typ <- case lookupNameEnv km name of+      _ | not needType -> pure Nothing+      Just ty -> pure (safeTyThingType ty)+      Nothing -> do+        (safeTyThingType =<<) <$> liftIO (lookupName (hscEnv sess) name)+    let det1 = case typ of+          Just ty -> Just (":: " <> printOutputable (stripForall ty) <> "\n")+          Nothing -> Nothing+        doc1 = case _documentation of+          Just (InR (MarkupContent MarkupKind_Markdown old)) ->+            InR $ MarkupContent MarkupKind_Markdown $ T.intercalate sectionSeparator (old:doc)+          _ -> InR $ MarkupContent MarkupKind_Markdown $ T.intercalate sectionSeparator doc+    pure  (comp & L.detail .~ (det1 <> _detail)+                & L.documentation .~ Just doc1)   where     stripForall ty = case splitForAllTyCoVars ty of       (_,res) -> res-resolveCompletion _ _ comp = pure (Right comp)  -- | Generate code actions.-getCompletionsLSP-    :: IdeState-    -> PluginId-    -> CompletionParams-    -> LSP.LspM Config (Either ResponseError (ResponseResult TextDocumentCompletion))+getCompletionsLSP :: PluginMethodHandler IdeState 'Method_TextDocumentCompletion getCompletionsLSP ide plId   CompletionParams{_textDocument=TextDocumentIdentifier uri                   ,_position=position-                  ,_context=completionContext} = do+                  ,_context=completionContext} = ExceptT $ do     contents <- LSP.getVirtualFile $ toNormalizedUri uri     fmap Right $ case (contents, uriToFilePath' uri) of       (Just cnts, Just path) -> do@@ -213,17 +208,16 @@             let pfix = getCompletionPrefix position cnts             case (pfix, completionContext) of               ((PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."})-                -> return (InL $ List [])+                -> return (InL [])               (_, _) -> do                 let clientCaps = clientCapabilities $ shakeExtras ide                     plugins = idePlugins $ shakeExtras ide                 config <- liftIO $ runAction "" ide $ getCompletionsConfig plId                  allCompletions <- liftIO $ getCompletions plugins ideOpts cci' parsedMod astres bindMap pfix clientCaps config moduleExports uri-                pure $ InL (List $ orderedCompletions allCompletions)-              _ -> return (InL $ List [])-          _ -> return (InL $ List [])-      _ -> return (InL $ List [])+                pure $ InL (orderedCompletions allCompletions)+          _ -> return (InL [])+      _ -> return (InL [])  getCompletionsConfig :: PluginId -> Action CompletionsConfig getCompletionsConfig pId =

@@ -1,7 +1,8 @@-{-# LANGUAGE CPP        #-}-{-# LANGUAGE GADTs      #-}-{-# LANGUAGE MultiWayIf #-}-+{-# LANGUAGE CPP              #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE GADTs            #-}+{-# LANGUAGE MultiWayIf       #-}+{-# LANGUAGE OverloadedLabels #-}  -- Mostly taken from "haskell-ide-engine" module Development.IDE.Plugin.Completions.Logic (@@ -14,15 +15,19 @@ ) where  import           Control.Applicative+import           Control.Lens                             hiding (Context) import           Data.Char                                (isAlphaNum, isUpper)+import           Data.Default                             (def) import           Data.Generics import           Data.List.Extra                          as List hiding                                                                   (stripPrefix) import qualified Data.Map                                 as Map+import           Data.Row  import           Data.Maybe                               (catMaybes, fromMaybe,-                                                           isJust, listToMaybe,-                                                           mapMaybe, isNothing)+                                                           isJust, isNothing,+                                                           listToMaybe,+                                                           mapMaybe) import qualified Data.Text                                as T import qualified Text.Fuzzy.Parallel                      as Fuzzy @@ -41,7 +46,7 @@ import           Development.IDE.GHC.Compat               hiding (ppr) import qualified Development.IDE.GHC.Compat               as GHC import           Development.IDE.GHC.Compat.Util-import           Development.IDE.GHC.CoreFile            (occNamePrefixes)+import           Development.IDE.GHC.CoreFile             (occNamePrefixes) import           Development.IDE.GHC.Error import           Development.IDE.GHC.Util import           Development.IDE.Plugin.Completions.Types@@ -64,8 +69,8 @@ import           Ide.Types                                (CommandId (..),                                                            IdePlugins (..),                                                            PluginId)-import           Language.LSP.Types-import           Language.LSP.Types.Capabilities+import qualified Language.LSP.Protocol.Lens               as L+import           Language.LSP.Protocol.Types import qualified Language.LSP.VFS                         as VFS import           Text.Fuzzy.Parallel                      (Scored (score),                                                            original)@@ -76,7 +81,7 @@ import           Development.IDE.Spans.AtPoint            (pointCommand)  #if MIN_VERSION_ghc(9,5,0)-import Language.Haskell.Syntax.Basic+import           Language.Haskell.Syntax.Basic #endif  -- Chunk size used for parallelizing fuzzy matching@@ -172,11 +177,11 @@ occNameToComKind :: OccName -> CompletionItemKind occNameToComKind oc   | isVarOcc  oc = case occNameString oc of-                     i:_ | isUpper i -> CiConstructor-                     _               -> CiFunction-  | isTcOcc   oc = CiStruct-  | isDataOcc oc = CiConstructor-  | otherwise    = CiVariable+                     i:_ | isUpper i -> CompletionItemKind_Constructor+                     _               -> CompletionItemKind_Function+  | isTcOcc   oc = CompletionItemKind_Struct+  | isDataOcc oc = CompletionItemKind_Constructor+  | otherwise    = CompletionItemKind_Variable   showModName :: ModuleName -> T.Text@@ -215,13 +220,15 @@                   _sortText = Nothing,                   _filterText = Nothing,                   _insertText = Just insertText,-                  _insertTextFormat = Just Snippet,+                  _insertTextFormat = Just InsertTextFormat_Snippet,                   _insertTextMode = Nothing,                   _textEdit = Nothing,                   _additionalTextEdits = Nothing,                   _commitCharacters = Nothing,                   _command = mbCommand,-                  _xdata = toJSON <$> fmap (CompletionResolveData uri (isNothing typeText)) nameDetails}+                  _data_ = toJSON <$> fmap (CompletionResolveData uri (isNothing typeText)) nameDetails,+                  _labelDetails = Nothing,+                  _textEditText = Nothing}   removeSnippetsWhen (isJust isInfix) ci    where kind = Just compKind@@ -230,8 +237,8 @@           Local pos  -> "*Defined at " <> pprLineCol (srcSpanStart pos) <> " in this module*\n"           ImportedFrom mod -> "*Imported from '" <> mod <> "'*\n"           DefinedIn mod -> "*Defined in '" <> mod <> "'*\n"-        documentation = Just $ CompletionDocMarkup $-                        MarkupContent MkMarkdown $+        documentation = Just $ InR $+                        MarkupContent MarkupKind_Markdown $                         T.intercalate sectionSeparator docs'         pprLineCol :: SrcLoc -> T.Text         pprLineCol (UnhelpfulLoc fs) = T.pack $ unpackFS fs@@ -253,8 +260,8 @@     typeText = Nothing     label = stripPrefix $ printOutputable origName     insertText = case isInfix of-            Nothing -> label-            Just LeftSide -> label <> "`"+            Nothing         -> label+            Just LeftSide   -> label <> "`"              Just Surrounded -> label     additionalTextEdits =@@ -278,30 +285,32 @@  mkModCompl :: T.Text -> CompletionItem mkModCompl label =-  CompletionItem label (Just CiModule) Nothing Nothing-    Nothing Nothing Nothing Nothing Nothing Nothing Nothing-    Nothing Nothing Nothing Nothing Nothing Nothing+    (defaultCompletionItemWithLabel label)+    { _kind = Just CompletionItemKind_Module }  mkModuleFunctionImport :: T.Text -> T.Text -> CompletionItem mkModuleFunctionImport moduleName label =-  CompletionItem label (Just CiFunction) Nothing (Just moduleName)-    Nothing Nothing Nothing Nothing Nothing Nothing Nothing-    Nothing Nothing Nothing Nothing Nothing Nothing+    (defaultCompletionItemWithLabel label)+    { _kind = Just CompletionItemKind_Function+    , _detail = Just moduleName }  mkImportCompl :: T.Text -> T.Text -> CompletionItem mkImportCompl enteredQual label =-  CompletionItem m (Just CiModule) Nothing (Just label)-    Nothing Nothing Nothing Nothing Nothing Nothing Nothing-    Nothing Nothing Nothing Nothing Nothing Nothing+    (defaultCompletionItemWithLabel m)+    { _kind = Just CompletionItemKind_Module+    , _detail = Just label }   where     m = fromMaybe "" (T.stripPrefix enteredQual label)  mkExtCompl :: T.Text -> CompletionItem mkExtCompl label =-  CompletionItem label (Just CiKeyword) Nothing Nothing-    Nothing Nothing Nothing Nothing Nothing Nothing Nothing-    Nothing Nothing Nothing Nothing Nothing Nothing+    (defaultCompletionItemWithLabel label)+    { _kind = Just CompletionItemKind_Keyword } +defaultCompletionItemWithLabel :: T.Text -> CompletionItem+defaultCompletionItemWithLabel label =+    CompletionItem label def def def def def def def def def+                         def def def def def def def def def  fromIdentInfo :: Uri -> IdentInfo -> Maybe T.Text -> CompItem fromIdentInfo doc id@IdentInfo{..} q = CI@@ -439,20 +448,20 @@     compls = concat         [ case decl of             SigD _ (TypeSig _ ids typ) ->-                [mkComp id CiFunction (Just $ showForSnippet typ) | id <- ids]+                [mkComp id CompletionItemKind_Function (Just $ showForSnippet typ) | id <- ids]             ValD _ FunBind{fun_id} ->-                [ mkComp fun_id CiFunction Nothing+                [ mkComp fun_id CompletionItemKind_Function Nothing                 | not (hasTypeSig fun_id)                 ]             ValD _ PatBind{pat_lhs} ->-                [mkComp id CiVariable Nothing+                [mkComp id CompletionItemKind_Variable Nothing                 | VarPat _ id <- listify (\(_ :: Pat GhcPs) -> True) pat_lhs]             TyClD _ ClassDecl{tcdLName, tcdSigs, tcdATs} ->-                mkComp tcdLName CiInterface (Just $ showForSnippet tcdLName) :-                [ mkComp id CiFunction (Just $ showForSnippet typ)+                mkComp tcdLName CompletionItemKind_Interface (Just $ showForSnippet tcdLName) :+                [ mkComp id CompletionItemKind_Function (Just $ showForSnippet typ)                 | L _ (ClassOpSig _ _ ids typ) <- tcdSigs                 , id <- ids] ++-                [ mkComp fdLName CiStruct (Just $ showForSnippet fdLName)+                [ mkComp fdLName CompletionItemKind_Struct (Just $ showForSnippet fdLName)                 | L _ (FamilyDecl{fdLName}) <- tcdATs]             TyClD _ x ->                 let generalCompls = [mkComp id cl (Just $ showForSnippet $ tyClDeclLName x)@@ -464,16 +473,16 @@                    -- the constructors and snippets will be duplicated here giving the user 2 choices.                    generalCompls ++ recordCompls             ForD _ ForeignImport{fd_name,fd_sig_ty} ->-                [mkComp fd_name CiVariable (Just $ showForSnippet fd_sig_ty)]+                [mkComp fd_name CompletionItemKind_Variable (Just $ showForSnippet fd_sig_ty)]             ForD _ ForeignExport{fd_name,fd_sig_ty} ->-                [mkComp fd_name CiVariable (Just $ showForSnippet fd_sig_ty)]+                [mkComp fd_name CompletionItemKind_Variable (Just $ showForSnippet fd_sig_ty)]             _ -> []             | L (locA -> pos) decl <- hsmodDecls,             let mkComp = mkLocalComp pos         ]      mkLocalComp pos n ctyp ty =-        CI ctyp pn (Local pos) pn ty Nothing (ctyp `elem` [CiStruct, CiInterface]) Nothing (Just $ NameDetails (ms_mod $ pm_mod_summary pm) occ) True+        CI ctyp pn (Local pos) pn ty Nothing (ctyp `elem` [CompletionItemKind_Struct, CompletionItemKind_Interface]) Nothing (Just $ NameDetails (ms_mod $ pm_mod_summary pm) occ) True       where         occ = rdrNameOcc $ unLoc n         pn = showForSnippet n@@ -520,7 +529,7 @@   removeSnippetsWhen (not $ enableSnippets && supported)   where     supported =-      Just True == (_textDocument >>= _completion >>= _completionItem >>= _snippetSupport)+      Just True == (_textDocument >>= _completion >>= view L.completionItem >>= (\x -> x .! #snippetSupport))  toggleAutoExtend :: CompletionsConfig -> CompItem -> CompItem toggleAutoExtend CompletionsConfig{enableAutoExtend=False} x = x {additionalTextEdits = Nothing}@@ -531,7 +540,7 @@   if condition     then       x-        { _insertTextFormat = Just PlainText,+        { _insertTextFormat = Just InsertTextFormat_PlainText,           _insertText = Nothing         }     else x@@ -613,7 +622,7 @@               -- to get the record's module, which isn't included in the type information used to get the fields.               dotFieldSelectorToCompl :: T.Text -> T.Text -> (Bool, CompItem)               dotFieldSelectorToCompl recname label = (True, CI-                { compKind = CiField+                { compKind = CompletionItemKind_Field                 , insertText = label                 , provenance = DefinedIn recname                 , label = label@@ -790,7 +799,7 @@ mkRecordSnippetCompItem uri parent ctxStr compl importedFrom imp = r   where       r  = CI {-            compKind = CiSnippet+            compKind = CompletionItemKind_Snippet           , insertText = buildSnippet           , provenance = importedFrom           , typeText = Nothing

@@ -1,9 +1,9 @@+{-# LANGUAGE CPP                #-} {-# LANGUAGE DeriveAnyClass     #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GADTs              #-} {-# LANGUAGE OverloadedLabels   #-} {-# LANGUAGE TypeFamilies       #-}-{-# LANGUAGE CPP                #-} module Development.IDE.Plugin.Completions.Types (   module Development.IDE.Plugin.Completions.Types ) where@@ -22,12 +22,12 @@ import           Development.IDE.Spans.Common import           GHC.Generics                 (Generic) import           Ide.Plugin.Properties-import           Language.LSP.Types           (CompletionItemKind (..), Uri)-import qualified Language.LSP.Types           as J+import           Language.LSP.Protocol.Types  (CompletionItemKind (..), Uri)+import qualified Language.LSP.Protocol.Types  as J #if MIN_VERSION_ghc(9,0,0)-import qualified GHC.Types.Name.Occurrence as Occ+import qualified GHC.Types.Name.Occurrence    as Occ #else-import qualified OccName as Occ+import qualified OccName                      as Occ #endif  -- | Produce completions info for a file@@ -178,7 +178,7 @@ parseNs (String "c") = pure dataName parseNs (String "t") = pure tcClsName parseNs (String "z") = pure tvName-parseNs _ = mempty+parseNs _            = mempty  instance FromJSON NameDetails where   parseJSON v@(Array _)@@ -204,9 +204,9 @@ -- We need the URI to be able to reconstruct the GHC environment -- in the file the completion was triggered in. data CompletionResolveData = CompletionResolveData-  { itemFile :: Uri+  { itemFile      :: Uri   , itemNeedsType :: Bool -- ^ Do we need to lookup a type for this item?-  , itemName :: NameDetails+  , itemName      :: NameDetails   }   deriving stock Generic   deriving anyclass (FromJSON, ToJSON)

@@ -6,75 +6,92 @@ module Development.IDE.Plugin.HLS     (       asGhcIdePlugin+    , toResponseError     , Log(..)     ) where -import           Control.Exception            (SomeException)-import           Control.Lens                 ((^.))+import           Control.Exception             (SomeException)+import           Control.Lens                  ((^.)) import           Control.Monad-import qualified Data.Aeson                   as J-import           Data.Bifunctor               (first)-import           Data.Dependent.Map           (DMap)-import qualified Data.Dependent.Map           as DMap+import           Control.Monad.Trans.Except    (runExceptT)+import qualified Data.Aeson                    as A+import           Data.Bifunctor                (first)+import           Data.Dependent.Map            (DMap)+import qualified Data.Dependent.Map            as DMap import           Data.Dependent.Sum import           Data.Either-import qualified Data.List                    as List-import           Data.List.NonEmpty           (NonEmpty, nonEmpty, toList)-import qualified Data.List.NonEmpty           as NE-import qualified Data.Map                     as Map+import qualified Data.List                     as List+import           Data.List.NonEmpty            (NonEmpty, nonEmpty, toList)+import qualified Data.List.NonEmpty            as NE+import qualified Data.Map                      as Map import           Data.Some import           Data.String-import           Data.Text                    (Text)-import qualified Data.Text                    as T-import           Development.IDE.Core.Shake   hiding (Log)+import           Data.Text                     (Text)+import qualified Data.Text                     as T+import           Development.IDE.Core.Shake    hiding (Log) import           Development.IDE.Core.Tracing-import           Development.IDE.Graph        (Rules)+import           Development.IDE.Graph         (Rules) import           Development.IDE.LSP.Server import           Development.IDE.Plugin-import qualified Development.IDE.Plugin       as P-import           Development.IDE.Types.Logger+import qualified Development.IDE.Plugin        as P+import           Ide.Logger import           Ide.Plugin.Config-import           Ide.PluginUtils              (getClientConfig)-import           Ide.Types                    as HLS-import qualified Language.LSP.Server          as LSP-import           Language.LSP.Types-import qualified Language.LSP.Types           as J-import qualified Language.LSP.Types.Lens      as LSP+import           Ide.Plugin.Error+import           Ide.PluginUtils               (getClientConfig)+import           Ide.Types                     as HLS+import qualified Language.LSP.Protocol.Lens    as L+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types+import qualified Language.LSP.Server           as LSP import           Language.LSP.VFS-import           Prettyprinter.Render.String  (renderString)-import           Text.Regex.TDFA.Text         ()-import           UnliftIO                     (MonadUnliftIO)-import           UnliftIO.Async               (forConcurrently)-import           UnliftIO.Exception           (catchAny)+import           Prettyprinter.Render.String   (renderString)+import           Text.Regex.TDFA.Text          ()+import           UnliftIO                      (MonadUnliftIO, liftIO)+import           UnliftIO.Async                (forConcurrently)+import           UnliftIO.Exception            (catchAny)  -- --------------------------------------------------------------------- --  data Log-    = LogPluginError PluginId ResponseError+    =  LogPluginError PluginId PluginError+    | LogResponseError PluginId ResponseError     | LogNoPluginForMethod (Some SMethod)     | LogInvalidCommandIdentifier+    | ExceptionInPlugin PluginId (Some SMethod) SomeException+ instance Pretty Log where   pretty = \case-    LogPluginError (PluginId pId) err -> pretty pId <> ":" <+> prettyResponseError err+    LogPluginError (PluginId pId) err ->+      pretty pId <> ":" <+> pretty err+    LogResponseError (PluginId pId) err ->+      pretty pId <> ":" <+> prettyResponseError err     LogNoPluginForMethod (Some method) ->         "No plugin enabled for " <> pretty (show method)     LogInvalidCommandIdentifier-> "Invalid command identifier"-+    ExceptionInPlugin plId (Some method) exception ->+        "Exception in plugin " <> viaShow plId <> " while processing "+          <> viaShow method <> ": " <> viaShow exception instance Show Log where show = renderString . layoutCompact . pretty  -- various error message specific builders prettyResponseError :: ResponseError -> Doc a prettyResponseError err = errorCode <> ":" <+> errorBody     where-        errorCode = pretty $ show $ err ^. LSP.code-        errorBody = pretty $ err ^. LSP.message--pluginNotEnabled :: SMethod m -> [(PluginId, b, a)] -> Text-pluginNotEnabled method availPlugins =-    "No plugin enabled for " <> T.pack (show method) <> ", available: "-        <> (T.intercalate ", " $ map (\(PluginId plid, _, _) -> plid) availPlugins)+        errorCode = pretty $ show $ err ^. L.code+        errorBody = pretty $ err ^. L.message +noPluginEnabled :: Recorder (WithPriority Log) -> SMethod m -> [PluginId] -> IO (Either ResponseError c)+noPluginEnabled recorder m fs' = do+  logWith recorder Warning (LogNoPluginForMethod $ Some m)+  let err = ResponseError (InR ErrorCodes_MethodNotFound) msg Nothing+      msg = pluginNotEnabled m fs'+  return $ Left err+  where pluginNotEnabled :: SMethod m -> [PluginId] -> Text+        pluginNotEnabled method availPlugins =+            "No plugin enabled for " <> T.pack (show method) <> ", potentially available: "+                <> (T.intercalate ", " $ map (\(PluginId plid) -> plid) availPlugins)+   pluginDoesntExist :: PluginId -> Text pluginDoesntExist (PluginId pid) = "Plugin " <> pid <> " doesn't exist" @@ -86,17 +103,21 @@ failedToParseArgs :: CommandId  -- ^ command that failed to parse                     -> PluginId -- ^ Plugin that created the command                     -> String   -- ^ The JSON Error message-                    -> J.Value  -- ^ The Argument Values+                    -> A.Value  -- ^ The Argument Values                     -> Text failedToParseArgs (CommandId com) (PluginId pid) err arg =     "Error while parsing args for " <> com <> " in plugin " <> pid <> ": "         <> T.pack err <> ", arg = " <> T.pack (show arg) +exceptionInPlugin :: PluginId -> SMethod m -> SomeException -> Text+exceptionInPlugin plId method exception =+    "Exception in plugin " <> T.pack (show plId) <> " while processing "<> T.pack (show method) <> ": " <> T.pack (show exception)+ -- | Build a ResponseError and log it before returning to the caller-logAndReturnError :: Recorder (WithPriority Log) -> PluginId -> ErrorCode -> Text -> LSP.LspT Config IO (Either ResponseError a)+logAndReturnError :: Recorder (WithPriority Log) -> PluginId -> (LSPErrorCodes |? ErrorCodes) -> Text -> LSP.LspT Config IO (Either ResponseError a) logAndReturnError recorder p errCode msg = do     let err = ResponseError errCode msg Nothing-    logWith recorder Warning $ LogPluginError p err+    logWith recorder Warning $ LogResponseError p err     pure $ Left err  -- | Map a set of plugins to the underlying ghcide engine.@@ -146,7 +167,7 @@ executeCommandPlugins recorder ecs = mempty { P.pluginHandlers = executeCommandHandlers recorder ecs }  executeCommandHandlers :: Recorder (WithPriority Log) -> [(PluginId, [PluginCommand IdeState])] -> LSP.Handlers (ServerM Config)-executeCommandHandlers recorder ecs = requestHandler SWorkspaceExecuteCommand execCmd+executeCommandHandlers recorder ecs = requestHandler SMethod_WorkspaceExecuteCommand execCmd   where     pluginMap = Map.fromListWith (++) ecs @@ -157,29 +178,29 @@       _                    -> Nothing      -- The parameters to the HLS command are always the first element-+    execCmd :: IdeState -> ExecuteCommandParams -> LSP.LspT Config IO (Either ResponseError (A.Value |? Null))     execCmd ide (ExecuteCommandParams _ cmdId args) = do-      let cmdParams :: J.Value+      let cmdParams :: A.Value           cmdParams = case args of-            Just (J.List (x:_)) -> x-            _                   -> J.Null+            Just ((x:_)) -> x+            _            -> A.Null       case parseCmdId cmdId of         -- Shortcut for immediately applying a applyWorkspaceEdit as a fallback for v3.8 code actions         Just ("hls", "fallbackCodeAction") ->-          case J.fromJSON cmdParams of-            J.Success (FallbackCodeActionParams mEdit mCmd) -> do+          case A.fromJSON cmdParams of+            A.Success (FallbackCodeActionParams mEdit mCmd) -> do                -- Send off the workspace request if it has one               forM_ mEdit $ \edit ->-                LSP.sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ())+                LSP.sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ())                case mCmd of                 -- If we have a command, continue to execute it-                Just (J.Command _ innerCmdId innerArgs)+                Just (Command _ innerCmdId innerArgs)                     -> execCmd ide (ExecuteCommandParams Nothing innerCmdId innerArgs)-                Nothing -> return $ Right J.Null+                Nothing -> return $ Right $ InR Null -            J.Error _str -> return $ Right J.Null+            A.Error _str -> return $ Right $ InR Null          -- Just an ordinary HIE command         Just (plugin, cmd) -> runPluginCommand ide plugin cmd cmdParams@@ -187,16 +208,26 @@         -- Couldn't parse the command identifier         _ -> do             logWith recorder Warning LogInvalidCommandIdentifier-            return $ Left $ ResponseError InvalidParams "Invalid command identifier" Nothing+            return $ Left $ ResponseError (InR ErrorCodes_InvalidParams) "Invalid command identifier" Nothing +    runPluginCommand :: IdeState -> PluginId -> CommandId -> A.Value -> LSP.LspT Config IO (Either ResponseError (A.Value |? Null))     runPluginCommand ide p com arg =       case Map.lookup p pluginMap  of-        Nothing -> logAndReturnError recorder p InvalidRequest (pluginDoesntExist p)+        Nothing -> logAndReturnError recorder p (InR ErrorCodes_InvalidRequest) (pluginDoesntExist p)         Just xs -> case List.find ((com ==) . commandId) xs of-          Nothing -> logAndReturnError recorder p InvalidRequest (commandDoesntExist com p xs)-          Just (PluginCommand _ _ f) -> case J.fromJSON arg of-            J.Error err -> logAndReturnError recorder p InvalidParams (failedToParseArgs com p err arg)-            J.Success a -> f ide a+          Nothing -> logAndReturnError recorder p (InR ErrorCodes_InvalidRequest) (commandDoesntExist com p xs)+          Just (PluginCommand _ _ f) -> case A.fromJSON arg of+            A.Error err -> logAndReturnError recorder p (InR ErrorCodes_InvalidParams) (failedToParseArgs com p err arg)+            A.Success a -> do+              res <- runExceptT (f ide a) `catchAny` -- See Note [Exception handling in plugins]+                (\e -> pure $ Left $ PluginInternalError (exceptionInPlugin p SMethod_WorkspaceExecuteCommand e))+              case res of+                (Left (PluginRequestRefused _)) ->+                  liftIO $ noPluginEnabled recorder SMethod_WorkspaceExecuteCommand (fst <$> ecs)+                (Left pluginErr) -> do+                  liftIO $ logErrors recorder [(p, pluginErr)]+                  pure $ Left $ toResponseError (p, pluginErr)+                (Right result) -> pure $ Right result  -- --------------------------------------------------------------------- @@ -218,25 +249,25 @@         let fs = filter (\(_, desc, _) -> pluginEnabled m params desc config) fs'         -- Clients generally don't display ResponseErrors so instead we log any that we come across         case nonEmpty fs of-          Nothing -> do-            logWith recorder Warning (LogNoPluginForMethod $ Some m)-            let err = ResponseError InvalidRequest msg Nothing-                msg = pluginNotEnabled m fs'-            return $ Left err+          Nothing -> liftIO $ noPluginEnabled recorder m ((\(x, _, _) -> x) <$> fs')           Just fs -> do-            let msg e pid = "Exception in plugin " <> T.pack (show pid) <> " while processing " <> T.pack (show m) <> ": " <> T.pack (show e)-                handlers = fmap (\(plid,_,handler) -> (plid,handler)) fs-            es <- runConcurrently msg (show m) handlers ide params-+            let  handlers = fmap (\(plid,_,handler) -> (plid,handler)) fs+            es <- runConcurrently exceptionInPlugin m handlers ide params+            caps <- LSP.getClientCapabilities             let (errs,succs) = partitionEithers $ toList $ join $ NE.zipWith (\(pId,_) -> fmap (first (pId,))) handlers es-            unless (null errs) $ forM_ errs $ \(pId, err) ->-                logWith recorder Warning $ LogPluginError pId err+            liftIO $ unless (null errs) $ logErrors recorder errs             case nonEmpty succs of-              Nothing -> pure $ Left $ combineErrors $ map snd errs+              Nothing -> do+                let noRefused (_, PluginRequestRefused _) = False+                    noRefused (_, _)                      = True+                    filteredErrs = filter noRefused errs+                case nonEmpty filteredErrs of+                  Nothing -> liftIO $ noPluginEnabled recorder m ((\(x, _, _) -> x) <$> fs')+                  Just xs -> pure $ Left $ combineErrors xs               Just xs -> do-                caps <- LSP.getClientCapabilities                 pure $ Right $ combineResponses m config caps params xs + -- ---------------------------------------------------------------------  extensibleNotificationPlugins :: Recorder (WithPriority Log) -> [(PluginId, PluginDescriptor IdeState)] -> Plugin Config@@ -260,35 +291,51 @@           Just fs -> do             -- We run the notifications in order, so the core ghcide provider             -- (which restarts the shake process) hopefully comes last-            mapM_ (\(pid,_,f) -> otTracedProvider pid (fromString $ show m) $ f ide vfs params) fs+            mapM_ (\(pid,_,f) -> otTracedProvider pid (fromString $ show m) $ f ide vfs params+                                    `catchAny` -- See Note [Exception handling in plugins]+                                    (\e -> logWith recorder Warning (ExceptionInPlugin pid (Some m) e))) fs + -- ---------------------------------------------------------------------  runConcurrently   :: MonadUnliftIO m-  => (SomeException -> PluginId -> T.Text)-  -> String -- ^ label-  -> NonEmpty (PluginId, a -> b -> m (NonEmpty (Either ResponseError d)))+  => (PluginId -> SMethod method -> SomeException -> T.Text)+  -> SMethod method -- ^ Method (used for errors and tracing)+  -> NonEmpty (PluginId, a -> b -> m (NonEmpty (Either PluginError d)))   -- ^ Enabled plugin actions that we are allowed to run   -> a   -> b-  -> m (NonEmpty(NonEmpty (Either ResponseError d)))-runConcurrently msg method fs a b = forConcurrently fs $ \(pid,f) -> otTracedProvider pid (fromString method) $ do-  f a b-     `catchAny` (\e -> pure $ pure $ Left $ ResponseError InternalError (msg e pid) Nothing)+  -> m (NonEmpty(NonEmpty (Either PluginError d)))+runConcurrently msg method fs a b = forConcurrently fs $ \(pid,f) -> otTracedProvider pid (fromString (show method)) $ do+  f a b  -- See Note [Exception handling in plugins]+     `catchAny` (\e -> pure $ pure $ Left $ PluginInternalError (msg pid method e)) -combineErrors :: [ResponseError] -> ResponseError-combineErrors [x] = x-combineErrors xs  = ResponseError InternalError (T.pack (show xs)) Nothing+combineErrors :: NonEmpty (PluginId, PluginError) -> ResponseError+combineErrors (x NE.:| []) = toResponseError x+combineErrors xs = toResponseError $ NE.last $ NE.sortWith (toPriority . snd) xs +toResponseError :: (PluginId, PluginError) -> ResponseError+toResponseError (PluginId plId, err) =+        ResponseError (toErrorCode err) (plId <> ": " <> tPretty err) Nothing+    where tPretty = T.pack . show . pretty++logErrors :: Recorder (WithPriority Log) -> [(PluginId, PluginError)] -> IO ()+logErrors recorder errs = do+  forM_ errs $ \(pId, err) ->+                logIndividualErrors pId err+  where logIndividualErrors plId err =+          logWith recorder (toPriority err) $ LogPluginError plId err++ -- | Combine the 'PluginHandler' for all plugins-newtype IdeHandler (m :: J.Method FromClient Request)-  = IdeHandler [(PluginId, PluginDescriptor IdeState, IdeState -> MessageParams m -> LSP.LspM Config (NonEmpty (Either ResponseError (ResponseResult m))))]+newtype IdeHandler (m :: Method ClientToServer Request)+  = IdeHandler [(PluginId, PluginDescriptor IdeState, IdeState -> MessageParams m -> LSP.LspM Config (NonEmpty (Either PluginError (MessageResult m))))]  -- | Combine the 'PluginHandler' for all plugins-newtype IdeNotificationHandler (m :: J.Method FromClient Notification)+newtype IdeNotificationHandler (m :: Method ClientToServer Notification)   = IdeNotificationHandler [(PluginId, PluginDescriptor IdeState, IdeState -> VFS -> MessageParams m -> LSP.LspM Config ())]--- type NotificationHandler (m :: Method FromClient Notification) = MessageParams m -> IO ()`+-- type NotificationHandler (m :: Method ClientToServer Notification) = MessageParams m -> IO ()`  -- | Combine the 'PluginHandlers' for all plugins newtype IdeHandlers             = IdeHandlers             (DMap IdeMethod       IdeHandler)@@ -307,3 +354,16 @@       go _ (IdeNotificationHandler a) (IdeNotificationHandler b) = IdeNotificationHandler (a <> b) instance Monoid IdeNotificationHandlers where   mempty = IdeNotificationHandlers mempty++{- Note [Exception handling in plugins]+Plugins run in LspM, and so have access to IO. This means they are likely to+throw exceptions, even if only by accident or through calling libraries that+throw exceptions. Ultimately, we're running a bunch of less-trusted IO code,+so we should be robust to it throwing.++We don't want these to bring down HLS. So we catch and log exceptions wherever+we run a handler defined in a plugin.++The flip side of this is that it's okay for plugins to throw exceptions as a+way of signalling failure!+-}

@@ -15,8 +15,8 @@ import qualified Development.IDE.Plugin.Completions  as Completions import qualified Development.IDE.Plugin.TypeLenses   as TypeLenses import           Ide.Types-import           Language.LSP.Server                 (LspM)-import           Language.LSP.Types+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types import           Text.Regex.TDFA.Text                ()  data Log@@ -43,29 +43,23 @@  descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId)-  { pluginHandlers = mkPluginHandler STextDocumentHover hover'-                  <> mkPluginHandler STextDocumentDocumentSymbol symbolsProvider-                  <> mkPluginHandler STextDocumentDefinition (\ide _ DefinitionParams{..} ->+  { pluginHandlers = mkPluginHandler SMethod_TextDocumentHover hover'+                  <> mkPluginHandler SMethod_TextDocumentDocumentSymbol moduleOutline+                  <> mkPluginHandler SMethod_TextDocumentDefinition (\ide _ DefinitionParams{..} ->                       gotoDefinition ide TextDocumentPositionParams{..})-                  <> mkPluginHandler STextDocumentTypeDefinition (\ide _ TypeDefinitionParams{..} ->+                  <> mkPluginHandler SMethod_TextDocumentTypeDefinition (\ide _ TypeDefinitionParams{..} ->                       gotoTypeDefinition ide TextDocumentPositionParams{..})-                  <> mkPluginHandler STextDocumentDocumentHighlight (\ide _ DocumentHighlightParams{..} ->+                  <> mkPluginHandler SMethod_TextDocumentDocumentHighlight (\ide _ DocumentHighlightParams{..} ->                       documentHighlight ide TextDocumentPositionParams{..})-                  <> mkPluginHandler STextDocumentReferences (\ide _ params -> references ide params)-                  <> mkPluginHandler SWorkspaceSymbol (\ide _ params -> wsSymbols ide params),+                  <> mkPluginHandler SMethod_TextDocumentReferences references+                  <> mkPluginHandler SMethod_WorkspaceSymbol wsSymbols,      pluginConfigDescriptor = defaultConfigDescriptor   }  -- --------------------------------------------------------------------- -hover' :: IdeState -> PluginId -> HoverParams  -> LspM c (Either ResponseError (Maybe Hover))+hover' :: PluginMethodHandler IdeState 'Method_TextDocumentHover hover' ideState _ HoverParams{..} = do     liftIO $ logDebug (ideLogger ideState) "GhcIde.hover entered (ideLogger)" -- AZ     hover ideState TextDocumentPositionParams{..}---- ----------------------------------------------------------------------symbolsProvider :: IdeState -> PluginId -> DocumentSymbolParams -> LspM c (Either ResponseError (List DocumentSymbol |? List SymbolInformation))-symbolsProvider ide _ params = moduleOutline ide params---- ---------------------------------------------------------------------

@@ -14,14 +14,18 @@  import           Control.Concurrent                   (threadDelay) import           Control.Monad+import           Control.Monad.Except                 (ExceptT (..), throwError) import           Control.Monad.IO.Class import           Control.Monad.STM-import           Data.Aeson-import           Data.Aeson.Types+import           Control.Monad.Trans.Class            (MonadTrans (lift))+import           Data.Aeson                           (FromJSON (parseJSON),+                                                       ToJSON (toJSON), Value)+import qualified Data.Aeson.Types                     as A import           Data.Bifunctor import           Data.CaseInsensitive                 (CI, original) import qualified Data.HashMap.Strict                  as HM import           Data.Maybe                           (isJust)+import           Data.Proxy import           Data.String import           Data.Text                            (Text, pack) import           Development.IDE.Core.OfInterest      (getFilesOfInterest)@@ -43,9 +47,11 @@ import           Development.IDE.Types.Location       (fromUri) import           GHC.Generics                         (Generic) import           Ide.Plugin.Config                    (CheckParents)+import           Ide.Plugin.Error import           Ide.Types+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types import qualified Language.LSP.Server                  as LSP-import           Language.LSP.Types import qualified "list-t" ListT import qualified StmContainers.Map                    as STM import           System.Time.Extra@@ -73,26 +79,26 @@  plugin :: PluginDescriptor IdeState plugin = (defaultPluginDescriptor "test") {-    pluginHandlers = mkPluginHandler (SCustomMethod "test") $ \st _ ->+    pluginHandlers = mkPluginHandler (SMethod_CustomMethod (Proxy @"test")) $ \st _ ->         testRequestHandler' st     }   where       testRequestHandler' ide req-        | Just customReq <- parseMaybe parseJSON req-        = testRequestHandler ide customReq+        | Just customReq <- A.parseMaybe parseJSON req+        = ExceptT $ testRequestHandler ide customReq         | otherwise-        = return $ Left-        $ ResponseError InvalidRequest "Cannot parse request" Nothing+        = throwError+        $ PluginInvalidParams "Cannot parse request"   testRequestHandler ::  IdeState                 -> TestRequest-                -> LSP.LspM c (Either ResponseError Value)+                -> LSP.LspM c (Either PluginError Value) testRequestHandler _ (BlockSeconds secs) = do-    LSP.sendNotification (SCustomMethod "ghcide/blocking/request") $+    LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/blocking/request")) $       toJSON secs     liftIO $ sleep secs-    return (Right Null)+    return (Right A.Null) testRequestHandler s (GetInterfaceFilesDir file) = liftIO $ do     let nfp = fromUri $ toNormalizedUri file     sess <- runAction "Test - GhcSession" s $ use_ GhcSession nfp@@ -105,12 +111,12 @@     atomically $ do         n <- countQueue $ actionQueue $ shakeExtras s         when (n>0) retry-    return $ Right Null+    return $ Right A.Null testRequestHandler s (WaitForIdeRule k file) = liftIO $ do     let nfp = fromUri $ toNormalizedUri file     success <- runAction ("WaitForIdeRule " <> k <> " " <> show file) s $ parseAction (fromString k) nfp     let res = WaitForIdeRuleResult <$> success-    return $ bimap mkResponseError toJSON res+    return $ bimap PluginInvalidParams toJSON res testRequestHandler s GetBuildKeysBuilt = liftIO $ do     keys <- getDatabaseKeys resultBuilt $ shakeDb s     return $ Right $ toJSON $ map show keys@@ -144,9 +150,6 @@     step <- shakeGetBuildStep db     return [ k | (k, res) <- keys, field res == Step step] -mkResponseError :: Text -> ResponseError-mkResponseError msg = ResponseError InvalidRequest msg Nothing- parseAction :: CI String -> NormalizedFilePath -> Action (Either Text Bool) parseAction "typecheck" fp = Right . isJust <$> use TypeCheck fp parseAction "getLocatedImports" fp = Right . isJust <$> use GetLocatedImports fp@@ -170,6 +173,6 @@  blockCommandHandler :: CommandFunction state ExecuteCommandParams blockCommandHandler _ideState _params = do-  LSP.sendNotification (SCustomMethod "ghcide/blocking/command") Null+  lift $ LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/blocking/command")) A.Null   liftIO $ threadDelay maxBound-  return (Right Null)+  pure $ InR Null

@@ -18,19 +18,20 @@ import           Control.Monad                        (mzero) import           Control.Monad.Extra                  (whenMaybe) import           Control.Monad.IO.Class               (MonadIO (liftIO))-import           Data.Aeson.Types                     (Value (..), toJSON)+import           Control.Monad.Trans.Class            (MonadTrans (lift))+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 qualified Data.Map                             as Map import           Data.Maybe                           (catMaybes, mapMaybe) import qualified Data.Text                            as T import           Development.IDE                      (GhcSession (..),                                                        HscEnvEq (hscEnv),                                                        RuleResult, Rules,                                                        define, srcSpanToRange,-                                                       usePropertyAction,-                                                       useWithStale)+                                                       usePropertyAction) import           Development.IDE.Core.Compile         (TcModuleResult (..))+import           Development.IDE.Core.PluginUtils import           Development.IDE.Core.PositionMapping (PositionMapping,                                                        toCurrentRange) import           Development.IDE.Core.Rules           (IdeState, runAction)@@ -46,12 +47,13 @@ import           Development.IDE.Spans.LocalBindings  (Bindings, getFuzzyScope) import           Development.IDE.Types.Location       (Position (Position, _character, _line),                                                        Range (Range, _end, _start))-import           Development.IDE.Types.Logger         (Pretty (pretty),+import           GHC.Generics                         (Generic)+import           Ide.Logger                           (Pretty (pretty),                                                        Recorder, WithPriority,                                                        cmapWithPrio)-import           GHC.Generics                         (Generic)+import           Ide.Plugin.Error import           Ide.Plugin.Properties-import           Ide.PluginUtils+import           Ide.PluginUtils                      (mkLspCommand) import           Ide.Types                            (CommandFunction,                                                        CommandId (CommandId),                                                        PluginCommand (PluginCommand),@@ -63,17 +65,18 @@                                                        defaultPluginDescriptor,                                                        mkCustomConfig,                                                        mkPluginHandler)-import qualified Language.LSP.Server                  as LSP-import           Language.LSP.Types                   (ApplyWorkspaceEditParams (ApplyWorkspaceEditParams),+import           Language.LSP.Protocol.Message        (Method (Method_TextDocumentCodeLens),+                                                       SMethod (..))+import           Language.LSP.Protocol.Types          (ApplyWorkspaceEditParams (ApplyWorkspaceEditParams),                                                        CodeLens (CodeLens),                                                        CodeLensParams (CodeLensParams, _textDocument),                                                        Diagnostic (..),-                                                       List (..),-                                                       Method (TextDocumentCodeLens),-                                                       SMethod (..),+                                                       Null (Null),                                                        TextDocumentIdentifier (TextDocumentIdentifier),                                                        TextEdit (TextEdit),-                                                       WorkspaceEdit (WorkspaceEdit))+                                                       WorkspaceEdit (WorkspaceEdit),+                                                       type (|?) (..))+import qualified Language.LSP.Server                  as LSP import           Text.Regex.TDFA                      ((=~), (=~~))  data Log = LogShake Shake.Log deriving Show@@ -88,7 +91,7 @@ descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId =   (defaultPluginDescriptor plId)-    { pluginHandlers = mkPluginHandler STextDocumentCodeLens codeLensProvider+    { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeLens codeLensProvider     , pluginCommands = [PluginCommand (CommandId typeLensCommandId) "adds a signature" commandHandler]     , pluginRules = rules recorder     , pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties}@@ -102,34 +105,28 @@     , (Diagnostics, "Follows error messages produced by GHC about missing signatures")     ] Always -codeLensProvider :: PluginMethodHandler IdeState TextDocumentCodeLens-codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentifier uri} = pluginResponse $ do+codeLensProvider :: PluginMethodHandler IdeState Method_TextDocumentCodeLens+codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentifier uri} = do     mode <- liftIO $ runAction "codeLens.config" ideState $ usePropertyAction #mode pId properties-    nfp <- getNormalizedFilePath uri-    env <- hscEnv . fst-            <$> (handleMaybeM "Unable to get GhcSession"-                $ liftIO-                $ runAction "codeLens.GhcSession" ideState (useWithStale GhcSession nfp)-                )-    tmr <- fst <$> (-                handleMaybeM "Unable to TypeCheck"-              $ liftIO-              $ runAction "codeLens.TypeCheck" ideState (useWithStale TypeCheck nfp)-              )-    bindings <- fst <$> (-                handleMaybeM "Unable to GetBindings"-                $ liftIO-                $ runAction "codeLens.GetBindings" ideState (useWithStale GetBindings nfp)-                )+    nfp <- getNormalizedFilePathE uri+    env <- hscEnv . fst <$>+      runActionE "codeLens.GhcSession" ideState+        (useWithStaleE GhcSession nfp)++    (tmr, _) <- runActionE "codeLens.TypeCheck" ideState+      (useWithStaleE TypeCheck nfp)++    (bindings, _) <- runActionE "codeLens.GetBindings" ideState+      (useWithStaleE GetBindings nfp)+     (gblSigs@(GlobalBindingTypeSigsResult gblSigs'), gblSigsMp) <--      handleMaybeM "Unable to GetGlobalBindingTypeSigs"-      $ liftIO-      $ runAction "codeLens.GetGlobalBindingTypeSigs" ideState (useWithStale GetGlobalBindingTypeSigs nfp)+      runActionE "codeLens.GetGlobalBindingTypeSigs" ideState+        (useWithStaleE GetGlobalBindingTypeSigs nfp)      diag <- liftIO $ atomically $ getDiagnostics ideState     hDiag <- liftIO $ atomically $ getHiddenDiagnostics ideState -    let toWorkSpaceEdit tedit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing Nothing+    let toWorkSpaceEdit tedit = WorkspaceEdit (Just $ Map.singleton uri $ tedit) Nothing Nothing         generateLensForGlobal mp sig@GlobalBindingTypeSig{gbRendered} = do             range <- toCurrentRange mp =<< srcSpanToRange (gbSrcSpan sig)             tedit <- gblBindingTypeSigToEdit sig (Just gblSigsMp)@@ -144,7 +141,7 @@               ]     -- `suggestLocalSignature` relies on diagnostic, if diagnostics don't have the local signature warning,     -- the `bindings` is useless, and if diagnostic has, that means we parsed success, and the `bindings` is fresh.-    pure $ List $ case mode of+    pure $ InL $ case mode of         Always ->           mapMaybe (generateLensForGlobal gblSigsMp) gblSigs'             <> generateLensFromDiags@@ -160,8 +157,8 @@  commandHandler :: CommandFunction IdeState WorkspaceEdit commandHandler _ideState wedit = do-  _ <- LSP.sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ())-  return $ Right Null+  _ <- lift $ LSP.sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ())+  pure $ InR Null  -------------------------------------------------------------------------------- 

@@ -1,9 +1,10 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE CPP        #-}-{-# LANGUAGE GADTs      #-}-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}  -- | Gives information about symbols at a given point in DAML files. -- These are all pure functions that should execute quickly.@@ -27,7 +28,8 @@ import           Development.IDE.GHC.Error import           Development.IDE.GHC.Orphans          () import           Development.IDE.Types.Location-import           Language.LSP.Types+import           Language.LSP.Protocol.Types          hiding+                                                      (SemanticTokenAbsolute (..))  -- compiler and infrastructure import           Development.IDE.Core.PositionMapping@@ -178,8 +180,8 @@       DocumentHighlight (realSrcSpanToRange sp) (Just $ highlightType $ identInfo dets)     highlightType s =       if any (isJust . getScopeFromContext) s-        then HkWrite-        else HkRead+        then DocumentHighlightKind_Write+        else DocumentHighlightKind_Read  gotoTypeDefinition   :: MonadIO m@@ -212,21 +214,33 @@   -> DocAndKindMap   -> HscEnv   -> Position-  -> Maybe (Maybe Range, [T.Text])-atPoint IdeOptions{} (HAR _ hf _ _ kind) (DKMap dm km) env pos = listToMaybe $ pointCommand hf pos hoverInfo+  -> IO (Maybe (Maybe Range, [T.Text]))+atPoint IdeOptions{} (HAR _ hf _ _ (kind :: HieKind hietype)) (DKMap dm km) env pos =+    listToMaybe <$> sequence (pointCommand hf pos hoverInfo)   where     -- Hover info for values/data-    hoverInfo ast = (Just range, prettyNames ++ pTypes)+    hoverInfo :: HieAST hietype -> IO (Maybe Range, [T.Text])+    hoverInfo ast = do+        prettyNames <- mapM prettyName filteredNames+        pure (Just range, prettyNames ++ pTypes)       where+        pTypes :: [T.Text]         pTypes           | Prelude.length names == 1 = dropEnd1 $ map wrapHaskell prettyTypes           | otherwise = map wrapHaskell prettyTypes +        range :: Range         range = realSrcSpanToRange $ nodeSpan ast +        wrapHaskell :: T.Text -> T.Text         wrapHaskell x = "\n```haskell\n"<>x<>"\n```\n"++        info :: NodeInfo hietype         info = nodeInfoH kind ast++        names :: [(Identifier, IdentifierDetails hietype)]         names = M.assocs $ nodeIdentifiers info+         -- Check for evidence bindings         isInternal :: (Identifier, IdentifierDetails a) -> Bool         isInternal (Right _, dets) =@@ -236,11 +250,12 @@           False #endif         isInternal (Left _, _) = False++        filteredNames :: [(Identifier, IdentifierDetails hietype)]         filteredNames = filter (not . isInternal) names-        types = nodeType info-        prettyNames :: [T.Text]-        prettyNames = map prettyName filteredNames-        prettyName (Right n, dets) = T.unlines $++        prettyName :: (Either ModuleName Name, IdentifierDetails hietype) -> IO T.Text+        prettyName (Right n, dets) = pure $ T.unlines $           wrapHaskell (printOutputable n <> maybe "" (" :: " <>) ((prettyType <$> identType dets) <|> maybeKind))           : maybeToList (pretty (definedAt n) (prettyPackageName n))           ++ catMaybes [ T.unlines . spanDocToMarkdown <$> lookupNameEnv dm n@@ -250,21 +265,48 @@                 pretty (Just define) Nothing = Just $ define <> "\n"                 pretty Nothing (Just pkgName) = Just $ pkgName <> "\n"                 pretty (Just define) (Just pkgName) = Just $ define <> " " <> pkgName <> "\n"-        prettyName (Left m,_) = printOutputable m+        prettyName (Left m,_) = packageNameForImportStatement m +        prettyPackageName :: Name -> Maybe T.Text         prettyPackageName n = do           m <- nameModule_maybe n+          pkgTxt <- packageNameWithVersion m env+          pure $ "*(" <> pkgTxt <> ")*"++        -- Return the module text itself and+        -- the package(with version) this `ModuleName` belongs to.+        packageNameForImportStatement :: ModuleName -> IO T.Text+        packageNameForImportStatement mod = do+          mpkg <- findImportedModule env mod :: IO (Maybe Module)+          let moduleName = printOutputable mod+          case mpkg >>= flip packageNameWithVersion env of+            Nothing             -> pure moduleName+            Just pkgWithVersion -> pure $ moduleName <> "\n\n" <> pkgWithVersion++        -- Return the package name and version of a module.+        -- For example, given module `Data.List`, it should return something like `base-4.x`.+        packageNameWithVersion :: Module -> HscEnv -> Maybe T.Text+        packageNameWithVersion m env = do           let pid = moduleUnit m           conf <- lookupUnit env pid           let pkgName = T.pack $ unitPackageNameString conf               version = T.pack $ showVersion (unitPackageVersion conf)-          pure $ "*(" <> pkgName <> "-" <> version <> ")*"+          pure $ pkgName <> "-" <> version +        -- Type info for the current node, it may contains several symbols+        -- for one range, like wildcard+        types :: [hietype]+        types = nodeType info++        prettyTypes :: [T.Text]         prettyTypes = map (("_ :: "<>) . prettyType) types++        prettyType :: hietype -> T.Text         prettyType t = case kind of           HieFresh -> printOutputable t           HieFromDisk full_file -> printOutputable $ hieTypeToIface $ recoverFullType t (hie_types full_file) +        definedAt :: Name -> Maybe T.Text         definedAt name =           -- do not show "at <no location info>" and similar messages           -- see the code of 'pprNameDefnLoc' for more information@@ -391,13 +433,15 @@  defRowToSymbolInfo :: Res DefRow -> Maybe SymbolInformation defRowToSymbolInfo (DefRow{..}:.(modInfoSrcFile -> Just srcFile))-  = Just $ SymbolInformation (printOutputable defNameOcc) kind Nothing Nothing loc Nothing+  = Just $ SymbolInformation (printOutputable defNameOcc) kind Nothing Nothing Nothing loc   where     kind-      | isVarOcc defNameOcc = SkVariable-      | isDataOcc defNameOcc = SkConstructor-      | isTcOcc defNameOcc = SkStruct-      | otherwise = SkUnknown 1+      | isVarOcc defNameOcc = SymbolKind_Variable+      | isDataOcc defNameOcc = SymbolKind_Constructor+      | isTcOcc defNameOcc = SymbolKind_Struct+        -- This used to be (SkUnknown 1), buth there is no SymbolKind_Unknown.+        -- Changing this to File, as that is enum representation of 1+      | otherwise = SymbolKind_File     loc   = Location file range     file  = fromNormalizedUri . filePathToUri' . toNormalizedFilePath' $ srcFile     range = Range start end@@ -424,6 +468,7 @@  where    sloc fs = mkRealSrcLoc fs (fromIntegral $ line+1) (fromIntegral $ cha+1)    sp fs = mkRealSrcSpan (sloc fs) (sloc fs)+   line :: UInt    line = _line pos    cha = _character pos 

@@ -32,7 +32,7 @@ import           System.Directory import           System.FilePath -import           Language.LSP.Types              (filePathToUri, getUri)+import           Language.LSP.Protocol.Types     (filePathToUri, getUri) #if MIN_VERSION_ghc(9,3,0) import           GHC.Types.Unique.Map #endif

@@ -15,15 +15,16 @@ import qualified Data.Maybe                      as Maybe import           Data.Text                       (Text, pack) import qualified Data.Text                       as Text-import           Development.IDE                 (srcSpanToRange, IdeState, NormalizedFilePath, runAction, useWithStale, GhcSession (..), getFileContents, hscEnv)+import           Development.IDE                 (srcSpanToRange, IdeState, NormalizedFilePath, GhcSession (..), getFileContents, hscEnv, runAction) import           Development.IDE.GHC.Compat import           Development.IDE.GHC.Compat.Util-import qualified Language.LSP.Types              as LSP+import qualified Language.LSP.Protocol.Types              as LSP import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Except (ExceptT)+import Ide.Plugin.Error (PluginError) import Ide.Types (PluginId(..)) import qualified Data.Text as T-import Ide.PluginUtils (handleMaybeM)+import  Development.IDE.Core.PluginUtils  getNextPragmaInfo :: DynFlags -> Maybe Text -> NextPragmaInfo getNextPragmaInfo dynFlags sourceText =@@ -51,13 +52,11 @@         pragmaInsertPosition = LSP.Position (fromIntegral nextPragmaLine) 0         pragmaInsertRange = LSP.Range pragmaInsertPosition pragmaInsertPosition -getFirstPragma :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT String m NextPragmaInfo-getFirstPragma (PluginId pId) state nfp = handleMaybeM "Could not get NextPragmaInfo" $ do-  ghcSession <- liftIO $ runAction (T.unpack pId <> ".GhcSession") state $ useWithStale GhcSession nfp+getFirstPragma :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError m NextPragmaInfo+getFirstPragma (PluginId pId) state nfp = do+  (hscEnv -> hsc_dflags -> sessionDynFlags, _) <- runActionE (T.unpack pId <> ".GhcSession") state $ useWithStaleE GhcSession nfp   (_, fileContents) <- liftIO $ runAction (T.unpack pId <> ".GetFileContents") state $ getFileContents nfp-  case ghcSession of-    Just (hscEnv -> hsc_dflags -> sessionDynFlags, _) -> pure $ Just $ getNextPragmaInfo sessionDynFlags fileContents-    Nothing                                           -> pure Nothing+  pure $ getNextPragmaInfo sessionDynFlags fileContents  -- Pre-declaration comments parser ----------------------------------------------------- 

@@ -11,12 +11,12 @@ where  import           Control.Concurrent.STM-import           Data.Hashable                (Hashable (..))-import           Data.HashSet                 (HashSet)-import qualified Data.HashSet                 as Set-import           Data.Unique                  (Unique)-import           Development.IDE.Graph        (Action)-import           Development.IDE.Types.Logger+import           Data.Hashable          (Hashable (..))+import           Data.HashSet           (HashSet)+import qualified Data.HashSet           as Set+import           Data.Unique            (Unique)+import           Development.IDE.Graph  (Action)+import           Ide.Logger import           Numeric.Natural  data DelayedAction a = DelayedAction

@@ -9,7 +9,6 @@   IdeResult,   LSP.DiagnosticSeverity(..),   DiagnosticStore,-  List(..),   ideErrorText,   ideErrorWithSource,   showDiagnostics,@@ -17,20 +16,17 @@   IdeResultNoDiagnosticsEarlyCutoff) where  import           Control.DeepSeq-import           Data.Maybe                                as Maybe-import qualified Data.Text                                 as T-import           Data.Text.Prettyprint.Doc-import           Data.Text.Prettyprint.Doc.Render.Terminal (Color (..), color)-import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Terminal-import           Data.Text.Prettyprint.Doc.Render.Text-import           Language.LSP.Diagnostics-import           Language.LSP.Types                        as LSP (Diagnostic (..),-                                                                   DiagnosticSeverity (..),-                                                                   DiagnosticSource,-                                                                   List (..))--import           Data.ByteString                           (ByteString)+import           Data.ByteString                (ByteString)+import           Data.Maybe                     as Maybe+import qualified Data.Text                      as T import           Development.IDE.Types.Location+import           Language.LSP.Diagnostics+import           Language.LSP.Protocol.Types    as LSP (Diagnostic (..),+                                                        DiagnosticSeverity (..))+import           Prettyprinter+import           Prettyprinter.Render.Terminal  (Color (..), color)+import qualified Prettyprinter.Render.Terminal  as Terminal+import           Prettyprinter.Render.Text   -- | The result of an IDE operation. Warnings and errors are in the Diagnostic,@@ -49,10 +45,10 @@ type IdeResultNoDiagnosticsEarlyCutoff  v = (Maybe ByteString, Maybe v)  ideErrorText :: NormalizedFilePath -> T.Text -> FileDiagnostic-ideErrorText = ideErrorWithSource (Just "compiler") (Just DsError)+ideErrorText = ideErrorWithSource (Just "compiler") (Just DiagnosticSeverity_Error)  ideErrorWithSource-  :: Maybe DiagnosticSource+  :: Maybe T.Text   -> Maybe DiagnosticSeverity   -> a   -> T.Text@@ -64,7 +60,9 @@     _source = source,     _message = msg,     _relatedInformation = Nothing,-    _tags = Nothing+    _tags = Nothing,+    _codeDescription = Nothing,+    _data_ = Nothing     })  -- | Defines whether a particular diagnostic should be reported@@ -117,14 +115,14 @@         , slabel_ "Severity:" $ pretty $ show sev         , slabel_ "Message: "             $ case sev of-              LSP.DsError   -> annotate $ color Red-              LSP.DsWarning -> annotate $ color Yellow-              LSP.DsInfo    -> annotate $ color Blue-              LSP.DsHint    -> annotate $ color Magenta+              LSP.DiagnosticSeverity_Error       -> annotate $ color Red+              LSP.DiagnosticSeverity_Warning     -> annotate $ color Yellow+              LSP.DiagnosticSeverity_Information -> annotate $ color Blue+              LSP.DiagnosticSeverity_Hint        -> annotate $ color Magenta             $ stringParagraphs _message         ]     where-        sev = fromMaybe LSP.DsError _severity+        sev = fromMaybe LSP.DiagnosticSeverity_Error _severity   -- | Label a document.

@@ -4,6 +4,7 @@     hscEnvWithImportPaths,     newHscEnvEqPreserveImportPaths,     newHscEnvEqWithImportPaths,+    updateHscEnvEq,     envImportPaths,     envPackageExports,     envVisibleModuleNames,@@ -32,7 +33,8 @@ import           System.FilePath  -- | An 'HscEnv' with equality. Two values are considered equal---   if they are created with the same call to 'newHscEnvEq'.+--   if they are created with the same call to 'newHscEnvEq' or+--   'updateHscEnvEq'. data HscEnvEq = HscEnvEq     { envUnique             :: !Unique     , hscEnv                :: !HscEnv@@ -50,6 +52,11 @@         -- So it's wrapped in IO here for error handling         -- If Nothing, 'listVisibleModuleNames' panic     }++updateHscEnvEq :: HscEnvEq -> HscEnv -> IO HscEnvEq+updateHscEnvEq oldHscEnvEq newHscEnv = do+  let update newUnique = oldHscEnvEq { envUnique = newUnique, hscEnv = newHscEnv }+  update <$> Unique.newUnique  -- | Wrap an 'HscEnv' into an 'HscEnvEq'. newHscEnvEq :: FilePath -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq

@@ -39,9 +39,9 @@ import           FastString import           SrcLoc                       as GHC #endif-import           Language.LSP.Types           (Location (..), Position (..),+import           Language.LSP.Protocol.Types  (Location (..), Position (..),                                                Range (..))-import qualified Language.LSP.Types           as LSP+import qualified Language.LSP.Protocol.Types  as LSP import           Text.ParserCombinators.ReadP as ReadP  toNormalizedFilePath' :: FilePath -> LSP.NormalizedFilePath

@@ -1,335 +0,0 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.--- SPDX-License-Identifier: Apache-2.0--{-# LANGUAGE CPP        #-}-{-# LANGUAGE RankNTypes #-}--- | This is a compatibility module that abstracts over the--- concrete choice of logging framework so users can plug in whatever--- framework they want to.-module Development.IDE.Types.Logger-  ( Priority(..)-  , Logger(..)-  , Recorder(..)-  , logError, logWarning, logInfo, logDebug-  , noLogging-  , WithPriority(..)-  , logWith-  , cmap-  , cmapIO-  , cfilter-  , withDefaultRecorder-  , makeDefaultStderrRecorder-  , makeDefaultHandleRecorder-  , LoggingColumn(..)-  , cmapWithPrio-  , withBacklog-  , lspClientMessageRecorder-  , lspClientLogRecorder-  , module PrettyPrinterModule-  , renderStrict-  , toCologActionWithPrio-  ) where--import           Control.Concurrent                    (myThreadId)-import           Control.Concurrent.Extra              (Lock, newLock, withLock)-import           Control.Concurrent.STM                (atomically,-                                                        flushTBQueue,-                                                        isFullTBQueue,-                                                        newTBQueueIO, newTVarIO,-                                                        readTVarIO,-                                                        writeTBQueue, writeTVar)-import           Control.Exception                     (IOException)-import           Control.Monad                         (unless, when, (>=>))-import           Control.Monad.IO.Class                (MonadIO (liftIO))-import           Data.Foldable                         (for_)-import           Data.Functor.Contravariant            (Contravariant (contramap))-import           Data.Maybe                            (fromMaybe)-import           Data.Text                             (Text)-import qualified Data.Text                             as T-import qualified Data.Text                             as Text-import qualified Data.Text.IO                          as Text-import           Data.Time                             (defaultTimeLocale,-                                                        formatTime,-                                                        getCurrentTime)-import           GHC.Stack                             (CallStack, HasCallStack,-                                                        SrcLoc (SrcLoc, srcLocModule, srcLocStartCol, srcLocStartLine),-                                                        callStack, getCallStack,-                                                        withFrozenCallStack)-import           Language.LSP.Server-import qualified Language.LSP.Server                   as LSP-import           Language.LSP.Types                    (LogMessageParams (..),-                                                        MessageType (..),-                                                        SMethod (SWindowLogMessage, SWindowShowMessage),-                                                        ShowMessageParams (..))-#if MIN_VERSION_prettyprinter(1,7,0)-import           Prettyprinter                         as PrettyPrinterModule-import           Prettyprinter.Render.Text             (renderStrict)-#else-import           Data.Text.Prettyprint.Doc             as PrettyPrinterModule-import           Data.Text.Prettyprint.Doc.Render.Text (renderStrict)-#endif-import           Colog.Core                            (LogAction (..),-                                                        Severity,-                                                        WithSeverity (..))-import qualified Colog.Core                            as Colog-import           System.IO                             (Handle,-                                                        IOMode (AppendMode),-                                                        hClose, hFlush,-                                                        openFile, stderr)-import           UnliftIO                              (MonadUnliftIO,-                                                        displayException,-                                                        finally, try)--data Priority--- Don't change the ordering of this type or you will mess up the Ord--- instance-    = Debug -- ^ Verbose debug logging.-    | Info  -- ^ Useful information in case an error has to be understood.-    | Warning-      -- ^ These error messages should not occur in a expected usage, and-      -- should be investigated.-    | Error -- ^ Such log messages must never occur in expected usage.-    deriving (Eq, Show, Ord, Enum, Bounded)---- | Note that this is logging actions _of the program_, not of the user.---   You shouldn't call warning/error if the user has caused an error, only---   if our code has gone wrong and is itself erroneous (e.g. we threw an exception).-newtype Logger = Logger {logPriority :: Priority -> T.Text -> IO ()}--instance Semigroup Logger where-    l1 <> l2 = Logger $ \p t -> logPriority l1 p t >> logPriority l2 p t--instance Monoid Logger where-    mempty = Logger $ \_ _ -> pure ()--logError :: Logger -> T.Text -> IO ()-logError x = logPriority x Error--logWarning :: Logger -> T.Text -> IO ()-logWarning x = logPriority x Warning--logInfo :: Logger -> T.Text -> IO ()-logInfo x = logPriority x Info--logDebug :: Logger -> T.Text -> IO ()-logDebug x = logPriority x Debug--noLogging :: Logger-noLogging = Logger $ \_ _ -> return ()--data WithPriority a = WithPriority { priority :: Priority, callStack_ :: CallStack, payload :: a } deriving Functor---- | Note that this is logging actions _of the program_, not of the user.---   You shouldn't call warning/error if the user has caused an error, only---   if our code has gone wrong and is itself erroneous (e.g. we threw an exception).-newtype Recorder msg = Recorder-  { logger_ :: forall m. (MonadIO m) => msg -> m () }--logWith :: (HasCallStack, MonadIO m) => Recorder (WithPriority msg) -> Priority -> msg -> m ()-logWith recorder priority msg = withFrozenCallStack $ logger_ recorder (WithPriority priority callStack msg)--instance Semigroup (Recorder msg) where-  (<>) Recorder{ logger_ = logger_1 } Recorder{ logger_ = logger_2 } =-    Recorder-      { logger_ = \msg -> logger_1 msg >> logger_2 msg }--instance Monoid (Recorder msg) where-  mempty =-    Recorder-      { logger_ = \_ -> pure () }--instance Contravariant Recorder where-  contramap f Recorder{ logger_ } =-    Recorder-      { logger_ = logger_ . f }--cmap :: (a -> b) -> Recorder b -> Recorder a-cmap = contramap--cmapWithPrio :: (a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a)-cmapWithPrio f = cmap (fmap f)--cmapIO :: (a -> IO b) -> Recorder b -> Recorder a-cmapIO f Recorder{ logger_ } =-  Recorder-    { logger_ = (liftIO . f) >=> logger_ }--cfilter :: (a -> Bool) -> Recorder a -> Recorder a-cfilter p Recorder{ logger_ } =-  Recorder-    { logger_ = \msg -> when (p msg) (logger_ msg) }--textHandleRecorder :: Handle -> Recorder Text-textHandleRecorder handle =-  Recorder-    { logger_ = \text -> liftIO $ Text.hPutStrLn handle text *> hFlush handle }--makeDefaultStderrRecorder :: MonadIO m => Maybe [LoggingColumn] -> m (Recorder (WithPriority (Doc a)))-makeDefaultStderrRecorder columns = do-  lock <- liftIO newLock-  makeDefaultHandleRecorder columns lock stderr---- | If no path given then use stderr, otherwise use file.-withDefaultRecorder-  :: MonadUnliftIO m-  => Maybe FilePath-  -- ^ Log file path. `Nothing` uses stderr-  -> Maybe [LoggingColumn]-  -- ^ logging columns to display. `Nothing` uses `defaultLoggingColumns`-  -> (Recorder (WithPriority (Doc d)) -> m a)-  -- ^ action given a recorder-  -> m a-withDefaultRecorder path columns action = do-  lock <- liftIO newLock-  let makeHandleRecorder = makeDefaultHandleRecorder columns lock-  case path of-    Nothing -> do-      recorder <- makeHandleRecorder stderr-      let message = "No log file specified; using stderr."-      logWith recorder Info message-      action recorder-    Just path -> do-      fileHandle :: Either IOException Handle <- liftIO $ try (openFile path AppendMode)-      case fileHandle of-        Left e -> do-          recorder <- makeHandleRecorder stderr-          let exceptionMessage = pretty $ displayException e-          let message = vcat [exceptionMessage, "Couldn't open log file" <+> pretty path <> "; falling back to stderr."]-          logWith recorder Warning message-          action recorder-        Right fileHandle -> finally (makeHandleRecorder fileHandle >>= action) (liftIO $ hClose fileHandle)--makeDefaultHandleRecorder-  :: MonadIO m-  => Maybe [LoggingColumn]-  -- ^ built-in logging columns to display. Nothing uses the default-  -> Lock-  -- ^ lock to take when outputting to handle-  -> Handle-  -- ^ handle to output to-  -> m (Recorder (WithPriority (Doc a)))-makeDefaultHandleRecorder columns lock handle = do-  let Recorder{ logger_ } = textHandleRecorder handle-  let threadSafeRecorder = Recorder { logger_ = \msg -> liftIO $ withLock lock (logger_ msg) }-  let loggingColumns = fromMaybe defaultLoggingColumns columns-  let textWithPriorityRecorder = cmapIO (textWithPriorityToText loggingColumns) threadSafeRecorder-  pure (cmap docToText textWithPriorityRecorder)-  where-    docToText = fmap (renderStrict . layoutPretty defaultLayoutOptions)--data LoggingColumn-  = TimeColumn-  | ThreadIdColumn-  | PriorityColumn-  | DataColumn-  | SourceLocColumn--defaultLoggingColumns :: [LoggingColumn]-defaultLoggingColumns = [TimeColumn, PriorityColumn, DataColumn]--textWithPriorityToText :: [LoggingColumn] -> WithPriority Text -> IO Text-textWithPriorityToText columns WithPriority{ priority, callStack_, payload } = do-    textColumns <- mapM loggingColumnToText columns-    pure $ Text.intercalate " | " textColumns-    where-      showAsText :: Show a => a -> Text-      showAsText = Text.pack . show--      utcTimeToText utcTime = Text.pack $ formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%6QZ" utcTime--      priorityToText :: Priority -> Text-      priorityToText = showAsText--      threadIdToText = showAsText--      callStackToSrcLoc :: CallStack -> Maybe SrcLoc-      callStackToSrcLoc callStack =-        case getCallStack callStack of-          (_, srcLoc) : _ -> Just srcLoc-          _               -> Nothing--      srcLocToText = \case-          Nothing -> "<unknown>"-          Just SrcLoc{ srcLocModule, srcLocStartLine, srcLocStartCol } ->-            Text.pack srcLocModule <> "#" <> showAsText srcLocStartLine <> ":" <> showAsText srcLocStartCol--      loggingColumnToText :: LoggingColumn -> IO Text-      loggingColumnToText = \case-        TimeColumn -> do-          utcTime <- getCurrentTime-          pure (utcTimeToText utcTime)-        SourceLocColumn -> pure $ (srcLocToText . callStackToSrcLoc) callStack_-        ThreadIdColumn -> do-          threadId <- myThreadId-          pure (threadIdToText threadId)-        PriorityColumn -> pure (priorityToText priority)-        DataColumn -> pure payload---- | Given a 'Recorder' that requires an argument, produces a 'Recorder'--- that queues up messages until the argument is provided using the callback, at which--- point it sends the backlog and begins functioning normally.-withBacklog :: (v -> Recorder a) -> IO (Recorder a, v -> IO ())-withBacklog recFun = do-  -- Arbitrary backlog capacity-  backlog <- newTBQueueIO 100-  let backlogRecorder = Recorder $ \it -> liftIO $ atomically $ do-          -- If the queue is full just drop the message on the floor. This is most likely-          -- to happen if the callback is just never going to be called; in which case-          -- we want neither to build up an unbounded backlog in memory, nor block waiting-          -- for space!-          full <- isFullTBQueue backlog-          unless full $ writeTBQueue backlog it--  -- The variable holding the recorder starts out holding the recorder that writes-  -- to the backlog.-  recVar <- newTVarIO backlogRecorder-  -- The callback atomically swaps out the recorder for the final one, and flushes-  -- the backlog to it.-  let cb arg = do-        let recorder = recFun arg-        toRecord <- atomically $ writeTVar recVar recorder >> flushTBQueue backlog-        for_ toRecord (logger_ recorder)--  -- The recorder we actually return looks in the variable and uses whatever is there.-  let varRecorder = Recorder $ \it -> do-          r <- liftIO $ readTVarIO recVar-          logger_ r it--  pure (varRecorder, cb)---- | Creates a recorder that sends logs to the LSP client via @window/showMessage@ notifications.-lspClientMessageRecorder :: LanguageContextEnv config -> Recorder (WithPriority Text)-lspClientMessageRecorder env = Recorder $ \WithPriority {..} ->-  liftIO $ LSP.runLspT env $ LSP.sendNotification SWindowShowMessage-      ShowMessageParams-        { _xtype = priorityToLsp priority,-          _message = payload-        }---- | Creates a recorder that sends logs to the LSP client via @window/logMessage@ notifications.-lspClientLogRecorder :: LanguageContextEnv config -> Recorder (WithPriority Text)-lspClientLogRecorder env = Recorder $ \WithPriority {..} ->-  liftIO $ LSP.runLspT env $ LSP.sendNotification SWindowLogMessage-      LogMessageParams-        { _xtype = priorityToLsp priority,-          _message = payload-        }--priorityToLsp :: Priority -> MessageType-priorityToLsp =-  \case-    Debug   -> MtLog-    Info    -> MtInfo-    Warning -> MtWarning-    Error   -> MtError--toCologActionWithPrio :: (MonadIO m, HasCallStack) => Recorder (WithPriority msg) -> LogAction m (WithSeverity msg)-toCologActionWithPrio (Recorder _logger) = LogAction $ \WithSeverity{..} -> do-    let priority = severityToPriority getSeverity-    _logger $ WithPriority priority callStack getMsg-  where-    severityToPriority :: Severity -> Priority-    severityToPriority Colog.Debug   = Debug-    severityToPriority Colog.Info    = Info-    severityToPriority Colog.Warning = Warning-    severityToPriority Colog.Error   = Error

@@ -2,7 +2,8 @@ -- SPDX-License-Identifier: Apache-2.0  -- | Options-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE RankNTypes       #-} module Development.IDE.Types.Options   ( IdeOptions(..)   , IdePreprocessedSource(..)@@ -18,7 +19,7 @@   , OptHaddockParse(..)   , ProgressReportingStyle(..)   ) where-+import           Control.Lens import qualified Data.Text                         as T import           Data.Typeable import           Development.IDE.Core.RuleTypes@@ -27,8 +28,8 @@ import           Development.IDE.Types.Diagnostics import           Ide.Plugin.Config import           Ide.Types                         (DynFlagsModifications)-import qualified Language.LSP.Types.Capabilities   as LSP-+import qualified Language.LSP.Protocol.Lens        as L+import qualified Language.LSP.Protocol.Types       as LSP data IdeOptions = IdeOptions   { optPreprocessor       :: GHC.ParsedSource -> IdePreprocessedSource     -- ^ Preprocessor to run over all parsed source trees, generating a list of warnings@@ -110,7 +111,7 @@  clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress clientSupportsProgress caps = IdeReportProgress $ Just True ==-    (LSP._workDoneProgress =<< LSP._window (caps :: LSP.ClientCapabilities))+    ((\x -> x ^. L.workDoneProgress) =<< LSP._window (caps :: LSP.ClientCapabilities))  defaultIdeOptions :: Action IdeGhcSession -> IdeOptions defaultIdeOptions session = IdeOptions

@@ -1,9 +1,9 @@ -- | Parallel versions of 'filter' and 'simpleFilter'  module Text.Fuzzy.Parallel-(   filter,-    simpleFilter,-    match,+(   filter, filter',+    simpleFilter, simpleFilter',+    match, defChunkSize, defMaxResults,     Scored(..) ) where @@ -29,7 +29,6 @@ -- Just 5 -- {-# INLINABLE match #-}- match :: T.Text    -- ^ Pattern in lowercase except for first character       -> T.Text    -- ^ The text to search in.       -> Maybe Int -- ^ The score@@ -70,23 +69,14 @@      toLowerAscii w = if (w - 65) < 26 then w .|. 0x20 else w --- | The function to filter a list of values by fuzzy search on the text extracted from them.-filter :: Int           -- ^ Chunk size. 1000 works well.-       -> Int           -- ^ Max. number of results wanted-       -> T.Text        -- ^ Pattern.-       -> [t]           -- ^ The list of values containing the text to search in.-       -> (t -> T.Text) -- ^ The function to extract the text from the container.-       -> [Scored t]    -- ^ The list of results, sorted, highest score first.-filter chunkSize maxRes pattern ts extract = partialSortByAscScore maxRes perfectScore (concat vss)-  where-      -- Preserve case for the first character, make all others lowercase-      pattern' = case T.uncons pattern of-        Just (c, rest) -> T.cons c (T.toLower rest)-        _              -> pattern-      vss = map (mapMaybe (\t -> flip Scored t <$> match pattern' (extract t))) (chunkList chunkSize ts)-        `using` parList (evalList rseq)-      perfectScore = fromMaybe (error $ T.unpack pattern) $ match pattern' pattern'+-- | Sensible default value for chunk size to use when calling simple filter.+defChunkSize :: Int+defChunkSize = 1000 +-- | Sensible default value for the number of max results to use when calling simple filter.+defMaxResults :: Int+defMaxResults = 10+ -- | Return all elements of the list that have a fuzzy -- match against the pattern. Runs with default settings where -- nothing is added around the matches, as case insensitive.@@ -102,6 +92,52 @@ simpleFilter chunk maxRes pattern xs =   filter chunk maxRes pattern xs id ++-- | The function to filter a list of values by fuzzy search on the text extracted from them,+-- using a custom matching function which determines how close words are.+filter' :: Int           -- ^ Chunk size. 1000 works well.+       -> Int           -- ^ Max. number of results wanted+       -> T.Text        -- ^ Pattern.+       -> [t]           -- ^ The list of values containing the text to search in.+       -> (t -> T.Text) -- ^ The function to extract the text from the container.+       -> (T.Text -> T.Text -> Maybe Int)+       -- ^ Custom scoring function to use for calculating how close words are+       -- When the function returns Nothing, this means the values are incomparable.+       -> [Scored t]    -- ^ The list of results, sorted, highest score first.+filter' chunkSize maxRes pattern ts extract match' = partialSortByAscScore maxRes perfectScore (concat vss)+  where+      -- Preserve case for the first character, make all others lowercase+      pattern' = case T.uncons pattern of+        Just (c, rest) -> T.cons c (T.toLower rest)+        _              -> pattern+      vss = map (mapMaybe (\t -> flip Scored t <$> match' pattern' (extract t))) (chunkList chunkSize ts)+        `using` parList (evalList rseq)+      perfectScore = fromMaybe (error $ T.unpack pattern) $ match' pattern' pattern'++-- | The function to filter a list of values by fuzzy search on the text extracted from them,+-- using a custom matching function which determines how close words are.+filter :: Int           -- ^ Chunk size. 1000 works well.+       -> Int           -- ^ Max. number of results wanted+       -> T.Text        -- ^ Pattern.+       -> [t]           -- ^ The list of values containing the text to search in.+       -> (t -> T.Text) -- ^ The function to extract the text from the container.+       -> [Scored t]    -- ^ The list of results, sorted, highest score first.+filter chunkSize maxRes pattern ts extract =+  filter' chunkSize maxRes pattern ts extract match++-- | Return all elements of the list that have a fuzzy match against the pattern,+-- the closeness of the match is determined using the custom scoring match function that is passed.+-- Runs with default settings where nothing is added around the matches, as case insensitive.+{-# INLINABLE simpleFilter' #-}+simpleFilter' :: Int      -- ^ Chunk size. 1000 works well.+             -> Int      -- ^ Max. number of results wanted+             -> T.Text   -- ^ Pattern to look for.+             -> [T.Text] -- ^ List of texts to check.+             -> (T.Text -> T.Text -> Maybe Int)+             -- ^ Custom scoring function to use for calculating how close words are+             -> [Scored T.Text] -- ^ The ones that match.+simpleFilter' chunk maxRes pattern xs match' =+  filter' chunk maxRes pattern xs id match' --------------------------------------------------------------------------------  chunkList :: Int -> [a] -> [[a]]

@@ -0,0 +1,53 @@+{-# LANGUAGE DataKinds #-}++module AsyncTests (tests) where++import           Control.Monad+import           Control.Monad.IO.Class        (liftIO)+import           Data.Aeson                    (toJSON)+import           Data.Proxy+import qualified Data.Text                     as T+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types   hiding+                                               (SemanticTokenAbsolute (..),+                                                SemanticTokenRelative (..),+                                                SemanticTokensEdit (..),+                                                mkRange)+import           Language.LSP.Test+-- import Test.QuickCheck.Instances ()+import           Development.IDE.Plugin.Test   (TestRequest (BlockSeconds),+                                                blockCommandId)+import           Test.Tasty+import           Test.Tasty.HUnit+import           TestUtils++-- | Test if ghcide asynchronously handles Commands and user Requests+tests :: TestTree+tests = testGroup "async"+    [+      testSession "command" $ do+            -- Execute a command that will block forever+            let req = ExecuteCommandParams Nothing blockCommandId Nothing+            void $ sendRequest SMethod_WorkspaceExecuteCommand req+            -- Load a file and check for code actions. Will only work if the command is run asynchronously+            doc <- createDoc "A.hs" "haskell" $ T.unlines+              [ "{-# OPTIONS -Wmissing-signatures #-}"+              , "foo = id"+              ]+            void waitForDiagnostics+            codeLenses <- getCodeLenses doc+            liftIO $ [ _title | CodeLens{_command = Just Command{_title}} <- codeLenses] @=?+              [ "foo :: a -> a" ]+    , testSession "request" $ do+            -- Execute a custom request that will block for 1000 seconds+            void $ sendRequest (SMethod_CustomMethod (Proxy @"test")) $ toJSON $ BlockSeconds 1000+            -- Load a file and check for code actions. Will only work if the request is run asynchronously+            doc <- createDoc "A.hs" "haskell" $ T.unlines+              [ "{-# OPTIONS -Wmissing-signatures #-}"+              , "foo = id"+              ]+            void waitForDiagnostics+            codeLenses <- getCodeLenses doc+            liftIO $ [ _title | CodeLens{_command = Just Command{_title}} <- codeLenses] @=?+              [ "foo :: a -> a" ]+    ]

@@ -0,0 +1,55 @@+module BootTests (tests) where++import           Control.Applicative.Combinators+import           Control.Monad+import           Control.Monad.IO.Class          (liftIO)+import           Development.IDE.GHC.Util+import           Development.IDE.Test            (expectNoMoreDiagnostics,+                                                  isReferenceReady)+import           Development.IDE.Types.Location+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types     hiding+                                                 (SemanticTokenAbsolute (..),+                                                  SemanticTokenRelative (..),+                                                  SemanticTokensEdit (..),+                                                  mkRange)+import           Language.LSP.Test+import           System.FilePath+import           Test.Tasty+import           Test.Tasty.HUnit+import           TestUtils+++tests :: TestTree+tests = testGroup "boot"+  [ testCase "boot-def-test" $ runWithExtraFiles "boot" $ \dir -> do+        let cPath = dir </> "C.hs"+        cSource <- liftIO $ readFileUtf8 cPath+        -- Dirty the cache+        liftIO $ runInDir dir $ do+            cDoc <- createDoc cPath "haskell" cSource+            -- We send a hover request then wait for either the hover response or+            -- `ghcide/reference/ready` notification.+            -- Once we receive one of the above, we wait for the other that we+            -- haven't received yet.+            -- If we don't wait for the `ready` notification it is possible+            -- that the `getDefinitions` request/response in the outer ghcide+            -- session will find no definitions.+            let hoverParams = HoverParams cDoc (Position 4 3) Nothing+            hoverRequestId <- sendRequest SMethod_TextDocumentHover hoverParams+            let parseReadyMessage = isReferenceReady cPath+            let parseHoverResponse = responseForId SMethod_TextDocumentHover hoverRequestId+            hoverResponseOrReadyMessage <- skipManyTill anyMessage ((Left <$> parseHoverResponse) <|> (Right <$> parseReadyMessage))+            _ <- skipManyTill anyMessage $+              case hoverResponseOrReadyMessage of+                Left _  -> void parseReadyMessage+                Right _ -> void parseHoverResponse+            closeDoc cDoc+        cdoc <- createDoc cPath "haskell" cSource+        locs <- getDefinitions cdoc (Position 7 4)+        let floc = mkR 9 0 9 1+        checkDefs locs (pure [floc])+  , testCase "graph with boot modules" $ runWithExtraFiles "boot2" $ \dir -> do+      _ <- openDoc (dir </> "A.hs") "haskell"+      expectNoMoreDiagnostics 2+  ]

@@ -0,0 +1,56 @@+module CPPTests (tests) where++import           Control.Exception           (catch)+import qualified Data.Text                   as T+import           Development.IDE.Test        (Cursor, expectDiagnostics,+                                              expectNoMoreDiagnostics)+import           Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..),+                                              SemanticTokenRelative (..),+                                              SemanticTokensEdit (..), mkRange)+import           Language.LSP.Test+-- import Test.QuickCheck.Instances ()+import           Test.Tasty+import           Test.Tasty.HUnit+import           TestUtils++tests :: TestTree+tests =+  testGroup "cpp"+    [ ignoreInWindowsBecause "Throw a lsp session time out in windows for ghc-8.8 and is broken for other versions" $ testCase "cpp-error" $ do+        let content =+              T.unlines+                [ "{-# LANGUAGE CPP #-}",+                  "module Testing where",+                  "#ifdef FOO",+                  "foo = 42"+                ]+        -- The error locations differ depending on which C-preprocessor is used.+        -- Some give the column number and others don't (hence maxBound == -1 unsigned). Assert either+        -- of them.+        (run $ expectError content (2, maxBound))+          `catch` ( \e -> do+                      let _ = e :: HUnitFailure+                      run $ expectError content (2, 1)+                  )+    , testSessionWait "cpp-ghcide" $ do+        _ <- createDoc "A.hs" "haskell" $ T.unlines+          ["{-# LANGUAGE CPP #-}"+          ,"main ="+          ,"#ifdef __GHCIDE__"+          ,"  worked"+          ,"#else"+          ,"  failed"+          ,"#endif"+          ]+        expectDiagnostics [("A.hs", [(DiagnosticSeverity_Error, (3, 2), "Variable not in scope: worked")])]+    ]+  where+    expectError :: T.Text -> Cursor -> Session ()+    expectError content cursor = do+      _ <- createDoc "Testing.hs" "haskell" content+      expectDiagnostics+        [ ( "Testing.hs",+            [(DiagnosticSeverity_Error, cursor, "error: unterminated")]+          )+        ]+      expectNoMoreDiagnostics 0.5

@@ -0,0 +1,34 @@+{-# LANGUAGE GADTs #-}+module ClientSettingsTests (tests) where++import           Control.Applicative.Combinators+import           Control.Monad+import           Data.Aeson                      (toJSON)+import qualified Data.Aeson                      as A+import qualified Data.Text                       as T+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types     hiding+                                                 (SemanticTokenAbsolute (..),+                                                  SemanticTokenRelative (..),+                                                  SemanticTokensEdit (..),+                                                  mkRange)+import           Language.LSP.Test+import           Test.Tasty+import           TestUtils++tests :: TestTree+tests = testGroup "client settings handling"+    [ testSession "ghcide restarts shake session on config changes" $ do+            void $ skipManyTill anyMessage $ message SMethod_ClientRegisterCapability+            void $ createDoc "A.hs" "haskell" "module A where"+            waitForProgressDone+            sendNotification SMethod_WorkspaceDidChangeConfiguration+                (DidChangeConfigurationParams (toJSON (mempty :: A.Object)))+            skipManyTill anyMessage restartingBuildSession++    ]+  where+    restartingBuildSession :: Session ()+    restartingBuildSession = do+        FromServerMess SMethod_WindowLogMessage TNotificationMessage{_params = LogMessageParams{..}} <- loggingNotification+        guard $ "Restarting build session" `T.isInfixOf` _message

@@ -0,0 +1,114 @@+{-# LANGUAGE GADTs #-}++module CodeLensTests (tests) where++import           Control.Applicative.Combinators+import           Control.Monad.IO.Class          (liftIO)+import qualified Data.Aeson                      as A+import           Data.Maybe+import qualified Data.Text                       as T+import           Development.IDE.GHC.Compat      (GhcVersion (..), ghcVersion)+import qualified Language.LSP.Protocol.Lens      as L+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types     hiding+                                                 (SemanticTokenAbsolute (..),+                                                  SemanticTokenRelative (..),+                                                  SemanticTokensEdit (..),+                                                  mkRange)+import           Language.LSP.Test+-- import Test.QuickCheck.Instances ()+import           Control.Lens                    ((^.))+import           Data.Tuple.Extra+import           Test.Tasty+import           Test.Tasty.HUnit+import           TestUtils++tests :: TestTree+tests = testGroup "code lenses"+  [ addSigLensesTests+  ]+++addSigLensesTests :: TestTree+addSigLensesTests =+  let pragmas = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}"+      moduleH exported =+        T.unlines+          [ "{-# LANGUAGE PatternSynonyms,TypeApplications,DataKinds,RankNTypes,ScopedTypeVariables,TypeOperators,GADTs,BangPatterns #-}"+          , "module Sigs(" <> exported <> ") where"+          , "import qualified Data.Complex as C"+          , "import Data.Data (Proxy (..), type (:~:) (..), mkCharType)"+          , "data T1 a where"+          , "  MkT1 :: (Show b) => a -> b -> T1 a"+          ]+      before enableGHCWarnings exported (def, _) others =+        T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported, def] <> others+      after' enableGHCWarnings exported (def, sig) others =+        T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported] <> maybe [] pure sig <> [def] <> others+      createConfig mode = A.object ["haskell" A..= A.object ["plugin" A..= A.object ["ghcide-type-lenses" A..= A.object ["config" A..= A.object ["mode" A..= A.String mode]]]]]+      sigSession testName enableGHCWarnings mode exported def others = testSession testName $ do+        let originalCode = before enableGHCWarnings exported def others+        let expectedCode = after' enableGHCWarnings exported def others+        sendNotification SMethod_WorkspaceDidChangeConfiguration $ DidChangeConfigurationParams $ createConfig mode+        doc <- createDoc "Sigs.hs" "haskell" originalCode+        waitForProgressDone+        codeLenses <- getCodeLenses doc+        if not $ null $ snd def+          then do+            liftIO $ length codeLenses == 1 @? "Expected 1 code lens, but got: " <> show codeLenses+            executeCommand $ fromJust $ head codeLenses ^. L.command+            modifiedCode <- skipManyTill anyMessage (getDocumentEdit doc)+            liftIO $ expectedCode @=? modifiedCode+          else liftIO $ null codeLenses @? "Expected no code lens, but got: " <> show codeLenses+      cases =+        [ ("abc = True", "abc :: Bool")+        , ("foo a b = a + b", "foo :: Num a => a -> a -> a")+        , ("bar a b = show $ a + b", "bar :: (Show a, Num a) => a -> a -> String")+        , ("(!!!) a b = a > b", "(!!!) :: Ord a => a -> a -> Bool")+        , ("a >>>> b = a + b", "(>>>>) :: Num a => a -> a -> a")+        , ("a `haha` b = a b", "haha :: (t1 -> t2) -> t1 -> t2")+        , ("pattern Some a = Just a", "pattern Some :: a -> Maybe a")+        , ("pattern Some a <- Just a", "pattern Some :: a -> Maybe a")+        , ("pattern Some a <- Just a\n  where Some a = Just a", "pattern Some :: a -> Maybe a")+        , ("pattern Some a <- Just !a\n  where Some !a = Just a", "pattern Some :: a -> Maybe a")+        , ("pattern Point{x, y} = (x, y)", "pattern Point :: a -> b -> (a, b)")+        , ("pattern Point{x, y} <- (x, y)", "pattern Point :: a -> b -> (a, b)")+        , ("pattern Point{x, y} <- (x, y)\n  where Point x y = (x, y)", "pattern Point :: a -> b -> (a, b)")+        , ("pattern MkT1' b = MkT1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a")+        , ("pattern MkT1' b <- MkT1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a")+        , ("pattern MkT1' b <- MkT1 42 b\n  where MkT1' b = MkT1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a")+        , ("qualifiedSigTest= C.realPart", "qualifiedSigTest :: C.Complex a -> a")+        , ("head = 233", "head :: Integer")+        , ("rank2Test (k :: forall a . a -> a) = (k 233 :: Int, k \"QAQ\")", "rank2Test :: (forall a. a -> a) -> (Int, " <> listOfChar <> ")")+        , ("symbolKindTest = Proxy @\"qwq\"", "symbolKindTest :: Proxy \"qwq\"")+        , ("promotedKindTest = Proxy @Nothing", if ghcVersion >= GHC96 then "promotedKindTest :: Proxy Nothing" else "promotedKindTest :: Proxy 'Nothing")+        , ("typeOperatorTest = Refl", if ghcVersion >= GHC92 then "typeOperatorTest :: forall {k} {a :: k}. a :~: a" else "typeOperatorTest :: a :~: a")+        , ("notInScopeTest = mkCharType", "notInScopeTest :: String -> Data.Data.DataType")+        ]+   in testGroup+        "add signature"+        [ testGroup "signatures are correct" [sigSession (T.unpack $ T.replace "\n" "\\n" def) False "always" "" (def, Just sig) [] | (def, sig) <- cases]+        , sigSession "exported mode works" False "exported" "xyz" ("xyz = True", Just "xyz :: Bool") (fst <$> take 3 cases)+        , testGroup+            "diagnostics mode works"+            [ sigSession "with GHC warnings" True "diagnostics" "" (second Just $ head cases) []+            , sigSession "without GHC warnings" False "diagnostics" "" (second (const Nothing) $ head cases) []+            ]+        , testSession "keep stale lens" $ do+            let content = T.unlines+                    [ "module Stale where"+                    , "f = _"+                    ]+            doc <- createDoc "Stale.hs" "haskell" content+            oldLens <- getCodeLenses doc+            liftIO $ length oldLens @?= 1+            let edit = TextEdit (mkRange 0 4 0 5) "" -- Remove the `_`+            _ <- applyEdit doc edit+            newLens <- getCodeLenses doc+            liftIO $ newLens @?= oldLens+        ]++-- | Before ghc9, lists of Char is displayed as [Char], but with ghc9 and up, it's displayed as String+listOfChar :: T.Text+listOfChar | ghcVersion >= GHC90 = "String"+           | otherwise = "[Char]"

@@ -0,0 +1,576 @@++{-# LANGUAGE GADTs            #-}+{-# LANGUAGE OverloadedLabels #-}++module CompletionTests (tests) where++import           Control.Lens                   ((^.))+import qualified Control.Lens                   as Lens+import           Control.Monad+import           Control.Monad.IO.Class         (liftIO)+import           Data.Default+import           Data.List.Extra+import           Data.Maybe+import           Data.Row+import qualified Data.Text                      as T+import           Development.IDE.GHC.Compat     (GhcVersion (..), ghcVersion)+import           Development.IDE.Test           (waitForTypecheck)+import           Development.IDE.Types.Location+import           Ide.Plugin.Config+import qualified Language.LSP.Protocol.Lens     as L+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types    hiding+                                                (SemanticTokenAbsolute (..),+                                                 SemanticTokenRelative (..),+                                                 SemanticTokensEdit (..),+                                                 mkRange)+import           Language.LSP.Test+import           System.FilePath+import           Test.Tasty+import           Test.Tasty.HUnit+import           TestUtils+++tests :: TestTree+tests+  = testGroup "completion"+    [+    testGroup "non local" nonLocalCompletionTests+    , testGroup "topLevel" topLevelCompletionTests+    , testGroup "local" localCompletionTests+    , testGroup "package" packageCompletionTests+    , testGroup "project" projectCompletionTests+    , testGroup "other" otherCompletionTests+    , testGroup "doc" completionDocTests+    ]++completionTest :: HasCallStack => String -> [T.Text] -> Position -> [(T.Text, CompletionItemKind, T.Text, Bool, Bool, Maybe [TextEdit])] -> TestTree+completionTest name src pos expected = testSessionWait name $ do+    docId <- createDoc "A.hs" "haskell" (T.unlines src)+    _ <- waitForDiagnostics+    compls <- getAndResolveCompletions docId pos+    let compls' = [ (_label, _kind, _insertText, _additionalTextEdits) | CompletionItem{..} <- compls]+    let emptyToMaybe x = if T.null x then Nothing else Just x+    liftIO $ sortOn (Lens.view Lens._1) (take (length expected) compls') @?=+        sortOn (Lens.view Lens._1)+          [ (l, Just k, emptyToMaybe t, at) | (l,k,t,_,_,at) <- expected]+    forM_ (zip compls expected) $ \(CompletionItem{..}, (_,_,_,expectedSig, expectedDocs, _)) -> do+        when expectedSig $+            liftIO $ assertBool ("Missing type signature: " <> T.unpack _label) (isJust _detail)+        when expectedDocs $+            liftIO $ assertBool ("Missing docs: " <> T.unpack _label) (isJust _documentation)+++topLevelCompletionTests :: [TestTree]+topLevelCompletionTests = [+    completionTest+        "variable"+        ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"]+        (Position 0 8)+        [("xxx", CompletionItemKind_Function, "xxx", True, True, Nothing)+        ],+    completionTest+        "constructor"+        ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"]+        (Position 0 8)+        [("xxx", CompletionItemKind_Function, "xxx", True, True, Nothing)+        ],+    completionTest+        "class method"+        ["bar = xx", "class Xxx a where", "-- | haddock", "xxx :: ()", "xxx = ()"]+        (Position 0 8)+        [("xxx", CompletionItemKind_Function, "xxx", True, True, Nothing)],+    completionTest+        "type"+        ["bar :: Xz", "zzz = ()", "-- | haddock", "data Xzz = XzzCon"]+        (Position 0 9)+        [("Xzz", CompletionItemKind_Struct, "Xzz", False, True, Nothing)],+    completionTest+        "class"+        ["bar :: Xz", "zzz = ()", "-- | haddock", "class Xzz a"]+        (Position 0 9)+        [("Xzz", CompletionItemKind_Interface, "Xzz", False, True, Nothing)],+    completionTest+        "records"+        ["data Person = Person { _personName:: String, _personAge:: Int}", "bar = Person { _pers }" ]+        (Position 1 19)+        [("_personName", CompletionItemKind_Function, "_personName", False, True, Nothing),+         ("_personAge", CompletionItemKind_Function, "_personAge", False, True, Nothing)],+    completionTest+        "recordsConstructor"+        ["data XxRecord = XyRecord { x:: String, y:: Int}", "bar = Xy" ]+        (Position 1 19)+        [("XyRecord", CompletionItemKind_Constructor, "XyRecord", False, True, Nothing),+         ("XyRecord", CompletionItemKind_Snippet, "XyRecord {x=${1:_x}, y=${2:_y}}", False, True, Nothing)]+    ]++localCompletionTests :: [TestTree]+localCompletionTests = [+    completionTest+        "argument"+        ["bar (Just abcdef) abcdefg = abcd"]+        (Position 0 32)+        [("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing),+         ("abcdefg", CompletionItemKind_Function , "abcdefg", True, False, Nothing)+        ],+    completionTest+        "let"+        ["bar = let (Just abcdef) = undefined"+        ,"          abcdefg = let abcd = undefined in undefined"+        ,"        in abcd"+        ]+        (Position 2 15)+        [("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing),+         ("abcdefg", CompletionItemKind_Function , "abcdefg", True, False, Nothing)+        ],+    completionTest+        "where"+        ["bar = abcd"+        ,"  where (Just abcdef) = undefined"+        ,"        abcdefg = let abcd = undefined in undefined"+        ]+        (Position 0 10)+        [("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing),+         ("abcdefg", CompletionItemKind_Function , "abcdefg", True, False, Nothing)+        ],+    completionTest+        "do/1"+        ["bar = do"+        ,"  Just abcdef <- undefined"+        ,"  abcd"+        ,"  abcdefg <- undefined"+        ,"  pure ()"+        ]+        (Position 2 6)+        [("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing)+        ],+    completionTest+        "do/2"+        ["bar abcde = do"+        ,"    Just [(abcdef,_)] <- undefined"+        ,"    abcdefg <- undefined"+        ,"    let abcdefgh = undefined"+        ,"        (Just [abcdefghi]) = undefined"+        ,"    abcd"+        ,"  where"+        ,"    abcdefghij = undefined"+        ]+        (Position 5 8)+        [("abcde", CompletionItemKind_Function, "abcde", True, False, Nothing)+        ,("abcdefghij", CompletionItemKind_Function, "abcdefghij", True, False, Nothing)+        ,("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing)+        ,("abcdefg", CompletionItemKind_Function, "abcdefg", True, False, Nothing)+        ,("abcdefgh", CompletionItemKind_Function, "abcdefgh", True, False, Nothing)+        ,("abcdefghi", CompletionItemKind_Function, "abcdefghi", True, False, Nothing)+        ],+    completionTest+        "type family"+        ["{-# LANGUAGE DataKinds, TypeFamilies #-}"+        ,"type family Bar a"+        ,"a :: Ba"+        ]+        (Position 2 7)+        [("Bar", CompletionItemKind_Struct, "Bar", 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", CompletionItemKind_Function, "abcd", True, False, Nothing)+        ,("abcde", CompletionItemKind_Function, "abcde", True, False, Nothing)+        ],+    testSessionWait "incomplete entries" $ do+        let src a = "data Data = " <> a+        doc <- createDoc "A.hs" "haskell" $ src "AAA"+        void $ waitForTypecheck doc+        let editA rhs =+                changeDoc doc [TextDocumentContentChangeEvent . InR . (.==) #text $ src rhs]+        editA "AAAA"+        void $ waitForTypecheck doc+        editA "AAAAA"+        void $ waitForTypecheck doc++        compls <- getCompletions doc (Position 0 15)+        liftIO $ filter ("AAA" `T.isPrefixOf`) (mapMaybe _insertText compls) @?= ["AAAAA"]+        pure ()+    ]++nonLocalCompletionTests :: [TestTree]+nonLocalCompletionTests =+  [ brokenForWinGhc $ completionTest+      "variable"+      ["module A where", "f = hea"]+      (Position 1 7)+      [("head", CompletionItemKind_Function, "head", True, True, Nothing)],+    completionTest+      "constructor"+      ["{-# OPTIONS_GHC -Wall #-}", "module A where", "f = True"]+      (Position 2 8)+      [ ("True", CompletionItemKind_Constructor, "True", True, True, Nothing)+      ],+    brokenForWinGhc $ completionTest+      "type"+      ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Boo", "f = True"]+      (Position 2 8)+      [ ("Bool", CompletionItemKind_Struct, "Bool", True, True, Nothing)+      ],+    completionTest+      "qualified"+      ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"]+      (Position 2 15)+      [ ("head", CompletionItemKind_Function, "head", True, True, Nothing)+      ],+    completionTest+      "duplicate import"+      ["module A where", "import Data.List", "import Data.List", "f = permu"]+      (Position 3 9)+      [ ("permutations", CompletionItemKind_Function, "permutations", False, False, Nothing)+      ],+    completionTest+       "dont show hidden items"+       [ "{-# LANGUAGE NoImplicitPrelude #-}",+         "module A where",+         "import Control.Monad hiding (join)",+         "f = joi"+       ]+       (Position 3 6)+       [],+    testGroup "ordering"+      [completionTest "qualified has priority"+        ["module A where"+        ,"import qualified Data.ByteString as BS"+        ,"f = BS.read"+        ]+        (Position 2 10)+        [("readFile", CompletionItemKind_Function, "readFile", True, True, Nothing)]+        ],+      -- we need this test to make sure the ghcide completions module does not return completions for language pragmas. this functionality is turned on in hls+     completionTest+      "do not show pragma completions"+      [ "{-# LANGUAGE  ",+        "{module A where}",+        "main = return ()"+      ]+      (Position 0 13)+      []+  ]+  where+    brokenForWinGhc = knownBrokenFor (BrokenSpecific Windows [GHC810, GHC90, GHC92, GHC94, GHC96]) "Windows has strange things in scope for some reason"++otherCompletionTests :: [TestTree]+otherCompletionTests = [+    completionTest+      "keyword"+      ["module A where", "f = newty"]+      (Position 1 9)+      [("newtype", CompletionItemKind_Keyword, "", False, False, Nothing)],+    completionTest+      "type context"+      [ "{-# OPTIONS_GHC -Wunused-binds #-}",+        "module A () where",+        "f = f",+        "g :: Intege"+      ]+      -- At this point the module parses but does not typecheck.+      -- This should be sufficient to detect that we are in a+      -- type context and only show the completion to the type.+      (Position 3 11)+      [("Integer", CompletionItemKind_Struct, "Integer", True, True, Nothing)],++    testSession "duplicate record fields" $ do+      void $+        createDoc "B.hs" "haskell" $+          T.unlines+            [ "{-# LANGUAGE DuplicateRecordFields #-}",+              "module B where",+              "newtype Foo = Foo { member :: () }",+              "newtype Bar = Bar { member :: () }"+            ]+      docA <-+        createDoc "A.hs" "haskell" $+          T.unlines+            [ "module A where",+              "import B",+              "memb"+            ]+      _ <- waitForDiagnostics+      compls <- getCompletions docA $ Position 2 4+      let compls' = [txt | CompletionItem {_insertText = Just txt, ..} <- compls, _label == "member"]+      liftIO $ take 2 compls' @?= ["member"],++    testSessionWait "maxCompletions" $ do+        doc <- createDoc "A.hs" "haskell" $ T.unlines+            [ "{-# OPTIONS_GHC -Wunused-binds #-}",+                "module A () where",+                "a = Prelude."+            ]+        _ <- waitForDiagnostics+        compls <- getCompletions  doc (Position 3 13)+        liftIO $ length compls @?= maxCompletions def+  ]++packageCompletionTests :: [TestTree]+packageCompletionTests =+  [ testSession' "fromList" $ \dir -> do+        liftIO $ writeFile (dir </> "hie.yaml")+            "cradle: {direct: {arguments: [-hide-all-packages, -package, base, A]}}"+        doc <- createDoc "A.hs" "haskell" $ T.unlines+            [ "{-# OPTIONS_GHC -Wunused-binds #-}",+                "module A () where",+                "a = fromList"+            ]+        _ <- waitForDiagnostics+        compls <- getCompletions doc (Position 2 12)+        let compls' =+              [T.drop 1 $ T.dropEnd 3 d+              | CompletionItem {_documentation = Just (InR (MarkupContent MarkupKind_Markdown d)), _label}+                <- compls+              , _label == "fromList"+              ]+        liftIO $ take 3 (sort compls') @?=+          map ("Defined in "<>) (+              [ "'Data.List.NonEmpty"+              , "'GHC.Exts"+              ] ++ if ghcVersion >= GHC94 then [ "'GHC.IsList" ] else [])++  , testSessionWait "Map" $ do+        doc <- createDoc "A.hs" "haskell" $ T.unlines+            [ "{-# OPTIONS_GHC -Wunused-binds #-}",+                "module A () where",+                "a :: Map"+            ]+        _ <- waitForDiagnostics+        compls <- getCompletions doc (Position 2 7)+        let compls' =+              [T.drop 1 $ T.dropEnd 3 d+              | CompletionItem {_documentation = Just (InR (MarkupContent MarkupKind_Markdown d)), _label}+                <- compls+              , _label == "Map"+              ]+        liftIO $ take 3 (sort compls') @?=+          map ("Defined in "<>)+              [ "'Data.Map"+              , "'Data.Map.Lazy"+              , "'Data.Map.Strict"+              ]+  , testSessionWait "no duplicates" $ do+        doc <- createDoc "A.hs" "haskell" $ T.unlines+            [ "{-# OPTIONS_GHC -Wunused-binds #-}",+                "module A () where",+                "import GHC.Exts(fromList)",+                "a = fromList"+            ]+        _ <- waitForDiagnostics+        compls <- getCompletions doc (Position 3 13)+        let duplicate =+              filter+                (\case+                  CompletionItem+                    { _insertText = Just "fromList"+                    , _documentation =+                      Just (InR (MarkupContent MarkupKind_Markdown d))+                    } ->+                    "GHC.Exts" `T.isInfixOf` d+                  _ -> False+                ) compls+        liftIO $ length duplicate @?= 1++  , testSessionWait "non-local before global" $ do+    -- non local completions are more specific+        doc <- createDoc "A.hs" "haskell" $ T.unlines+            [ "{-# OPTIONS_GHC -Wunused-binds #-}",+                "module A () where",+                "import GHC.Exts(fromList)",+                "a = fromList"+            ]+        _ <- waitForDiagnostics+        compls <- getCompletions doc (Position 3 13)+        let compls' =+              [_insertText+              | CompletionItem {_label, _insertText} <- compls+              , _label == "fromList"+              ]+        liftIO $ take 3 compls' @?=+          map Just ["fromList"]+  ]++projectCompletionTests :: [TestTree]+projectCompletionTests =+    [ testSession' "from hiedb" $ \dir-> do+        liftIO $ writeFile (dir </> "hie.yaml")+            "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}"+        _ <- createDoc "A.hs" "haskell" $ T.unlines+            [  "module A (anidentifier) where",+               "anidentifier = ()"+            ]+        _ <- waitForDiagnostics+        -- Note that B does not import A+        doc <- createDoc "B.hs" "haskell" $ T.unlines+            [ "module B where",+              "b = anidenti"+            ]+        compls <- getCompletions doc (Position 1 10)+        let compls' =+              [T.drop 1 $ T.dropEnd 3 d+              | CompletionItem {_documentation = Just (InR (MarkupContent MarkupKind_Markdown d)), _label}+                <- compls+              , _label == "anidentifier"+              ]+        liftIO $ compls' @?= ["Defined in 'A"],+      testSession' "auto complete project imports" $ \dir-> do+        liftIO $ writeFile (dir </> "hie.yaml")+            "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"ALocalModule\", \"B\"]}}"+        _ <- createDoc "ALocalModule.hs" "haskell" $ T.unlines+            [  "module ALocalModule (anidentifier) where",+               "anidentifier = ()"+            ]+        _ <- waitForDiagnostics+        -- Note that B does not import A+        doc <- createDoc "B.hs" "haskell" $ T.unlines+            [ "module B where",+              "import ALocal"+            ]+        compls <- getCompletions doc (Position 1 13)+        let item = head $ filter ((== "ALocalModule") . (^. L.label)) compls+        liftIO $ do+          item ^. L.label @?= "ALocalModule",+      testSession' "auto complete functions from qualified imports without alias" $ \dir-> do+        liftIO $ writeFile (dir </> "hie.yaml")+            "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}"+        _ <- createDoc "A.hs" "haskell" $ T.unlines+            [  "module A (anidentifier) where",+               "anidentifier = ()"+            ]+        _ <- waitForDiagnostics+        doc <- createDoc "B.hs" "haskell" $ T.unlines+            [ "module B where",+              "import qualified A",+              "A."+            ]+        compls <- getCompletions doc (Position 2 2)+        let item = head compls+        liftIO $ do+          item ^. L.label @?= "anidentifier",+      testSession' "auto complete functions from qualified imports with alias" $ \dir-> do+        liftIO $ writeFile (dir </> "hie.yaml")+            "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}"+        _ <- createDoc "A.hs" "haskell" $ T.unlines+            [  "module A (anidentifier) where",+               "anidentifier = ()"+            ]+        _ <- waitForDiagnostics+        doc <- createDoc "B.hs" "haskell" $ T.unlines+            [ "module B where",+              "import qualified A as Alias",+              "foo = Alias."+            ]+        compls <- getCompletions doc (Position 2 12)+        let item = head compls+        liftIO $ do+          item ^. L.label @?= "anidentifier"+    ]++completionDocTests :: [TestTree]+completionDocTests =+  [ testSession "local define" $ do+      doc <- createDoc "A.hs" "haskell" $ T.unlines+        [ "module A where"+        , "foo = ()"+        , "bar = fo"+        ]+      let expected = "*Defined at line 2, column 1 in this module*\n"+      test doc (Position 2 8) "foo" Nothing [expected]+  , testSession "local empty doc" $ do+      doc <- createDoc "A.hs" "haskell" $ T.unlines+        [ "module A where"+        , "foo = ()"+        , "bar = fo"+        ]+      test doc (Position 2 8) "foo" Nothing ["*Defined at line 2, column 1 in this module*\n"]+  , testSession "local single line doc without newline" $ do+      doc <- createDoc "A.hs" "haskell" $ T.unlines+        [ "module A where"+        , "-- |docdoc"+        , "foo = ()"+        , "bar = fo"+        ]+      test doc (Position 3 8) "foo" Nothing ["*Defined at line 3, column 1 in this module*\n* * *\n\n\ndocdoc\n"]+  , testSession "local multi line doc with newline" $ do+      doc <- createDoc "A.hs" "haskell" $ T.unlines+        [ "module A where"+        , "-- | abcabc"+        , "--"+        , "foo = ()"+        , "bar = fo"+        ]+      test doc (Position 4 8) "foo" Nothing ["*Defined at line 4, column 1 in this module*\n* * *\n\n\nabcabc\n"]+  , testSession "local multi line doc without newline" $ do+      doc <- createDoc "A.hs" "haskell" $ T.unlines+        [ "module A where"+        , "-- |     abcabc"+        , "--"+        , "--def"+        , "foo = ()"+        , "bar = fo"+        ]+      test doc (Position 5 8) "foo" Nothing ["*Defined at line 5, column 1 in this module*\n* * *\n\n\nabcabc \n\ndef\n"]+  , testSession "extern empty doc" $ do+      doc <- createDoc "A.hs" "haskell" $ T.unlines+        [ "module A where"+        , "foo = od"+        ]+      let expected = "*Imported from 'Prelude'*\n"+      test doc (Position 1 8) "odd" (Just $ T.length expected) [expected]+  , brokenForMacGhc9 $ brokenForWinGhc90 $ testSession "extern single line doc without '\\n'" $ do+      doc <- createDoc "A.hs" "haskell" $ T.unlines+        [ "module A where"+        , "foo = no"+        ]+      let expected = "*Imported from 'Prelude'*\n* * *\n\n\nBoolean \"not\"\n"+      test doc (Position 1 8) "not" (Just $ T.length expected) [expected]+  , brokenForMacGhc9 $ brokenForWinGhc90 $ testSession "extern mulit line doc" $ do+      doc <- createDoc "A.hs" "haskell" $ T.unlines+        [ "module A where"+        , "foo = i"+        ]+      let expected = "*Imported from 'Prelude'*\n* * *\n\n\nIdentity function. \n```haskell\nid x = x\n```\n"+      test doc (Position 1 7) "id" (Just $ T.length expected) [expected]+  , testSession "extern defined doc" $ do+      doc <- createDoc "A.hs" "haskell" $ T.unlines+        [ "module A where"+        , "foo = i"+        ]+      let expected = "*Imported from 'Prelude'*\n"+      test doc (Position 1 7) "id" (Just $ T.length expected) [expected]+  ]+  where+    brokenForGhc9 = knownBrokenFor (BrokenForGHC [GHC90, GHC92, GHC94, GHC96]) "Completion doc doesn't support ghc9"+    brokenForWinGhc90 = knownBrokenFor (BrokenSpecific Windows [GHC90]) "Extern doc doesn't support Windows for ghc9.2"+    -- https://gitlab.haskell.org/ghc/ghc/-/issues/20903+    brokenForMacGhc9 = knownBrokenFor (BrokenSpecific MacOS [GHC90, GHC92, GHC94, GHC96]) "Extern doc doesn't support MacOS for ghc9"+    test doc pos label mn expected = do+      _ <- waitForDiagnostics+      compls <- getCompletions doc pos+      rcompls <- forM compls $ \item -> do+            if isJust (item ^. L.data_)+            then do+                rsp <- request SMethod_CompletionItemResolve item+                case rsp ^. L.result of+                    Left err -> liftIO $ assertFailure ("completionItem/resolve failed with: " <> show err)+                    Right x -> pure x+            else pure item+      let compls' = [+            -- We ignore doc uris since it points to the local path which determined by specific machines+            case mn of+                Nothing -> txt+                Just n  -> T.take n txt+            | CompletionItem {_documentation = Just (InR (MarkupContent MarkupKind_Markdown txt)), ..} <- rcompls+            , _label == label+            ]+      liftIO $ compls' @?= expected

@@ -0,0 +1,219 @@++{-# LANGUAGE GADTs            #-}+{-# LANGUAGE OverloadedLabels #-}++module CradleTests (tests) where++import           Control.Applicative.Combinators+import           Control.Monad.IO.Class          (liftIO)+import           Data.Row+import qualified Data.Text                       as T+import           Development.IDE.GHC.Compat      (GhcVersion (..), ghcVersion)+import           Development.IDE.GHC.Util+import           Development.IDE.Test            (expectDiagnostics,+                                                  expectDiagnosticsWithTags,+                                                  expectNoMoreDiagnostics,+                                                  isReferenceReady,+                                                  waitForAction)+import           Development.IDE.Types.Location+import qualified Language.LSP.Protocol.Lens      as L+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types     hiding+                                                 (SemanticTokenAbsolute (..),+                                                  SemanticTokenRelative (..),+                                                  SemanticTokensEdit (..),+                                                  mkRange)+import           Language.LSP.Test+import           System.FilePath+import           System.IO.Extra                 hiding (withTempDir)+-- import Test.QuickCheck.Instances ()+import           Control.Lens                    ((^.))+import           Development.IDE.Plugin.Test     (WaitForIdeRuleResult (..))+import           GHC.TypeLits                    (symbolVal)+import           Test.Tasty+import           Test.Tasty.HUnit+import           TestUtils+++tests :: TestTree+tests = testGroup "cradle"+    [testGroup "dependencies" [sessionDepsArePickedUp]+    ,testGroup "ignore-fatal" [ignoreFatalWarning]+    ,testGroup "loading" [loadCradleOnlyonce, retryFailedCradle]+    ,testGroup "multi"   [simpleMultiTest, simpleMultiTest2, simpleMultiTest3, simpleMultiDefTest]+    ,testGroup "sub-directory"   [simpleSubDirectoryTest]+    ]++loadCradleOnlyonce :: TestTree+loadCradleOnlyonce = testGroup "load cradle only once"+    [ testSession' "implicit" implicit+    , testSession' "direct"   direct+    ]+    where+        direct dir = do+            liftIO $ writeFileUTF8 (dir </> "hie.yaml")+                "cradle: {direct: {arguments: []}}"+            test dir+        implicit dir = test dir+        test _dir = do+            doc <- createDoc "B.hs" "haskell" "module B where\nimport Data.Foo"+            msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message SMethod_TextDocumentPublishDiagnostics))+            liftIO $ length msgs @?= 1+            changeDoc doc [TextDocumentContentChangeEvent . InR . (.==) #text $ "module B where\nimport Data.Maybe"]+            msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message SMethod_TextDocumentPublishDiagnostics))+            liftIO $ length msgs @?= 0+            _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar"+            msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message SMethod_TextDocumentPublishDiagnostics))+            liftIO $ length msgs @?= 0++retryFailedCradle :: TestTree+retryFailedCradle = testSession' "retry failed" $ \dir -> do+  -- The false cradle always fails+  let hieContents = "cradle: {bios: {shell: \"false\"}}"+      hiePath = dir </> "hie.yaml"+  liftIO $ writeFile hiePath hieContents+  let aPath = dir </> "A.hs"+  doc <- createDoc aPath "haskell" "main = return ()"+  WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc+  liftIO $ "Test assumption failed: cradle should error out" `assertBool` not ideResultSuccess++  -- Fix the cradle and typecheck again+  let validCradle = "cradle: {bios: {shell: \"echo A.hs\"}}"+  liftIO $ writeFileUTF8 hiePath $ T.unpack validCradle+  sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $+         [FileEvent (filePathToUri $ dir </> "hie.yaml") FileChangeType_Changed ]++  WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc+  liftIO $ "No joy after fixing the cradle" `assertBool` ideResultSuccess+++cradleLoadedMessage :: Session FromServerMessage+cradleLoadedMessage = satisfy $ \case+        FromServerMess (SMethod_CustomMethod p) (NotMess _) -> symbolVal p == cradleLoadedMethod+        _                                            -> False++cradleLoadedMethod :: String+cradleLoadedMethod = "ghcide/cradle/loaded"++ignoreFatalWarning :: TestTree+ignoreFatalWarning = testCase "ignore-fatal-warning" $ runWithExtraFiles "ignore-fatal" $ \dir -> do+    let srcPath = dir </> "IgnoreFatal.hs"+    src <- liftIO $ readFileUtf8 srcPath+    _ <- createDoc srcPath "haskell" src+    expectNoMoreDiagnostics 5++simpleSubDirectoryTest :: TestTree+simpleSubDirectoryTest =+  testCase "simple-subdirectory" $ runWithExtraFiles "cabal-exe" $ \dir -> do+    let mainPath = dir </> "a/src/Main.hs"+    mainSource <- liftIO $ readFileUtf8 mainPath+    _mdoc <- createDoc mainPath "haskell" mainSource+    expectDiagnosticsWithTags+      [("a/src/Main.hs", [(DiagnosticSeverity_Warning,(2,0), "Top-level binding", Nothing)]) -- So that we know P has been loaded+      ]+    expectNoMoreDiagnostics 0.5++simpleMultiTest :: TestTree+simpleMultiTest = testCase "simple-multi-test" $ withLongTimeout $ runWithExtraFiles "multi" $ \dir -> do+    let aPath = dir </> "a/A.hs"+        bPath = dir </> "b/B.hs"+    adoc <- openDoc aPath "haskell"+    bdoc <- openDoc bPath "haskell"+    WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" adoc+    liftIO $ assertBool "A should typecheck" ideResultSuccess+    WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" bdoc+    liftIO $ assertBool "B should typecheck" ideResultSuccess+    locs <- getDefinitions bdoc (Position 2 7)+    let fooL = mkL (adoc ^. L.uri) 2 0 2 3+    checkDefs locs (pure [fooL])+    expectNoMoreDiagnostics 0.5++-- Like simpleMultiTest but open the files in the other order+simpleMultiTest2 :: TestTree+simpleMultiTest2 = testCase "simple-multi-test2" $ runWithExtraFiles "multi" $ \dir -> do+    let aPath = dir </> "a/A.hs"+        bPath = dir </> "b/B.hs"+    bdoc <- openDoc bPath "haskell"+    WaitForIdeRuleResult {} <- waitForAction "TypeCheck" bdoc+    TextDocumentIdentifier auri <- openDoc aPath "haskell"+    skipManyTill anyMessage $ isReferenceReady aPath+    locs <- getDefinitions bdoc (Position 2 7)+    let fooL = mkL auri 2 0 2 3+    checkDefs locs (pure [fooL])+    expectNoMoreDiagnostics 0.5++-- Now with 3 components+simpleMultiTest3 :: TestTree+simpleMultiTest3 =+  testCase "simple-multi-test3" $ runWithExtraFiles "multi" $ \dir -> do+    let aPath = dir </> "a/A.hs"+        bPath = dir </> "b/B.hs"+        cPath = dir </> "c/C.hs"+    bdoc <- openDoc bPath "haskell"+    WaitForIdeRuleResult {} <- waitForAction "TypeCheck" bdoc+    TextDocumentIdentifier auri <- openDoc aPath "haskell"+    skipManyTill anyMessage $ isReferenceReady aPath+    cdoc <- openDoc cPath "haskell"+    WaitForIdeRuleResult {} <- waitForAction "TypeCheck" cdoc+    locs <- getDefinitions cdoc (Position 2 7)+    let fooL = mkL auri 2 0 2 3+    checkDefs locs (pure [fooL])+    expectNoMoreDiagnostics 0.5++-- Like simpleMultiTest but open the files in component 'a' in a separate session+simpleMultiDefTest :: TestTree+simpleMultiDefTest = testCase "simple-multi-def-test" $ runWithExtraFiles "multi" $ \dir -> do+    let aPath = dir </> "a/A.hs"+        bPath = dir </> "b/B.hs"+    adoc <- liftIO $ runInDir dir $ do+      aSource <- liftIO $ readFileUtf8 aPath+      adoc <- createDoc aPath "haskell" aSource+      skipManyTill anyMessage $ isReferenceReady aPath+      closeDoc adoc+      pure adoc+    bSource <- liftIO $ readFileUtf8 bPath+    bdoc <- createDoc bPath "haskell" bSource+    locs <- getDefinitions bdoc (Position 2 7)+    let fooL = mkL (adoc ^. L.uri) 2 0 2 3+    checkDefs locs (pure [fooL])+    expectNoMoreDiagnostics 0.5+++sessionDepsArePickedUp :: TestTree+sessionDepsArePickedUp = testSession'+  "session-deps-are-picked-up"+  $ \dir -> do+    liftIO $+      writeFileUTF8+        (dir </> "hie.yaml")+        "cradle: {direct: {arguments: []}}"+    -- Open without OverloadedStrings and expect an error.+    doc <- createDoc "Foo.hs" "haskell" fooContent+    expectDiagnostics $+        if ghcVersion >= GHC90+            -- String vs [Char] causes this change in error message+            then [("Foo.hs", [(DiagnosticSeverity_Error, (3, 6), "Couldn't match type")])]+            else [("Foo.hs", [(DiagnosticSeverity_Error, (3, 6), "Couldn't match expected type")])]+    -- Update hie.yaml to enable OverloadedStrings.+    liftIO $+      writeFileUTF8+        (dir </> "hie.yaml")+        "cradle: {direct: {arguments: [-XOverloadedStrings]}}"+    sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $+        [FileEvent (filePathToUri $ dir </> "hie.yaml") FileChangeType_Changed ]+    -- Send change event.+    let change =+          TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 4 0) (Position 4 0)+                                              .+ #rangeLength .== Nothing+                                              .+ #text .== "\n"+    changeDoc doc [change]+    -- Now no errors.+    expectDiagnostics [("Foo.hs", [])]+  where+    fooContent =+      T.unlines+        [ "module Foo where",+          "import Data.Text",+          "foo :: Text",+          "foo = \"hello\""+        ]

@@ -0,0 +1,62 @@++{-# LANGUAGE GADTs            #-}+{-# LANGUAGE OverloadedLabels #-}++module DependentFileTest (tests) where++import           Control.Monad.IO.Class         (liftIO)+import           Data.Row+import qualified Data.Text                      as T+import           Development.IDE.GHC.Compat     (GhcVersion (..), ghcVersion)+import           Development.IDE.Test           (expectDiagnostics)+import           Development.IDE.Types.Location+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types    hiding+                                                (SemanticTokenAbsolute (..),+                                                 SemanticTokenRelative (..),+                                                 SemanticTokensEdit (..),+                                                 mkRange)+import           Language.LSP.Test+import           System.FilePath+import           Test.Tasty+import           TestUtils++tests :: TestTree+tests = testGroup "addDependentFile"+    [testGroup "file-changed" [testSession' "test" test]+    ]+    where+      test dir = do+        -- If the file contains B then no type error+        -- otherwise type error+        let depFilePath = dir </> "dep-file.txt"+        liftIO $ writeFile depFilePath "A"+        let fooContent = T.unlines+              [ "{-# LANGUAGE TemplateHaskell #-}"+              , "module Foo where"+              , "import Language.Haskell.TH.Syntax"+              , "foo :: Int"+              , "foo = 1 + $(do"+              , "               qAddDependentFile \"dep-file.txt\""+              , "               f <- qRunIO (readFile \"dep-file.txt\")"+              , "               if f == \"B\" then [| 1 |] else lift f)"+              ]+        let bazContent = T.unlines ["module Baz where", "import Foo ()"]+        _ <- createDoc "Foo.hs" "haskell" fooContent+        doc <- createDoc "Baz.hs" "haskell" bazContent+        expectDiagnostics $+            if ghcVersion >= GHC90+                -- String vs [Char] causes this change in error message+                then [("Foo.hs", [(DiagnosticSeverity_Error, if ghcVersion >= GHC92 then (4,11) else (4, 6), "Couldn't match type")])]+                else [("Foo.hs", [(DiagnosticSeverity_Error, (4, 6), "Couldn't match expected type")])]+        -- Now modify the dependent file+        liftIO $ writeFile depFilePath "B"+        sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $+            [FileEvent (filePathToUri "dep-file.txt") FileChangeType_Changed ]++        -- Modifying Baz will now trigger Foo to be rebuilt as well+        let change = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 2 0) (Position 2 6)+                                                         .+ #rangeLength .== Nothing+                                                         .+ #text .== "f = ()"+        changeDoc doc [change]+        expectDiagnostics [("Foo.hs", [])]

@@ -0,0 +1,565 @@++{-# LANGUAGE GADTs            #-}+{-# LANGUAGE OverloadedLabels #-}++module DiagnosticTests (tests) where++import           Control.Applicative.Combinators+import qualified Control.Lens                    as Lens+import           Control.Monad+import           Control.Monad.IO.Class          (liftIO)+import           Data.List.Extra+import           Data.Row+import qualified Data.Text                       as T+import           Development.IDE.GHC.Compat      (GhcVersion (..), ghcVersion)+import           Development.IDE.GHC.Util+import           Development.IDE.Test            (diagnostic,+                                                  expectCurrentDiagnostics,+                                                  expectDiagnostics,+                                                  expectDiagnosticsWithTags,+                                                  expectNoMoreDiagnostics,+                                                  flushMessages, waitForAction)+import           Development.IDE.Types.Location+import qualified Language.LSP.Protocol.Lens      as L+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types     hiding+                                                 (SemanticTokenAbsolute (..),+                                                  SemanticTokenRelative (..),+                                                  SemanticTokensEdit (..),+                                                  mkRange)+import           Language.LSP.Test+import           System.Directory+import           System.FilePath+import           System.IO.Extra                 hiding (withTempDir)+-- import Test.QuickCheck.Instances ()+import           Control.Lens                    ((^.))+import           Control.Monad.Extra             (whenJust)+import           Development.IDE.Plugin.Test     (WaitForIdeRuleResult (..))+import           System.Time.Extra+import           Test.Tasty+import           Test.Tasty.HUnit+import           TestUtils++tests :: TestTree+tests = testGroup "diagnostics"+  [ testSessionWait "fix syntax error" $ do+      let content = T.unlines [ "module Testing wher" ]+      doc <- createDoc "Testing.hs" "haskell" content+      expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "parse error")])]+      let change = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 0 15) (Position 0 19)+                                                       .+ #rangeLength .== Nothing+                                                       .+ #text .== "where"+      changeDoc doc [change]+      expectDiagnostics [("Testing.hs", [])]+  , testSessionWait "introduce syntax error" $ do+      let content = T.unlines [ "module Testing where" ]+      doc <- createDoc "Testing.hs" "haskell" content+      void $ skipManyTill anyMessage (message SMethod_WindowWorkDoneProgressCreate)+      waitForProgressBegin+      let change = TextDocumentContentChangeEvent$ InL $ #range .== Range (Position 0 15) (Position 0 18)+                                                      .+ #rangeLength .== Nothing+                                                      .+ #text .== "wher"+      changeDoc doc [change]+      expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "parse error")])]+  , testSessionWait "update syntax error" $ do+      let content = T.unlines [ "module Testing(missing) where" ]+      doc <- createDoc "Testing.hs" "haskell" content+      expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "Not in scope: 'missing'")])]+      let change = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 0 15) (Position 0 16)+                                                       .+ #rangeLength .== Nothing+                                                       .+ #text .== "l"+      changeDoc doc [change]+      expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "Not in scope: 'lissing'")])]+  , testSessionWait "variable not in scope" $ do+      let content = T.unlines+            [ "module Testing where"+            , "foo :: Int -> Int -> Int"+            , "foo a _b = a + ab"+            , "bar :: Int -> Int -> Int"+            , "bar _a b = cd + b"+            ]+      _ <- createDoc "Testing.hs" "haskell" content+      expectDiagnostics+        [ ( "Testing.hs"+          , [ (DiagnosticSeverity_Error, (2, 15), "Variable not in scope: ab")+            , (DiagnosticSeverity_Error, (4, 11), "Variable not in scope: cd")+            ]+          )+        ]+  , testSessionWait "type error" $ do+      let content = T.unlines+            [ "module Testing where"+            , "foo :: Int -> String -> Int"+            , "foo a b = a + b"+            ]+      _ <- createDoc "Testing.hs" "haskell" content+      expectDiagnostics+        [ ( "Testing.hs"+          , [(DiagnosticSeverity_Error, (2, 14), "Couldn't match type '[Char]' with 'Int'")]+          )+        ]+  , testSessionWait "typed hole" $ do+      let content = T.unlines+            [ "module Testing where"+            , "foo :: Int -> String"+            , "foo a = _ a"+            ]+      _ <- createDoc "Testing.hs" "haskell" content+      expectDiagnostics+        [ ( "Testing.hs"+          , [(DiagnosticSeverity_Error, (2, 8), "Found hole: _ :: Int -> String")]+          )+        ]++  , testGroup "deferral" $+    let sourceA a = T.unlines+          [ "module A where"+          , "a :: Int"+          , "a = " <> a]+        sourceB = T.unlines+          [ "module B where"+          , "import A ()"+          , "b :: Float"+          , "b = True"]+        bMessage = "Couldn't match expected type 'Float' with actual type 'Bool'"+        expectedDs aMessage =+          [ ("A.hs", [(DiagnosticSeverity_Error, (2,4), aMessage)])+          , ("B.hs", [(DiagnosticSeverity_Error, (3,4), bMessage)])]+        deferralTest title binding msg = testSessionWait title $ do+          _ <- createDoc "A.hs" "haskell" $ sourceA binding+          _ <- createDoc "B.hs" "haskell"   sourceB+          expectDiagnostics $ expectedDs msg+    in+    [ deferralTest "type error"          "True"    "Couldn't match expected type"+    , deferralTest "typed hole"          "_"       "Found hole"+    , deferralTest "out of scope var"    "unbound" "Variable not in scope"+    ]++  , testSessionWait "remove required module" $ do+      let contentA = T.unlines [ "module ModuleA where" ]+      docA <- createDoc "ModuleA.hs" "haskell" contentA+      let contentB = T.unlines+            [ "module ModuleB where"+            , "import ModuleA"+            ]+      _ <- createDoc "ModuleB.hs" "haskell" contentB+      let change = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 0 0) (Position 0 20)+                                                       .+ #rangeLength .== Nothing+                                                       .+ #text .== ""+      changeDoc docA [change]+      expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Error, (1, 0), "Could not find module")])]+  , testSessionWait "add missing module" $ do+      let contentB = T.unlines+            [ "module ModuleB where"+            , "import ModuleA ()"+            ]+      _ <- createDoc "ModuleB.hs" "haskell" contentB+      expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Error, (1, 7), "Could not find module")])]+      let contentA = T.unlines [ "module ModuleA where" ]+      _ <- createDoc "ModuleA.hs" "haskell" contentA+      expectDiagnostics [("ModuleB.hs", [])]+  , testCase "add missing module (non workspace)" $+    -- By default lsp-test sends FileWatched notifications for all files, which we don't want+    -- as non workspace modules will not be watched by the LSP server.+    -- To work around this, we tell lsp-test that our client doesn't have the+    -- FileWatched capability, which is enough to disable the notifications+    withTempDir $ \tmpDir -> runInDir'' lspTestCapsNoFileWatches tmpDir "." "." [] $ do+      let contentB = T.unlines+            [ "module ModuleB where"+            , "import ModuleA ()"+            ]+      _ <- createDoc (tmpDir </> "ModuleB.hs") "haskell" contentB+      expectDiagnostics [(tmpDir </> "ModuleB.hs", [(DiagnosticSeverity_Error, (1, 7), "Could not find module")])]+      let contentA = T.unlines [ "module ModuleA where" ]+      _ <- createDoc (tmpDir </> "ModuleA.hs") "haskell" contentA+      expectDiagnostics [(tmpDir </> "ModuleB.hs", [])]+  , testSessionWait "cyclic module dependency" $ do+      let contentA = T.unlines+            [ "module ModuleA where"+            , "import ModuleB"+            ]+      let contentB = T.unlines+            [ "module ModuleB where"+            , "import ModuleA"+            ]+      _ <- createDoc "ModuleA.hs" "haskell" contentA+      _ <- createDoc "ModuleB.hs" "haskell" contentB+      expectDiagnostics+        [ ( "ModuleA.hs"+          , [(DiagnosticSeverity_Error, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]+          )+        , ( "ModuleB.hs"+          , [(DiagnosticSeverity_Error, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]+          )+        ]+  , testSession' "deeply nested cyclic module dependency" $ \path -> do+      let contentA = unlines+            [ "module ModuleA where" , "import ModuleB" ]+      let contentB = unlines+            [ "module ModuleB where" , "import ModuleA" ]+      let contentC = unlines+            [ "module ModuleC where" , "import ModuleB" ]+      let contentD = T.unlines+            [ "module ModuleD where" , "import ModuleC" ]+          cradle =+            "cradle: {direct: {arguments: [ModuleA, ModuleB, ModuleC, ModuleD]}}"+      liftIO $ writeFile (path </> "ModuleA.hs") contentA+      liftIO $ writeFile (path </> "ModuleB.hs") contentB+      liftIO $ writeFile (path </> "ModuleC.hs") contentC+      liftIO $ writeFile (path </> "hie.yaml") cradle+      _ <- createDoc "ModuleD.hs" "haskell" contentD+      expectDiagnostics+        [ ( "ModuleB.hs"+          , [(DiagnosticSeverity_Error, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]+          )+        ]+  , testSessionWait "cyclic module dependency with hs-boot" $ do+      let contentA = T.unlines+            [ "module ModuleA where"+            , "import {-# SOURCE #-} ModuleB"+            ]+      let contentB = T.unlines+            [ "{-# OPTIONS -Wmissing-signatures#-}"+            , "module ModuleB where"+            , "import ModuleA"+            -- introduce an artificial diagnostic+            , "foo = ()"+            ]+      let contentBboot = T.unlines+            [ "module ModuleB where"+            ]+      _ <- createDoc "ModuleA.hs" "haskell" contentA+      _ <- createDoc "ModuleB.hs" "haskell" contentB+      _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot+      expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Warning, (3,0), "Top-level binding")])]+  , testSessionWait "correct reference used with hs-boot" $ do+      let contentB = T.unlines+            [ "module ModuleB where"+            , "import {-# SOURCE #-} ModuleA()"+            ]+      let contentA = T.unlines+            [ "module ModuleA where"+            , "import ModuleB()"+            , "x = 5"+            ]+      let contentAboot = T.unlines+            [ "module ModuleA where"+            ]+      let contentC = T.unlines+            [ "{-# OPTIONS -Wmissing-signatures #-}"+            , "module ModuleC where"+            , "import ModuleA"+            -- this reference will fail if it gets incorrectly+            -- resolved to the hs-boot file+            , "y = x"+            ]+      _ <- createDoc "ModuleB.hs" "haskell" contentB+      _ <- createDoc "ModuleA.hs" "haskell" contentA+      _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot+      _ <- createDoc "ModuleC.hs" "haskell" contentC+      expectDiagnostics [("ModuleC.hs", [(DiagnosticSeverity_Warning, (3,0), "Top-level binding")])]+  , testSessionWait "redundant import" $ do+      let contentA = T.unlines ["module ModuleA where"]+      let contentB = T.unlines+            [ "{-# OPTIONS_GHC -Wunused-imports #-}"+            , "module ModuleB where"+            , "import ModuleA"+            ]+      _ <- createDoc "ModuleA.hs" "haskell" contentA+      _ <- createDoc "ModuleB.hs" "haskell" contentB+      expectDiagnosticsWithTags+        [ ( "ModuleB.hs"+          , [(DiagnosticSeverity_Warning, (2, 0), "The import of 'ModuleA' is redundant", Just DiagnosticTag_Unnecessary)]+          )+        ]+  , testSessionWait "redundant import even without warning" $ do+      let contentA = T.unlines ["module ModuleA where"]+      let contentB = T.unlines+            [ "{-# OPTIONS_GHC -Wno-unused-imports -Wmissing-signatures #-}"+            , "module ModuleB where"+            , "import ModuleA"+            -- introduce an artificial warning for testing purposes+            , "foo = ()"+            ]+      _ <- createDoc "ModuleA.hs" "haskell" contentA+      _ <- createDoc "ModuleB.hs" "haskell" contentB+      expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Warning, (3,0), "Top-level binding")])]+  , testSessionWait "package imports" $ do+      let thisDataListContent = T.unlines+            [ "module Data.List where"+            , "x :: Integer"+            , "x = 123"+            ]+      let mainContent = T.unlines+            [ "{-# LANGUAGE PackageImports #-}"+            , "module Main where"+            , "import qualified \"this\" Data.List as ThisList"+            , "import qualified \"base\" Data.List as BaseList"+            , "useThis = ThisList.x"+            , "useBase = BaseList.map"+            , "wrong1 = ThisList.map"+            , "wrong2 = BaseList.x"+            , "main = pure ()"+            ]+      _ <- createDoc "Data/List.hs" "haskell" thisDataListContent+      _ <- createDoc "Main.hs" "haskell" mainContent+      expectDiagnostics+        [ ( "Main.hs"+          , [(DiagnosticSeverity_Error, (6, 9),+                if ghcVersion >= GHC96 then+                  "Variable not in scope: ThisList.map"+                else if ghcVersion >= GHC94 then+                  "Variable not in scope: map" -- See https://gitlab.haskell.org/ghc/ghc/-/issues/22130+                else+                  "Not in scope: \8216ThisList.map\8217")+            ,(DiagnosticSeverity_Error, (7, 9),+                if ghcVersion >= GHC96 then+                  "Variable not in scope: BaseList.x"+                else if ghcVersion >= GHC94 then+                  "Variable not in scope: x" -- See https://gitlab.haskell.org/ghc/ghc/-/issues/22130+                else+                  "Not in scope: \8216BaseList.x\8217")+            ]+          )+        ]+  , testSessionWait "unqualified warnings" $ do+      let fooContent = T.unlines+            [ "{-# OPTIONS_GHC -Wredundant-constraints #-}"+            , "module Foo where"+            , "foo :: Ord a => a -> Int"+            , "foo _a = 1"+            ]+      _ <- createDoc "Foo.hs" "haskell" fooContent+      expectDiagnostics+        [ ( "Foo.hs"+      -- The test is to make sure that warnings contain unqualified names+      -- where appropriate. The warning should use an unqualified name 'Ord', not+      -- something like 'GHC.Classes.Ord'. The choice of redundant-constraints to+      -- test this is fairly arbitrary.+          , [(DiagnosticSeverity_Warning, (2, if ghcVersion >= GHC94 then 7 else 0), "Redundant constraint: Ord a")+            ]+          )+        ]+    , testSessionWait "lower-case drive" $ do+          let aContent = T.unlines+                [ "module A.A where"+                , "import A.B ()"+                ]+              bContent = T.unlines+                [ "{-# OPTIONS_GHC -Wall #-}"+                , "module A.B where"+                , "import Data.List"+                ]+          uriB <- getDocUri "A/B.hs"+          Just pathB <- pure $ uriToFilePath uriB+          uriB <- pure $+              let (drive, suffix) = splitDrive pathB+              in filePathToUri (joinDrive (lower drive) suffix)+          liftIO $ createDirectoryIfMissing True (takeDirectory pathB)+          liftIO $ writeFileUTF8 pathB $ T.unpack bContent+          uriA <- getDocUri "A/A.hs"+          Just pathA <- pure $ uriToFilePath uriA+          uriA <- pure $+              let (drive, suffix) = splitDrive pathA+              in filePathToUri (joinDrive (lower drive) suffix)+          let itemA = TextDocumentItem uriA "haskell" 0 aContent+          let a = TextDocumentIdentifier uriA+          sendNotification SMethod_TextDocumentDidOpen (DidOpenTextDocumentParams itemA)+          TNotificationMessage{_params = PublishDiagnosticsParams fileUri _ diags} <- skipManyTill anyMessage diagnostic+          -- Check that if we put a lower-case drive in for A.A+          -- the diagnostics for A.B will also be lower-case.+          liftIO $ fileUri @?= uriB+          let msg :: T.Text = (head diags) ^. L.message+          liftIO $ unless ("redundant" `T.isInfixOf` msg) $+              assertFailure ("Expected redundant import but got " <> T.unpack msg)+          closeDoc a+  , testSessionWait "haddock parse error" $ do+      let fooContent = T.unlines+            [ "module Foo where"+            , "foo :: Int"+            , "foo = 1 {-|-}"+            ]+      _ <- createDoc "Foo.hs" "haskell" fooContent+      if ghcVersion >= GHC90 then+          -- Haddock parse errors are ignored on ghc-9.0+            pure ()+      else+        expectDiagnostics+            [ ( "Foo.hs"+              , [(DiagnosticSeverity_Warning, (2, 8), "Haddock parse error on input")]+              )+            ]+  , testSessionWait "strip file path" $ do+      let+          name = "Testing"+          content = T.unlines+            [ "module " <> name <> " where"+            , "value :: Maybe ()"+            , "value = [()]"+            ]+      _ <- createDoc (T.unpack name <> ".hs") "haskell" content+      notification <- skipManyTill anyMessage diagnostic+      let+          offenders =+            L.params .+            L.diagnostics .+            Lens.folded .+            L.message .+            Lens.filtered (T.isInfixOf ("/" <> name <> ".hs:"))+          failure msg = liftIO $ assertFailure $ "Expected file path to be stripped but got " <> T.unpack msg+      Lens.mapMOf_ offenders failure notification+  , testSession' "-Werror in cradle is ignored" $ \sessionDir -> do+      liftIO $ writeFile (sessionDir </> "hie.yaml")+        "cradle: {direct: {arguments: [\"-Wall\", \"-Werror\"]}}"+      let fooContent = T.unlines+            [ "module Foo where"+            , "foo = ()"+            ]+      _ <- createDoc "Foo.hs" "haskell" fooContent+      expectDiagnostics+        [ ( "Foo.hs"+          , [(DiagnosticSeverity_Warning, (1, 0), "Top-level binding with no type signature:")+            ]+          )+        ]+  , testSessionWait "-Werror in pragma is ignored" $ do+      let fooContent = T.unlines+            [ "{-# OPTIONS_GHC -Wall -Werror #-}"+            , "module Foo() where"+            , "foo :: Int"+            , "foo = 1"+            ]+      _ <- createDoc "Foo.hs" "haskell" fooContent+      expectDiagnostics+        [ ( "Foo.hs"+          , [(DiagnosticSeverity_Warning, (3, 0), "Defined but not used:")+            ]+          )+        ]+  , testCase "typecheck-all-parents-of-interest" $ runWithExtraFiles "recomp" $ \dir -> do+    let bPath = dir </> "B.hs"+        pPath = dir </> "P.hs"+        aPath = dir </> "A.hs"++    bSource <- liftIO $ readFileUtf8 bPath -- y :: Int+    pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int+    aSource <- liftIO $ readFileUtf8 aPath -- x = y :: Int++    bdoc <- createDoc bPath "haskell" bSource+    _pdoc <- createDoc pPath "haskell" pSource+    expectDiagnostics+      [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")])] -- So that we know P has been loaded++    -- Change y from Int to B which introduces a type error in A (imported from P)+    changeDoc bdoc [TextDocumentContentChangeEvent . InR . (.==) #text $+                    T.unlines ["module B where", "y :: Bool", "y = undefined"]]+    expectDiagnostics+      [("A.hs", [(DiagnosticSeverity_Error, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])+      ]++    -- Open A and edit to fix the type error+    adoc <- createDoc aPath "haskell" aSource+    changeDoc adoc [TextDocumentContentChangeEvent . InR . (.==) #text $+                    T.unlines ["module A where", "import B", "x :: Bool", "x = y"]]++    expectDiagnostics+      [ ( "P.hs",+          [ (DiagnosticSeverity_Error, (4, 6), "Couldn't match expected type 'Int' with actual type 'Bool'"),+            (DiagnosticSeverity_Warning, (4, 0), "Top-level binding")+          ]+        ),+        ("A.hs", [])+      ]+    expectNoMoreDiagnostics 1++  , testSessionWait "deduplicate missing module diagnostics" $  do+      let fooContent = T.unlines [ "module Foo() where" , "import MissingModule" ]+      doc <- createDoc "Foo.hs" "haskell" fooContent+      expectDiagnostics [("Foo.hs", [(DiagnosticSeverity_Error, (1,7), "Could not find module 'MissingModule'")])]++      changeDoc doc [TextDocumentContentChangeEvent  . InR . (.==) #text $ "module Foo() where" ]+      expectDiagnostics []++      changeDoc doc [TextDocumentContentChangeEvent  . InR . (.==) #text $ T.unlines+            [ "module Foo() where" , "import MissingModule" ] ]+      expectDiagnostics [("Foo.hs", [(DiagnosticSeverity_Error, (1,7), "Could not find module 'MissingModule'")])]++  , testGroup "Cancellation"+    [ cancellationTestGroup "edit header" editHeader yesSession noParse  noTc+    , cancellationTestGroup "edit import" editImport noSession  yesParse noTc+    , cancellationTestGroup "edit body"   editBody   yesSession yesParse yesTc+    ]+  ]+  where+      editPair x y = let p = Position x y ; p' = Position x (y+2) in+        (TextDocumentContentChangeEvent $ InL $ #range .== Range p p+                                             .+ #rangeLength .== Nothing+                                             .+ #text .== "fd"+        ,TextDocumentContentChangeEvent $ InL $ #range .== Range p p'+                                             .+ #rangeLength .== Nothing+                                             .+ #text .== "")+      editHeader = editPair 0 0+      editImport = editPair 2 10+      editBody   = editPair 3 10++      noParse = False+      yesParse = True++      noSession = False+      yesSession = True++      noTc = False+      yesTc = True++cancellationTestGroup :: TestName -> (TextDocumentContentChangeEvent, TextDocumentContentChangeEvent) -> Bool -> Bool -> Bool -> TestTree+cancellationTestGroup name edits sessionDepsOutcome parseOutcome tcOutcome = testGroup name+    [ cancellationTemplate edits Nothing+    , cancellationTemplate edits $ Just ("GetFileContents", True)+    , cancellationTemplate edits $ Just ("GhcSession", True)+      -- the outcome for GetModSummary is always True because parseModuleHeader never fails (!)+    , cancellationTemplate edits $ Just ("GetModSummary", True)+    , cancellationTemplate edits $ Just ("GetModSummaryWithoutTimestamps", True)+      -- getLocatedImports never fails+    , cancellationTemplate edits $ Just ("GetLocatedImports", True)+    , cancellationTemplate edits $ Just ("GhcSessionDeps", sessionDepsOutcome)+    , cancellationTemplate edits $ Just ("GetParsedModule", parseOutcome)+    , cancellationTemplate edits $ Just ("TypeCheck", tcOutcome)+    , cancellationTemplate edits $ Just ("GetHieAst", tcOutcome)+    ]++cancellationTemplate :: (TextDocumentContentChangeEvent, TextDocumentContentChangeEvent) -> Maybe (String, Bool) -> TestTree+cancellationTemplate (edit, undoEdit) mbKey = testCase (maybe "-" fst mbKey) $ runTestNoKick $ do+      doc <- createDoc "Foo.hs" "haskell" $ T.unlines+            [ "{-# OPTIONS_GHC -Wall #-}"+            , "module Foo where"+            , "import Data.List()"+            , "f0 x = (x,x)"+            ]++      -- for the example above we expect one warning+      let missingSigDiags = [(DiagnosticSeverity_Warning, (3, 0), "Top-level binding") ]+      typeCheck doc >> expectCurrentDiagnostics doc missingSigDiags++      -- Now we edit the document and wait for the given key (if any)+      changeDoc doc [edit]+      whenJust mbKey $ \(key, expectedResult) -> do+        WaitForIdeRuleResult{ideResultSuccess} <- waitForAction key doc+        liftIO $ ideResultSuccess @?= expectedResult++      -- The 2nd edit cancels the active session and unbreaks the file+      -- wait for typecheck and check that the current diagnostics are accurate+      changeDoc doc [undoEdit]+      typeCheck doc >> expectCurrentDiagnostics doc missingSigDiags++      expectNoMoreDiagnostics 0.5+    where+        -- similar to run except it disables kick+        runTestNoKick s = withTempDir $ \dir -> runInDir' dir "." "." ["--test-no-kick"] s++        typeCheck doc = do+            WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc+            liftIO $ assertBool "The file should typecheck" ideResultSuccess+            -- wait for the debouncer to publish diagnostics if the rule runs+            liftIO $ sleep 0.2+            -- flush messages to ensure current diagnostics state is updated+            flushMessages

@@ -0,0 +1,155 @@++module ExceptionTests (tests) where++import           Control.Exception                 (ArithException (DivideByZero),+                                                    throwIO)+import           Control.Lens+import           Control.Monad.Error.Class         (MonadError (throwError))+import           Control.Monad.IO.Class            (liftIO)+import qualified Data.Aeson                        as A+import           Data.Text                         as T+import           Development.IDE.Core.Shake        (IdeState (..))+import qualified Development.IDE.LSP.Notifications as Notifications+import qualified Development.IDE.Main              as IDE+import           Development.IDE.Plugin.HLS        (toResponseError)+import           Development.IDE.Plugin.Test       as Test+import           Development.IDE.Types.Options+import           GHC.Base                          (coerce)+import           Ide.Logger                        (Logger, Recorder,+                                                    WithPriority, cmapWithPrio)+import           Ide.Plugin.Error+import           Ide.PluginUtils                   (idePluginsToPluginDesc,+                                                    pluginDescToIdePlugins)+import           Ide.Types+import qualified Language.LSP.Protocol.Lens        as L+import           Language.LSP.Protocol.Message+import           Language.LSP.Protocol.Types       hiding+                                                   (SemanticTokenAbsolute (..),+                                                    SemanticTokenRelative (..),+                                                    SemanticTokensEdit (..),+                                                    mkRange)+import           Language.LSP.Test+import           LogType                           (Log (..))+import           Test.Tasty+import           Test.Tasty.HUnit+import           TestUtils++tests :: Recorder (WithPriority Log) -> Logger -> TestTree+tests recorder logger = do+  testGroup "Exceptions and PluginError" [+    testGroup "Testing that IO Exceptions are caught in..."+      [ testCase "PluginHandlers" $ do+          let pluginId = "plugin-handler-exception"+              plugins = pluginDescToIdePlugins $+                  [ (defaultPluginDescriptor pluginId)+                      { pluginHandlers = mconcat+                          [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do+                              _ <- liftIO $ throwIO DivideByZero+                              pure (InL [])+                          ]+                      }]+          testIde recorder (testingLite recorder logger plugins) $ do+              doc <- createDoc "A.hs" "haskell" "module A where"+              waitForProgressDone+              (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc)+              case lens of+                Left (ResponseError {_code = InR ErrorCodes_InternalError, _message}) ->+                  liftIO $ assertBool "We caught an error, but it wasn't ours!"+                          (T.isInfixOf "divide by zero" _message && T.isInfixOf (coerce pluginId) _message)+                _ -> liftIO $ assertFailure $ show lens++        , testCase "Commands" $ do+          let pluginId = "command-exception"+              commandId = CommandId "exception"+              plugins = pluginDescToIdePlugins $+                  [ (defaultPluginDescriptor pluginId)+                      { pluginCommands =+                          [ PluginCommand commandId "Causes an exception" $ \_ (_::Int) -> do+                              _ <- liftIO $ throwIO DivideByZero+                              pure (InR Null)+                          ]+                      }]+          testIde recorder (testingLite recorder logger plugins) $ do+              _ <- createDoc "A.hs" "haskell" "module A where"+              waitForProgressDone+              let cmd = mkLspCommand (coerce pluginId) commandId "" (Just [A.toJSON (1::Int)])+                  execParams = ExecuteCommandParams Nothing (cmd ^. L.command) (cmd ^. L.arguments)+              (view L.result -> res) <- request SMethod_WorkspaceExecuteCommand execParams+              case res of+                Left (ResponseError {_code = InR ErrorCodes_InternalError, _message}) ->+                  liftIO $ assertBool "We caught an error, but it wasn't ours!"+                          (T.isInfixOf "divide by zero" _message && T.isInfixOf (coerce pluginId) _message)+                _ -> liftIO $ assertFailure $ show res++        , testCase "Notification Handlers" $ do+          let pluginId = "notification-exception"+              plugins = pluginDescToIdePlugins $+                  [ (defaultPluginDescriptor pluginId)+                      { pluginNotificationHandlers = mconcat+                          [  mkPluginNotificationHandler SMethod_TextDocumentDidOpen $ \_ _ _ _ ->+                              liftIO $ throwIO DivideByZero+                          ]+                        , pluginHandlers = mconcat+                          [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do+                              pure (InL [])+                          ]+                      }]+          testIde recorder (testingLite recorder logger plugins) $ do+              doc <- createDoc "A.hs" "haskell" "module A where"+              waitForProgressDone+              (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc)+              case lens of+                Right (InL []) ->+                  -- We don't get error responses from notification handlers, so+                  -- we can only make sure that the server is still responding+                  pure ()+                _ -> liftIO $ assertFailure $ "We should have had an empty list" <> show lens]++   , testGroup "Testing PluginError order..."+      [ pluginOrderTestCase recorder logger  "InternalError over InvalidParams" PluginInternalError PluginInvalidParams+      , pluginOrderTestCase recorder logger  "InvalidParams over InvalidUserState" PluginInvalidParams PluginInvalidUserState+      , pluginOrderTestCase recorder logger  "InvalidUserState over RequestRefused" PluginInvalidUserState PluginRequestRefused+      ]+   ]++testingLite :: Recorder (WithPriority Log) -> Logger -> IdePlugins IdeState -> IDE.Arguments+testingLite recorder logger plugins =+  let+    arguments@IDE.Arguments{ argsIdeOptions } =+        IDE.defaultArguments (cmapWithPrio LogIDEMain recorder) logger plugins+    hlsPlugins = pluginDescToIdePlugins $+      idePluginsToPluginDesc plugins+      ++ [Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core"]+      ++ [Test.blockCommandDescriptor "block-command", Test.plugin]+    ideOptions config sessionLoader =+      let+        defOptions = argsIdeOptions config sessionLoader+      in+        defOptions{ optTesting = IdeTesting True }+  in+    arguments+      { IDE.argsHlsPlugins = hlsPlugins+      , IDE.argsIdeOptions = ideOptions+      }++pluginOrderTestCase :: Recorder (WithPriority Log) -> Logger -> TestName -> (T.Text -> PluginError) -> (T.Text -> PluginError) -> TestTree+pluginOrderTestCase recorder logger msg err1 err2 =+  testCase msg $ do+      let pluginId = "error-order-test"+          plugins = pluginDescToIdePlugins $+              [ (defaultPluginDescriptor pluginId)+                  { pluginHandlers = mconcat+                      [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do+                          throwError $ err1 "error test"+                        ,mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do+                          throwError $ err2 "error test"+                      ]+                  }]+      testIde recorder (testingLite recorder logger plugins) $ do+          doc <- createDoc "A.hs" "haskell" "module A where"+          waitForProgressDone+          (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc)+          case lens of+            Left re | toResponseError (pluginId, err1 "error test") == re -> pure ()+                    | otherwise -> liftIO $ assertFailure "We caught an error, but it wasn't ours!"+            _ -> liftIO $ assertFailure $ show lens

@@ -0,0 +1,252 @@++{-# LANGUAGE MultiWayIf #-}++module FindDefinitionAndHoverTests (tests) where++import           Control.Monad+import           Control.Monad.IO.Class         (liftIO)+import           Data.Foldable+import           Data.Maybe+import qualified Data.Text                      as T+import           Development.IDE.GHC.Compat     (GhcVersion (..), ghcVersion)+import           Development.IDE.GHC.Util+import           Development.IDE.Test           (expectDiagnostics,+                                                 standardizeQuotes)+import           Development.IDE.Types.Location+import qualified Language.LSP.Protocol.Lens     as L+import           Language.LSP.Protocol.Types    hiding+                                                (SemanticTokenAbsolute (..),+                                                 SemanticTokenRelative (..),+                                                 SemanticTokensEdit (..),+                                                 mkRange)+import           Language.LSP.Test+import           System.FilePath+import           System.Info.Extra              (isWindows)+-- import Test.QuickCheck.Instances ()+import           Control.Lens                   ((^.))+import           Test.Tasty+import           Test.Tasty.HUnit+import           TestUtils+import           Text.Regex.TDFA                ((=~))++tests :: TestTree+tests = let++  tst :: (TextDocumentIdentifier -> Position -> Session a, a -> Session [Expect] -> Session ()) -> Position -> String -> Session [Expect] -> String -> TestTree+  tst (get, check) pos sfp targetRange title = testSessionWithExtraFiles "hover" title $ \dir -> do++    -- Dirty the cache to check that definitions work even in the presence of iface files+    liftIO $ runInDir dir $ do+      let fooPath = dir </> "Foo.hs"+      fooSource <- liftIO $ readFileUtf8 fooPath+      fooDoc <- createDoc fooPath "haskell" fooSource+      _ <- getHover fooDoc $ Position 4 3+      closeDoc fooDoc++    doc <- openTestDataDoc (dir </> sfp)+    waitForProgressDone+    found <- get doc pos+    check found targetRange++++  checkHover :: Maybe Hover -> Session [Expect] -> Session ()+  checkHover hover expectations = traverse_ check =<< expectations where++    check expected =+      case hover of+        Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found"+        Just Hover{_contents = (InL MarkupContent{_value = standardizeQuotes -> msg})+                  ,_range    = rangeInHover } ->+          case expected of+            ExpectRange  expectedRange -> checkHoverRange expectedRange rangeInHover msg+            ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg+            ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets+            ExpectHoverExcludeText snippets -> liftIO $ traverse_ (`assertNotFoundIn` msg) snippets+            ExpectHoverTextRegex re -> liftIO $ assertBool ("Regex not found in " <> T.unpack msg) (msg =~ re :: Bool)+            ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover+            _ -> pure () -- all other expectations not relevant to hover+        _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover++  extractLineColFromHoverMsg :: T.Text -> [T.Text]+  extractLineColFromHoverMsg = T.splitOn ":" . head . T.splitOn "*" . last . T.splitOn (sourceFileName <> ":")++  checkHoverRange :: Range -> Maybe Range -> T.Text -> Session ()+  checkHoverRange expectedRange rangeInHover msg =+    let+      lineCol = extractLineColFromHoverMsg msg+      -- looks like hovers use 1-based numbering while definitions use 0-based+      -- turns out that they are stored 1-based in RealSrcLoc by GHC itself.+      adjust Position{_line = l, _character = c} =+        Position{_line = l + 1, _character = c + 1}+    in+    case map (read . T.unpack) lineCol of+      [l,c] -> liftIO $ adjust (expectedRange ^. L.start) @=? Position l c+      _     -> liftIO $ assertFailure $+        "expected: " <> show ("[...]" <> sourceFileName <> ":<LINE>:<COL>**[...]", Just expectedRange) <>+        "\n but got: " <> show (msg, rangeInHover)++  assertFoundIn :: T.Text -> T.Text -> Assertion+  assertFoundIn part whole = assertBool+    (T.unpack $ "failed to find: `" <> part <> "` in hover message:\n" <> whole)+    (part `T.isInfixOf` whole)++  assertNotFoundIn :: T.Text -> T.Text -> Assertion+  assertNotFoundIn part whole = assertBool+    (T.unpack $ "found unexpected: `" <> part <> "` in hover message:\n" <> whole)+    (not . T.isInfixOf part $ whole)++  sourceFilePath = T.unpack sourceFileName+  sourceFileName = "GotoHover.hs"++  mkFindTests tests = testGroup "get"+    [ testGroup "definition" $ mapMaybe fst tests+    , testGroup "hover"      $ mapMaybe snd tests+    , checkFileCompiles sourceFilePath $+        expectDiagnostics+          [ ( "GotoHover.hs", [(DiagnosticSeverity_Error, (62, 7), "Found hole: _")])+          , ( "GotoHover.hs", [(DiagnosticSeverity_Error, (65, 8), "Found hole: _")])+          ]+    , testGroup "type-definition" typeDefinitionTests+    , testGroup "hover-record-dot-syntax" recordDotSyntaxTests ]++  typeDefinitionTests = [ tst (getTypeDefinitions, checkDefs) aaaL14 sourceFilePath (pure tcData) "Saturated data con"+                        , tst (getTypeDefinitions, checkDefs) aL20 sourceFilePath (pure [ExpectNoDefinitions]) "Polymorphic variable"]++  recordDotSyntaxTests+    | ghcVersion >= GHC92 =+        [ tst (getHover, checkHover) (Position 19 24) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["x :: MyRecord"]]) "hover over parent"+        , tst (getHover, checkHover) (Position 19 25) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over dot shows child"+        , tst (getHover, checkHover) (Position 19 26) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over child"+        ]+    | otherwise = []++  test runDef runHover look expect = testM runDef runHover look (return expect)++  testM runDef runHover look expect title =+    ( runDef   $ tst def   look sourceFilePath expect title+    , runHover $ tst hover look sourceFilePath expect title ) where+      def   = (getDefinitions, checkDefs)+      hover = (getHover      , checkHover)++  -- search locations            expectations on results+  fffL4  = fffR  ^. L.start;  fffR = mkRange 8  4    8  7 ; fff  = [ExpectRange fffR]+  fffL8  = Position 12  4  ;+  fffL14 = Position 18  7  ;+  aL20   = Position 19 15+  aaaL14 = Position 18 20  ;  aaa    = [mkR  11  0   11  3]+  dcL7   = Position 11 11  ;  tcDC   = [mkR   7 23    9 16]+  dcL12  = Position 16 11  ;+  xtcL5  = Position  9 11  ;  xtc    = [ExpectExternFail,   ExpectHoverText ["Int", "Defined in ", "GHC.Types", "ghc-prim"]]+  tcL6   = Position 10 11  ;  tcData = [mkR   7  0    9 16, ExpectHoverText ["TypeConstructor", "GotoHover.hs:8:1"]]+  vvL16  = Position 20 12  ;  vv     = [mkR  20  4   20  6]+  opL16  = Position 20 15  ;  op     = [mkR  21  2   21  4]+  opL18  = Position 22 22  ;  opp    = [mkR  22 13   22 17]+  aL18   = Position 22 20  ;  apmp   = [mkR  22 10   22 11]+  b'L19  = Position 23 13  ;  bp     = [mkR  23  6   23  7]+  xvL20  = Position 24  8  ;  xvMsg  = [ExpectExternFail,   ExpectHoverText ["pack", ":: String -> Text", "Data.Text", "text"]]+  clL23  = Position 27 11  ;  cls    = [mkR  25  0   26 20, ExpectHoverText ["MyClass", "GotoHover.hs:26:1"]]+  clL25  = Position 29  9+  eclL15 = Position 19  8  ;  ecls   = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ", "GHC.Num", "base"]]+  dnbL29 = Position 33 18  ;  dnb    = [ExpectHoverText [":: ()"],   mkR  33 12   33 21]+  dnbL30 = Position 34 23+  lcbL33 = Position 37 26  ;  lcb    = [ExpectHoverText [":: Char"], mkR  37 26   37 27]+  lclL33 = Position 37 22+  mclL36 = Position 40  1  ;  mcl    = [mkR  40  0   40 14]+  mclL37 = Position 41  1+  spaceL37 = Position 41  24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]]+  docL41 = Position 45  1  ;  doc    = [ExpectHoverText ["Recognizable docs: kpqz"]]+                           ;  constr = [ExpectHoverText ["Monad m"]]+  eitL40 = Position 44 28  ;  kindE  = [ExpectHoverText [if ghcVersion >= GHC92 then ":: Type -> Type -> Type\n" else ":: * -> * -> *\n"]]+  intL40 = Position 44 34  ;  kindI  = [ExpectHoverText [if ghcVersion >= GHC92 then ":: Type\n" else ":: *\n"]]+  tvrL40 = Position 44 37  ;  kindV  = [ExpectHoverText [":: * -> *\n"]]+  intL41 = Position 45 20  ;  litI   = [ExpectHoverText ["7518"]]+  chrL36 = Position 41 24  ;  litC   = [ExpectHoverText ["'f'"]]+  txtL8  = Position 12 14  ;  litT   = [ExpectHoverText ["\"dfgy\""]]+  lstL43 = Position 47 12  ;  litL   = [ExpectHoverText ["[8391 :: Int, 6268]"]]+  outL45 = Position 49  3  ;  outSig = [ExpectHoverText ["outer", "Bool"], mkR 50 0 50 5]+  innL48 = Position 52  5  ;  innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7]+  holeL60 = Position 62 7  ;  hleInfo = [ExpectHoverText ["_ ::"]]+  holeL65 = Position 65 8  ;  hleInfo2 = [ExpectHoverText ["_ :: a -> Maybe a"]]+  cccL17 = Position 17 16  ;  docLink = [ExpectHoverTextRegex "\\*Defined in 'GHC.Types'\\* \\*\\(ghc-prim-[0-9.]+\\)\\*\n\n"]+  imported = Position 56 13 ; importedSig = getDocUri "Foo.hs" >>= \foo -> return [ExpectHoverText ["foo", "Foo", "Haddock"], mkL foo 5 0 5 3]+  reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar", "Haddock"], mkL bar 3 (if ghcVersion >= GHC94 then 5 else 0) 3 (if ghcVersion >= GHC94 then 8 else 14)]+  thLocL57 = Position 59 10 ; thLoc = [ExpectHoverText ["Identity"]]+  cmtL68 = Position 67  0  ;  lackOfdEq = [ExpectHoverExcludeText ["$dEq"]]+  import310 = Position 3 10; pkgTxt = [ExpectHoverText ["Data.Text\n\ntext-"]]+  in+  mkFindTests+  --      def    hover  look       expect+  [+    if ghcVersion >= GHC90 then+        -- It suggests either going to the constructor or to the field+        test  broken yes    fffL4      fff           "field in record definition"+    else+        test  yes    yes    fffL4      fff           "field in record definition"+  , test  yes    yes    fffL8      fff           "field in record construction    #1102"+  , test  yes    yes    fffL14     fff           "field name used as accessor"           -- https://github.com/haskell/ghcide/pull/120 in Calculate.hs+  , test  yes    yes    aaaL14     aaa           "top-level name"                        -- https://github.com/haskell/ghcide/pull/120+  , test  yes    yes    dcL7       tcDC          "data constructor record         #1029"+  , test  yes    yes    dcL12      tcDC          "data constructor plain"                -- https://github.com/haskell/ghcide/pull/121+  , test  yes    yes    tcL6       tcData        "type constructor                #1028" -- https://github.com/haskell/ghcide/pull/147+  , test  broken yes    xtcL5      xtc           "type constructor external   #717,1028"+  , test  broken yes    xvL20      xvMsg         "value external package           #717" -- https://github.com/haskell/ghcide/pull/120+  , test  yes    yes    vvL16      vv            "plain parameter"                       -- https://github.com/haskell/ghcide/pull/120+  , test  yes    yes    aL18       apmp          "pattern match name"                    -- https://github.com/haskell/ghcide/pull/120+  , test  yes    yes    opL16      op            "top-level operator               #713" -- https://github.com/haskell/ghcide/pull/120+  , test  yes    yes    opL18      opp           "parameter operator"                    -- https://github.com/haskell/ghcide/pull/120+  , test  yes    yes    b'L19      bp            "name in backticks"                     -- https://github.com/haskell/ghcide/pull/120+  , test  yes    yes    clL23      cls           "class in instance declaration   #1027"+  , test  yes    yes    clL25      cls           "class in signature              #1027" -- https://github.com/haskell/ghcide/pull/147+  , test  broken yes    eclL15     ecls          "external class in signature #717,1027"+  , test  yes    yes    dnbL29     dnb           "do-notation   bind              #1073"+  , test  yes    yes    dnbL30     dnb           "do-notation lookup"+  , test  yes    yes    lcbL33     lcb           "listcomp   bind                 #1073"+  , 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 ghcVersion >= GHC810 then+        test  yes    yes    spaceL37   space         "top-level fn on space           #1002"+    else+        test  yes    broken spaceL37   space         "top-level fn on space           #1002"+  , test  no     yes    docL41     doc           "documentation                   #1129"+  , test  no     yes    eitL40     kindE         "kind of Either                  #1017"+  , test  no     yes    intL40     kindI         "kind of Int                     #1017"+  , test  no     broken tvrL40     kindV         "kind of (* -> *) type variable  #1017"+  , test  no     broken intL41     litI          "literal Int  in hover info      #1016"+  , test  no     broken chrL36     litC          "literal Char in hover info      #1016"+  , test  no     broken txtL8      litT          "literal Text in hover info      #1016"+  , test  no     broken lstL43     litL          "literal List in hover info      #1016"+  , test  yes    yes    cmtL68     lackOfdEq     "no Core symbols                 #3280"+  , if ghcVersion >= GHC90 then+        test  no     yes    docL41     constr        "type constraint in hover info   #1012"+    else+        test  no     broken docL41     constr        "type constraint in hover info   #1012"+  , test  no     yes    outL45     outSig        "top-level signature              #767"+  , test  broken broken innL48     innSig        "inner     signature              #767"+  , test  no     yes    holeL60    hleInfo       "hole without internal name       #831"+  , test  no     yes    holeL65    hleInfo2      "hole with variable"+  , test  no     yes    cccL17     docLink       "Haddock html links"+  , testM yes    yes    imported   importedSig   "Imported symbol"+  , if | isWindows ->+        -- Flaky on Windows: https://github.com/haskell/haskell-language-server/issues/2997+        testM no     yes    reexported reexportedSig "Imported symbol (reexported)"+       | otherwise ->+        testM yes    yes    reexported reexportedSig "Imported symbol (reexported)"+  , if | ghcVersion == GHC90 && isWindows ->+        test  no     broken    thLocL57   thLoc         "TH Splice Hover"+       | otherwise ->+        test  no     yes       thLocL57   thLoc         "TH Splice Hover"+  , test yes yes import310 pkgTxt "show package name and its version"+  ]+  where yes, broken :: (TestTree -> Maybe TestTree)+        yes    = Just -- test should run and pass+        broken = Just . (`xfail` "known broken")+        no = const Nothing -- don't run this test at all+        skip = const Nothing -- unreliable, don't run++checkFileCompiles :: FilePath -> Session () -> TestTree+checkFileCompiles fp diag =+  testSessionWithExtraFiles "hover" ("Does " ++ fp ++ " compile") $ \dir -> do+    void (openTestDataDoc (dir </> fp))+    diag

@@ -1,6 +1,5 @@ module FuzzySearch (tests) where -import           Control.Monad              (guard) import           Data.Char                  (toLower) import           Data.Maybe                 (catMaybes) import qualified Data.Monoid.Textual        as T@@ -8,12 +7,10 @@ import qualified Data.Text                  as Text import           Prelude                    hiding (filter) import           System.Directory           (doesFileExist)-import           System.Info.Extra          (isWindows) import           System.IO.Unsafe           (unsafePerformIO) import           Test.QuickCheck import           Test.Tasty import           Test.Tasty.ExpectedFailure-import           Test.Tasty.HUnit import           Test.Tasty.QuickCheck      (testProperty) import qualified Text.Fuzzy                 as Fuzzy import           Text.Fuzzy                 (Fuzzy (..))