ghcide 2.7.0.0 → 2.8.0.0

raw patch · 63 files changed

+392/−5213 lines, 63 filesdep −QuickCheckdep −ekg-coredep −ekg-waidep ~basedep ~extradep ~hie-biosPVP ok

version bump matches the API change (PVP)

Dependencies removed: QuickCheck, ekg-core, ekg-wai, fuzzy, ghc-typelits-knownnat, monoid-subclasses, network-uri, shake, tasty, tasty-expected-failure, tasty-quickcheck, tasty-rerun

Dependency ranges changed: base, extra, hie-bios, hls-graph, hls-plugin-api, lsp, lsp-test, lsp-types, regex-tdfa, unordered-containers

API changes (from Hackage documentation)

Files

exe/Arguments.hs +0/−2
exe/Main.hs +8/−14
ghcide.cabal +5/−120
session-loader/Development/IDE/Session.hs +140/−25
src/Development/IDE/Core/Compile.hs +3/−1
src/Development/IDE/Core/FileExists.hs +3/−0
src/Development/IDE/Core/OfInterest.hs +6/−5
src/Development/IDE/Core/RuleTypes.hs +6/−0
src/Development/IDE/Core/Rules.hs +73/−114
src/Development/IDE/Core/Service.hs +2/−5
src/Development/IDE/Core/Shake.hs +30/−26
src/Development/IDE/Core/Tracing.hs +13/−9
src/Development/IDE/GHC/Compat.hs +1/−3
src/Development/IDE/GHC/Compat/Core.hs +1/−0
src/Development/IDE/GHC/Error.hs +1/−0
src/Development/IDE/LSP/HoverDefinition.hs +35/−24
src/Development/IDE/LSP/LanguageServer.hs +13/−16
src/Development/IDE/LSP/Notifications.hs +19/−6
src/Development/IDE/Main.hs +14/−18
src/Development/IDE/Monitoring/EKG.hs +0/−49
src/Development/IDE/Plugin/HLS.hs +1/−0
src/Development/IDE/Plugin/HLS/GhcIde.hs +15/−14
src/Development/IDE/Types/Exports.hs +2/−2
test/data/plugin-recorddot/RecordDot.hs +0/−6
test/data/plugin-recorddot/cabal.project +0/−1
test/data/plugin-recorddot/plugin.cabal +0/−9
test/exe/AsyncTests.hs +0/−53
test/exe/BootTests.hs +0/−55
test/exe/CPPTests.hs +0/−56
test/exe/ClientSettingsTests.hs +0/−34
test/exe/CodeLensTests.hs +0/−121
test/exe/CompletionTests.hs +0/−575
test/exe/CradleTests.hs +0/−241
test/exe/DependentFileTest.hs +0/−62
test/exe/DiagnosticTests.hs +0/−593
test/exe/ExceptionTests.hs +0/−156
test/exe/FindDefinitionAndHoverTests.hs +0/−249
test/exe/FuzzySearch.hs +0/−129
test/exe/GarbageCollectionTests.hs +0/−94
test/exe/HaddockTests.hs +0/−90
test/exe/HieDbRetry.hs +0/−136
test/exe/HighlightTests.hs +0/−79
test/exe/IfaceTests.hs +0/−163
test/exe/InitializeResponseTests.hs +0/−97
test/exe/LogType.hs +0/−21
test/exe/Main.hs +0/−127
test/exe/NonLspCommandLine.hs +0/−27
test/exe/OpenCloseTest.hs +0/−18
test/exe/OutlineTests.hs +0/−189
test/exe/PluginParsedResultTests.hs +0/−16
test/exe/PluginSimpleTests.hs +0/−50
test/exe/PositionMappingTests.hs +0/−222
test/exe/PreprocessorTests.hs +0/−27
test/exe/Progress.hs +0/−60
test/exe/ReferenceTests.hs +0/−199
test/exe/RootUriTests.hs +0/−26
test/exe/SafeTests.hs +0/−38
test/exe/SymlinkTests.hs +0/−27
test/exe/THTests.hs +0/−194
test/exe/TestUtils.hs +0/−325
test/exe/UnitTests.hs +0/−110
test/exe/WatchedFileTests.hs +0/−84
test/src/Development/IDE/Test.hs +1/−1

exe/Arguments.hs view

@@ -20,7 +20,6 @@     ,argsVerbose                    :: Bool     ,argsCommand                    :: Command     ,argsConservativeChangeTracking :: Bool-    ,argsMonitoringPort             :: Int     }  getArguments :: IdePlugins IdeState -> IO Arguments@@ -43,7 +42,6 @@       <*> switch (short 'd' <> long "verbose" <> help "Include internal events in logging output")       <*> (commandP plugins <|> lspCommand <|> checkCommand)       <*> switch (long "conservative-change-tracking" <> help "disable reactive change tracking (for testing/debugging)")-      <*> option auto (long "monitoring-port" <> metavar "PORT" <> value 8999 <> showDefault <> help "Port to use for EKG monitoring (if the binary is built with EKG)")       where           checkCommand = Check <$> many (argument str (metavar "FILES/DIRS..."))           lspCommand = LSP <$ flag' True (long "lsp" <> help "Start talking to an LSP client")

exe/Main.hs view

@@ -16,15 +16,12 @@ import           Development.IDE.Core.OfInterest          (kick) import           Development.IDE.Core.Rules               (mainRule) import qualified Development.IDE.Core.Rules               as Rules-import           Development.IDE.Core.Tracing             (withTelemetryLogger)+import           Development.IDE.Core.Tracing             (withTelemetryRecorder) import qualified Development.IDE.Main                     as IDEMain-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.Options-import           GHC.Stack                                (emptyCallStack)-import           Ide.Logger                               (Logger (Logger),-                                                           LoggingColumn (DataColumn, PriorityColumn),+import           Ide.Logger                               (LoggingColumn (DataColumn, PriorityColumn),                                                            Pretty (pretty),                                                            Priority (Debug, Error, Info),                                                            WithPriority (WithPriority, priority),@@ -72,7 +69,7 @@              <> gitHashSection  main :: IO ()-main = withTelemetryLogger $ \telemetryLogger -> do+main = withTelemetryRecorder $ \telemetryRecorder -> do     -- stderr recorder just for plugin cli commands     pluginCliRecorder <-       cmapWithPrio pretty@@ -110,23 +107,20 @@           (lspLogRecorder & cmapWithPrio (renderStrict . layoutPretty defaultLayoutOptions)                           & cfilter (\WithPriority{ priority } -> priority >= minPriority)) <>           (lspMessageRecorder & cmapWithPrio (renderStrict . layoutPretty defaultLayoutOptions)-                              & cfilter (\WithPriority{ priority } -> priority >= Error))--    -- exists so old-style logging works. intended to be phased out-    let logger = Logger $ \p m -> Logger.logger_ docWithFilteredPriorityRecorder (WithPriority p emptyCallStack (pretty m))+                              & cfilter (\WithPriority{ priority } -> priority >= Error)) <>+          telemetryRecorder      let recorder = docWithFilteredPriorityRecorder                  & cmapWithPrio pretty      let arguments =           if argsTesting-          then IDEMain.testing (cmapWithPrio LogIDEMain recorder) logger hlsPlugins-          else IDEMain.defaultArguments (cmapWithPrio LogIDEMain recorder) logger hlsPlugins+          then IDEMain.testing (cmapWithPrio LogIDEMain recorder) hlsPlugins+          else IDEMain.defaultArguments (cmapWithPrio LogIDEMain recorder) hlsPlugins      IDEMain.defaultMain (cmapWithPrio LogIDEMain recorder) arguments         { IDEMain.argsProjectRoot = Just argsCwd         , IDEMain.argCommand = argsCommand-        , IDEMain.argsLogger = IDEMain.argsLogger arguments <> pure telemetryLogger         , IDEMain.argsHlsPlugins = IDEMain.argsHlsPlugins arguments <> pluginDescToIdePlugins [lspRecorderPlugin]          , IDEMain.argsRules = do@@ -148,5 +142,5 @@                 , optRunSubset = not argsConservativeChangeTracking                 , optVerifyCoreFile = argsVerifyCoreFile                 }-        , IDEMain.argsMonitoring = OpenTelemetry.monitoring <> EKG.monitoring logger argsMonitoringPort+        , IDEMain.argsMonitoring = OpenTelemetry.monitoring         }

ghcide.cabal view

@@ -2,7 +2,7 @@ build-type:         Simple category:           Development name:               ghcide-version:            2.7.0.0+version:            2.8.0.0 license:            Apache-2.0 license-file:       LICENSE author:             Digital Asset and Ghcide contributors@@ -28,13 +28,6 @@   type:     git   location: https://github.com/haskell/haskell-language-server.git -flag ekg-  description:-    Enable EKG monitoring of the build graph and other metrics on port 8999--  default:     False-  manual:      True- flag pedantic   description: Enable -Werror   default:     False@@ -85,11 +78,11 @@     , Glob     , haddock-library              >=1.8      && <1.12     , hashable-    , hie-bios                     ==0.13.1+    , hie-bios                     ^>=0.14.0     , hie-compat                   ^>=0.3.0.0     , hiedb                        ^>= 0.6.0.0-    , hls-graph                    == 2.7.0.0-    , hls-plugin-api               == 2.7.0.0+    , hls-graph                    == 2.8.0.0+    , hls-plugin-api               == 2.8.0.0     , implicit-hie                 >= 0.1.4.0 && < 0.1.5     , lens     , list-t@@ -178,7 +171,6 @@     Development.IDE.LSP.Server     Development.IDE.Main     Development.IDE.Main.HeapStats-    Development.IDE.Monitoring.EKG     Development.IDE.Monitoring.OpenTelemetry     Development.IDE.Plugin     Development.IDE.Plugin.Completions@@ -218,13 +210,6 @@     ghc-options:       -Werror -  if flag(ekg)-    build-depends:-      , ekg-core-      , ekg-wai--    cpp-options:   -DMONITORING_EKG- flag test-exe   description: Build the ghcide-test-preprocessor executable   default:     True@@ -285,7 +270,7 @@   visibility: public   default-language:   GHC2021 -  hs-source-dirs: test/src test/cabal +  hs-source-dirs: test/src test/cabal   exposed-modules:     Development.IDE.Test     Development.IDE.Test.Runfiles@@ -306,109 +291,9 @@       lsp-test ^>= 0.17,       tasty-hunit >= 0.10,       text,-      row-types,    default-extensions:       LambdaCase       OverloadedStrings       RecordWildCards       ViewPatterns-  -test-suite ghcide-tests-  import: warnings-  type:               exitcode-stdio-1.0-  default-language:   GHC2021-  build-tool-depends:-    , ghcide:ghcide-    , ghcide:ghcide-test-preprocessor-    , implicit-hie:gen-hie--  build-depends:-    , aeson-    , async-    , base-    , containers-    , data-default-    , directory-    , enummapset-    , extra-    , filepath-    , fuzzy-    , ghcide-    , ghcide:ghcide-test-utils-    , hls-plugin-api-    , lens-    , list-t-    , lsp-    , lsp-test                ^>=0.17.0.0-    , lsp-types-    , monoid-subclasses-    , mtl-    , network-uri-    , QuickCheck-    , random-    , regex-tdfa              ^>=1.3.1-    , row-types-    , shake-    , sqlite-simple-    , stm-    , stm-containers-    , tasty-    , tasty-expected-failure-    , tasty-hunit             >=0.10-    , tasty-quickcheck-    , tasty-rerun-    , text-    , text-rope-    , unordered-containers--  if impl(ghc <9.3)-    build-depends: ghc-typelits-knownnat--  hs-source-dirs:     test/exe -  ghc-options:        -threaded -O0--  main-is:            Main.hs-  other-modules:-    AsyncTests-    BootTests-    ClientSettingsTests-    CodeLensTests-    CompletionTests-    CPPTests-    CradleTests-    DependentFileTest-    DiagnosticTests-    ExceptionTests-    FindDefinitionAndHoverTests-    FuzzySearch-    GarbageCollectionTests-    HaddockTests-    HieDbRetry-    HighlightTests-    IfaceTests-    InitializeResponseTests-    LogType-    NonLspCommandLine-    OpenCloseTest-    OutlineTests-    PluginParsedResultTests-    PluginSimpleTests-    PositionMappingTests-    PreprocessorTests-    Progress-    ReferenceTests-    RootUriTests-    SafeTests-    SymlinkTests-    TestUtils-    THTests-    UnitTests-    WatchedFileTests--  -- Tests that have been pulled out of the main file-  default-extensions:-    LambdaCase-    OverloadedStrings-    RecordWildCards-    ViewPatterns

session-loader/Development/IDE/Session.hs view

@@ -25,7 +25,7 @@ import           Control.Concurrent.Strict import           Control.Exception.Safe               as Safe import           Control.Monad-import           Control.Monad.Extra+import           Control.Monad.Extra                  as Extra import           Control.Monad.IO.Class import qualified Crypto.Hash.SHA1                     as H import           Data.Aeson                           hiding (Error)@@ -58,6 +58,7 @@ import qualified Development.IDE.GHC.Compat.Core      as GHC import           Development.IDE.GHC.Compat.Env       hiding (Logger) import           Development.IDE.GHC.Compat.Units     (UnitId)+import qualified Development.IDE.GHC.Compat.Util      as Compat import           Development.IDE.GHC.Util import           Development.IDE.Graph                (Action) import           Development.IDE.Session.VersionCheck@@ -69,6 +70,7 @@ import           Development.IDE.Types.Options import           GHC.Check import qualified HIE.Bios                             as HieBios+import qualified HIE.Bios.Cradle                      as HieBios import           HIE.Bios.Environment                 hiding (getCacheDir) import           HIE.Bios.Types                       hiding (Log) import qualified HIE.Bios.Types                       as HieBios@@ -79,6 +81,8 @@                                                        nest,                                                        toCologActionWithPrio,                                                        vcat, viaShow, (<+>))+import           Ide.Types                            (SessionLoadingPreferenceConfig (..),+                                                       sessionLoading) import           Language.LSP.Protocol.Message import           Language.LSP.Server import           System.Directory@@ -122,10 +126,12 @@ import           GHC.Driver.Env                       (hsc_all_home_unit_ids) import           GHC.Driver.Errors.Types import           GHC.Driver.Make                      (checkHomeUnitsClosed)-import           GHC.Types.Error                      (errMsgDiagnostic)+import           GHC.Types.Error                      (errMsgDiagnostic,+                                                       singleMessage) import           GHC.Unit.State #endif +import           GHC.Data.Graph.Directed import           GHC.ResponseFile  data Log@@ -147,6 +153,7 @@   | LogNoneCradleFound FilePath   | LogNewComponentCache !(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)   | LogHieBios HieBios.Log+  | LogSessionLoadingChanged deriving instance Show Log  instance Pretty Log where@@ -217,6 +224,8 @@     LogNewComponentCache componentCache ->       "New component cache HscEnvEq:" <+> viaShow componentCache     LogHieBios msg -> pretty msg+    LogSessionLoadingChanged ->+      "Session Loading config changed, reloading the full session."  -- | Bump this version number when making changes to the format of the data stored in hiedb hiedbDataVersion :: String@@ -447,6 +456,7 @@   filesMap <- newVar HM.empty :: IO (Var FilesMap)   -- Version of the mappings above   version <- newVar 0+  biosSessionLoadingVar <- newVar Nothing :: IO (Var (Maybe SessionLoadingPreferenceConfig))   let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readVar version)   -- This caches the mapping from Mod.hs -> hie.yaml   cradleLoc <- liftIO $ memoIO $ \v -> do@@ -461,6 +471,7 @@   runningCradle <- newVar dummyAs :: IO (Var (Async (IdeResult HscEnvEq,[FilePath])))    return $ do+    clientConfig <- getClientConfigAction     extras@ShakeExtras{restartShakeSession, ideNc, knownTargetsVar, lspEnv                       } <- getShakeExtras     let invalidateShakeCache :: IO ()@@ -495,14 +506,14 @@                 -- 'TargetFile Foo.hs' in the 'knownTargetsVar', thus not find 'TargetFile Foo.hs-boot'                 -- and also not find 'TargetModule Foo'.                 fs <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations-                pure $ map (\fp -> (TargetFile fp, [fp])) (nubOrd (f:fs))+                pure $ map (\fp -> (TargetFile fp, Set.singleton fp)) (nubOrd (f:fs))               TargetModule _ -> do                 found <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations-                return [(targetTarget, found)]+                return [(targetTarget, Set.fromList found)]           hasUpdate <- join $ atomically $ do             known <- readTVar knownTargetsVar             let known' = flip mapHashed known $ \k ->-                            HM.unionWith (<>) k $ HM.fromList $ map (second Set.fromList) knownTargets+                            HM.unionWith (<>) k $ HM.fromList knownTargets                 hasUpdate = if known /= known' then Just (unhashed known') else Nothing             writeTVar knownTargetsVar known'             logDirtyKeys <- recordDirtyKeys extras GetKnownTargets [emptyFilePath]@@ -585,9 +596,21 @@           let new_cache = newComponentCache recorder optExtensions hieYaml _cfp hscEnv           all_target_details <- new_cache old_deps new_deps -          let all_targets = concatMap fst all_target_details--          let this_flags_map = HM.fromList (concatMap toFlagsMap all_targets)+          this_dep_info <- getDependencyInfo $ maybeToList hieYaml+          let (all_targets, this_flags_map, this_options)+                = case HM.lookup _cfp flags_map' of+                    Just this -> (all_targets', flags_map', this)+                    Nothing -> (this_target_details : all_targets', HM.insert _cfp this_flags flags_map', this_flags)+                  where all_targets' = concat all_target_details+                        flags_map' = HM.fromList (concatMap toFlagsMap all_targets')+                        this_target_details = TargetDetails (TargetFile _cfp) this_error_env this_dep_info [_cfp]+                        this_flags = (this_error_env, this_dep_info)+                        this_error_env = ([this_error], Nothing)+                        this_error = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) _cfp+                                       $ T.unlines+                                       [ "No cradle target found. Is this file listed in the targets of your cradle?"+                                       , "If you are using a .cabal file, please ensure that this module is listed in either the exposed-modules or other-modules section"+                                       ]            void $ modifyVar' fileToFlags $               Map.insert hieYaml this_flags_map@@ -615,7 +638,7 @@                     let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces                     liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>) -          return $ second Map.keys $ this_flags_map HM.! _cfp+          return $ second Map.keys this_options      let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath])         consultCradle hieYaml cfp = do@@ -639,7 +662,7 @@               withTrace "Load cradle" $ \addTag -> do                   addTag "file" lfp                   old_files <- readIORef cradle_files-                  res <- cradleToOptsAndLibDir recorder cradle cfp old_files+                  res <- cradleToOptsAndLibDir recorder (sessionLoading clientConfig) cradle cfp old_files                   addTag "result" (show res)                   return res @@ -667,11 +690,38 @@                void $ modifyVar' filesMap $ HM.insert ncfp hieYaml                return (res, maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err) +    let+        -- | We allow users to specify a loading strategy.+        -- Check whether this config was changed since the last time we have loaded+        -- a session.+        --+        -- If the loading configuration changed, we likely should restart the session+        -- in its entirety.+        didSessionLoadingPreferenceConfigChange :: IO Bool+        didSessionLoadingPreferenceConfigChange = do+          mLoadingConfig <- readVar biosSessionLoadingVar+          case mLoadingConfig of+            Nothing -> do+              writeVar biosSessionLoadingVar (Just (sessionLoading clientConfig))+              pure False+            Just loadingConfig -> do+              writeVar biosSessionLoadingVar (Just (sessionLoading clientConfig))+              pure (loadingConfig /= sessionLoading clientConfig)+     -- This caches the mapping from hie.yaml + Mod.hs -> [String]     -- Returns the Ghc session and the cradle dependencies     let sessionOpts :: (Maybe FilePath, FilePath)                     -> IO (IdeResult HscEnvEq, [FilePath])         sessionOpts (hieYaml, file) = do+          Extra.whenM didSessionLoadingPreferenceConfigChange $ do+            logWith recorder Info LogSessionLoadingChanged+            -- If the dependencies are out of date then clear both caches and start+            -- again.+            modifyVar_ fileToFlags (const (return Map.empty))+            modifyVar_ filesMap (const (return HM.empty))+            -- Don't even keep the name cache, we start from scratch here!+            modifyVar_ hscEnvs (const (return Map.empty))+           v <- Map.findWithDefault HM.empty hieYaml <$> readVar fileToFlags           cfp <- makeAbsolute file           case HM.lookup (toNormalizedFilePath' cfp) v of@@ -682,6 +732,7 @@                   -- If the dependencies are out of date then clear both caches and start                   -- again.                   modifyVar_ fileToFlags (const (return Map.empty))+                  modifyVar_ filesMap (const (return HM.empty))                   -- Keep the same name cache                   modifyVar_ hscEnvs (return . Map.adjust (const []) hieYaml )                   consultCradle hieYaml cfp@@ -701,7 +752,7 @@                 return (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml)      returnWithVersion $ \file -> do-      opts <- liftIO $ join $ mask_ $ modifyVar runningCradle $ \as -> do+      opts <- join $ mask_ $ modifyVar runningCradle $ \as -> do         -- If the cradle is not finished, then wait for it to finish.         void $ wait as         asyncRes <- async $ getOptions file@@ -711,14 +762,14 @@ -- | Run the specific cradle on a specific FilePath via hie-bios. -- This then builds dependencies or whatever based on the cradle, gets the -- GHC options/dynflags needed for the session and the GHC library directory-cradleToOptsAndLibDir :: Recorder (WithPriority Log) -> Cradle Void -> FilePath -> [FilePath]+cradleToOptsAndLibDir :: Recorder (WithPriority Log) -> SessionLoadingPreferenceConfig -> Cradle Void -> FilePath -> [FilePath]                       -> IO (Either [CradleError] (ComponentOptions, FilePath))-cradleToOptsAndLibDir recorder cradle file old_files = do+cradleToOptsAndLibDir recorder loadConfig cradle file old_fps = do     -- let noneCradleFoundMessage :: FilePath -> T.Text     --     noneCradleFoundMessage f = T.pack $ "none cradle found for " <> f <> ", ignoring the file"     -- Start off by getting the session options     logWith recorder Debug $ LogCradle cradle-    cradleRes <- HieBios.getCompilerOptions file old_files cradle+    cradleRes <- HieBios.getCompilerOptions file loadStyle cradle     case cradleRes of         CradleSuccess r -> do             -- Now get the GHC lib dir@@ -736,6 +787,11 @@             logWith recorder Info $ LogNoneCradleFound file             return (Left []) +    where+        loadStyle = case loadConfig of+            PreferSingleComponentLoading -> LoadFile+            PreferMultiComponentLoading  -> LoadWithContext old_fps+ #if MIN_VERSION_ghc(9,3,0) emptyHscEnv :: NameCache -> FilePath -> IO HscEnv #else@@ -798,6 +854,65 @@ #endif setNameCache nc hsc = hsc { hsc_NC = nc } +#if MIN_VERSION_ghc(9,3,0)+-- This function checks the important property that if both p and q are home units+-- then any dependency of p, which transitively depends on q is also a home unit.+-- GHC had an implementation of this function, but it was horribly inefficient+-- We should move back to the GHC implementation on compilers where+-- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/12162 is included+checkHomeUnitsClosed' ::  UnitEnv -> OS.Set UnitId -> [DriverMessages]+checkHomeUnitsClosed' ue home_id_set+    | OS.null bad_unit_ids = []+    | otherwise = [singleMessage $ GHC.mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (OS.toList bad_unit_ids)]+  where+    bad_unit_ids = upwards_closure OS.\\ home_id_set+    rootLoc = mkGeneralSrcSpan (Compat.fsLit "<command line>")++    graph :: Graph (Node UnitId UnitId)+    graph = graphFromEdgedVerticesUniq graphNodes++    -- downwards closure of graph+    downwards_closure+      = graphFromEdgedVerticesUniq [ DigraphNode uid uid (OS.toList deps)+                                   | (uid, deps) <- Map.toList (allReachable graph node_key)]++    inverse_closure = transposeG downwards_closure++    upwards_closure = OS.fromList $ map node_key $ reachablesG inverse_closure [DigraphNode uid uid [] | uid <- OS.toList home_id_set]++    all_unit_direct_deps :: UniqMap UnitId (OS.Set UnitId)+    all_unit_direct_deps+      = unitEnv_foldWithKey go emptyUniqMap $ ue_home_unit_graph ue+      where+        go rest this this_uis =+           plusUniqMap_C OS.union+             (addToUniqMap_C OS.union external_depends this (OS.fromList $ this_deps))+             rest+           where+             external_depends = mapUniqMap (OS.fromList . unitDepends)+#if !MIN_VERSION_ghc(9,7,0)+                              $ listToUniqMap $ Map.toList+#endif++                              $ unitInfoMap this_units+             this_units = homeUnitEnv_units this_uis+             this_deps = [ Compat.toUnitId unit | (unit,Just _) <- explicitUnits this_units]++    graphNodes :: [Node UnitId UnitId]+    graphNodes = go OS.empty home_id_set+      where+        go done todo+          = case OS.minView todo of+              Nothing -> []+              Just (uid, todo')+                | OS.member uid done -> go done todo'+                | otherwise -> case lookupUniqMap all_unit_direct_deps uid of+                    Nothing -> pprPanic "uid not found" (Compat.ppr (uid, all_unit_direct_deps))+                    Just depends ->+                      let todo'' = (depends OS.\\ done) `OS.union` todo'+                      in DigraphNode uid uid (OS.toList depends) : go (OS.insert uid done) todo''+#endif+ -- | Create a mapping from FilePaths to HscEnvEqs -- This combines all the components we know about into -- an appropriate session, which is a multi component@@ -810,7 +925,7 @@          -> HscEnv             -- ^ An empty HscEnv          -> [ComponentInfo]    -- ^ New components to be loaded          -> [ComponentInfo]    -- ^ old, already existing components-         -> IO [ ([TargetDetails], (IdeResult HscEnvEq, DependencyInfo))]+         -> IO [ [TargetDetails] ] newComponentCache recorder exts cradlePath _cfp hsc_env old_cis new_cis = do     let cis = Map.unionWith unionCIs (mkMap new_cis) (mkMap old_cis)         -- When we have multiple components with the same uid,@@ -826,11 +941,7 @@               Compat.initUnits dfs hsc_env  #if MIN_VERSION_ghc(9,3,0)-    let closure_errs = checkHomeUnitsClosed (hsc_unit_env hscEnv') (hsc_all_home_unit_ids hscEnv') pkg_deps-        pkg_deps = do-          home_unit_id <- uids-          home_unit_env <- maybeToList $ unitEnv_lookup_maybe home_unit_id $ hsc_HUG hscEnv'-          map (home_unit_id,) (map (Compat.toUnitId . fst) $ explicitUnits $ homeUnitEnv_units home_unit_env)+    let closure_errs = checkHomeUnitsClosed' (hsc_unit_env hscEnv') (hsc_all_home_unit_ids hscEnv')         multi_errs = map (ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Warning) _cfp . T.pack . Compat.printWithoutUniques) closure_errs         bad_units = OS.fromList $ concat $ do             x <- bagToList $ mapBag errMsgDiagnostic $ unionManyBags $ map Compat.getMessages closure_errs@@ -882,14 +993,13 @@       henv <- createHscEnvEq thisEnv (zip uids dfs)       let targetEnv = (if isBad ci then multi_errs else [], Just henv)           targetDepends = componentDependencyInfo ci-          res = ( targetEnv, targetDepends)-      logWith recorder Debug $ LogNewComponentCache res+      logWith recorder Debug $ LogNewComponentCache (targetEnv, targetDepends)       evaluate $ liftRnf rwhnf $ componentTargets ci        let mk t = fromTargetId (importPaths df) exts (targetId t) targetEnv targetDepends       ctargets <- concatMapM mk (componentTargets ci) -      return (L.nubOrdOn targetTarget ctargets, res)+      return (L.nubOrdOn targetTarget ctargets)  {- Note [Avoiding bad interface files] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1081,15 +1191,20 @@         -- A special target for the file which caused this wonderful         -- component to be created. In case the cradle doesn't list all the targets for         -- the component, in which case things will be horribly broken anyway.-        -- Otherwise, we will immediately attempt to reload this module which-        -- causes an infinite loop and high CPU usage.         --+        -- When we have a singleComponent that is caused to be loaded due to a+        -- file, we assume the file is part of that component. This is useful+        -- for bare GHC sessions, such as many of the ones used in the testsuite+        --         -- We don't do this when we have multiple components, because each         -- component better list all targets or there will be anarchy.         -- It is difficult to know which component to add our file to in         -- that case.         -- Multi unit arguments are likely to come from cabal, which         -- does list all targets.+        --+        -- If we don't end up with a target for the current file in the end, then+        -- we will report it as an error for that file         abs_fp <- liftIO $ makeAbsolute (fromNormalizedFilePath cfp)         let special_target = Compat.mkSimpleTarget df abs_fp         pure $ (df, special_target : targets) :| []

src/Development/IDE/Core/Compile.hs view

@@ -436,6 +436,7 @@   -- Note [Clearing mi_globals after generating an iface]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- GHC populates the mi_global field in interfaces for GHCi if we are using the bytecode -- interpreter. -- However, this field is expensive in terms of heap usage, and we don't use it in HLS@@ -1366,7 +1367,7 @@   {- Note [Recompilation avoidance in the presence of TH]-+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Most versions of GHC we currently support don't have a working implementation of code unloading for object code, and no version of GHC supports this on certain platforms like Windows. This makes it completely infeasible for interactive use,@@ -1736,6 +1737,7 @@       rep c = c  {- Note [Guidelines For Using CPP In GHCIDE Import Statements]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~   GHCIDE's interface with GHC is extensive, and unfortunately, because we have   to work with multiple versions of GHC, we have several files that need to use   a lot of CPP. In order to simplify the CPP in the import section of every file

src/Development/IDE/Core/FileExists.hs view

@@ -40,6 +40,7 @@ import qualified System.FilePath.Glob                  as Glob  {- Note [File existence cache and LSP file watchers]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Some LSP servers provide the ability to register file watches with the client, which will then notify us of file changes. Some clients can do this more efficiently than us, or generally it's a tricky problem@@ -135,6 +136,7 @@ getFileExists fp = use_ GetFileExists fp  {- Note [Which files should we watch?]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The watcher system gives us a lot of flexibility: we can set multiple watchers, and they can all watch on glob patterns. @@ -201,6 +203,7 @@             else fileExistsSlow file  {- Note [Invalidating file existence results]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We have two mechanisms for getting file existence information: - The file existence cache - The VFS lookup

src/Development/IDE/Core/OfInterest.hs view

@@ -42,10 +42,11 @@ import           Development.IDE.Types.Options            (IdeTesting (..)) import           GHC.TypeLits                             (KnownSymbol) import           Ide.Logger                               (Pretty (pretty),+                                                           Priority (..),                                                            Recorder,                                                            WithPriority,                                                            cmapWithPrio,-                                                           logDebug)+                                                           logWith) import qualified Language.LSP.Protocol.Message            as LSP import qualified Language.LSP.Server                      as LSP @@ -110,16 +111,16 @@         pure (new, (prev, new))     when (prev /= Just v) $ do         join $ atomically $ recordDirtyKeys (shakeExtras state) IsFileOfInterest [f]-        logDebug (ideLogger state) $-            "Set files of interest to: " <> T.pack (show files)+        logWith (ideLogger state) Debug $+            LogSetFilesOfInterest (HashMap.toList files)  deleteFileOfInterest :: IdeState -> NormalizedFilePath -> IO () deleteFileOfInterest state f = do     OfInterestVar var <- getIdeGlobalState state     files <- modifyVar' var $ HashMap.delete f     join $ atomically $ recordDirtyKeys (shakeExtras state) IsFileOfInterest [f]-    logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show files)-+    logWith (ideLogger state) Debug $+        LogSetFilesOfInterest (HashMap.toList files) scheduleGarbageCollection :: IdeState -> IO () scheduleGarbageCollection state = do     GarbageCollectVar var <- getIdeGlobalState state

src/Development/IDE/Core/RuleTypes.hs view

@@ -41,6 +41,8 @@ import           Development.IDE.Spans.LocalBindings import           Development.IDE.Types.Diagnostics import           GHC.Serialized                               (Serialized)+import           Ide.Logger                                   (Pretty (..),+                                                               viaShow) import           Language.LSP.Protocol.Types                  (Int32,                                                                NormalizedFilePath) @@ -340,6 +342,9 @@ instance Hashable FileOfInterestStatus instance NFData   FileOfInterestStatus +instance Pretty FileOfInterestStatus where+    pretty = viaShow+ data IsFileOfInterestResult = NotFOI | IsFOI FileOfInterestStatus   deriving (Eq, Show, Typeable, Generic) instance Hashable IsFileOfInterestResult@@ -512,6 +517,7 @@     ''Splices  {- Note [Client configuration in Rules]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The LSP client configuration is stored by `lsp` for us, and is accesible in handlers through the LspT monad.

src/Development/IDE/Core/Rules.hs view

@@ -11,11 +11,8 @@ module Development.IDE.Core.Rules(     -- * Types     IdeState, GetParsedModule(..), TransitiveDependencies(..),-    Priority(..), GhcSessionIO(..), GetClientSettings(..),+    GhcSessionIO(..), GetClientSettings(..),     -- * Functions-    priorityTypeCheck,-    priorityGenerateCore,-    priorityFilesOfInterest,     runAction,     toIdeResult,     defineNoFile,@@ -60,14 +57,16 @@     DisplayTHWarning(..),     ) where -import           Prelude                                      hiding (mod) import           Control.Applicative import           Control.Concurrent.Async                     (concurrently)+import           Control.Concurrent.STM.Stats                 (atomically)+import           Control.Concurrent.STM.TVar import           Control.Concurrent.Strict import           Control.DeepSeq-import           Control.Exception.Safe import           Control.Exception                            (evaluate)+import           Control.Exception.Safe import           Control.Monad.Extra                          hiding (msum)+import           Control.Monad.IO.Unlift import           Control.Monad.Reader                         hiding (msum) import           Control.Monad.State                          hiding (msum) import           Control.Monad.Trans.Except                   (ExceptT, except,@@ -78,44 +77,53 @@ import qualified Data.ByteString                              as BS import qualified Data.ByteString.Lazy                         as LBS import           Data.Coerce+import           Data.Default                                 (Default, def) import           Data.Foldable                                hiding (msum)+import           Data.Hashable import qualified Data.HashMap.Strict                          as HM import qualified Data.HashSet                                 as HashSet-import           Data.Hashable-import           Data.IORef-import           Control.Concurrent.STM.TVar import           Data.IntMap.Strict                           (IntMap) import qualified Data.IntMap.Strict                           as IntMap+import           Data.IORef 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 import qualified Data.Text.Encoding                           as T+import qualified Data.Text.Utf16.Rope                         as Rope import           Data.Time                                    (UTCTime (..))+import           Data.Time.Clock.POSIX                        (posixSecondsToUTCTime) import           Data.Tuple.Extra import           Data.Typeable                                (cast) import           Development.IDE.Core.Compile-import           Development.IDE.Core.FileExists hiding (LogShake, Log)+import           Development.IDE.Core.FileExists              hiding (Log,+                                                               LogShake) import           Development.IDE.Core.FileStore               (getFileContents,                                                                getModTime) import           Development.IDE.Core.IdeConfiguration-import           Development.IDE.Core.OfInterest hiding (LogShake, Log)+import           Development.IDE.Core.OfInterest              hiding (Log,+                                                               LogShake) import           Development.IDE.Core.PositionMapping import           Development.IDE.Core.RuleTypes-import           Development.IDE.Core.Service hiding (LogShake, Log)-import           Development.IDE.Core.Shake hiding (Log)-import           Development.IDE.GHC.Compat.Env+import           Development.IDE.Core.Service                 hiding (Log,+                                                               LogShake)+import           Development.IDE.Core.Shake                   hiding (Log)+import qualified Development.IDE.Core.Shake                   as Shake import           Development.IDE.GHC.Compat                   hiding-                                                              (vcat, nest, parseModule,-                                                               TargetId(..),-                                                               loadInterface,+                                                              (TargetId (..),                                                                Var,-                                                               (<+>), settings)-import qualified Development.IDE.GHC.Compat                   as Compat hiding (vcat, nest)+                                                               loadInterface,+                                                               nest,+                                                               parseModule,+                                                               settings, vcat,+                                                               (<+>))+import qualified Development.IDE.GHC.Compat                   as Compat hiding+                                                                        (nest,+                                                                         vcat)+import           Development.IDE.GHC.Compat.Env import qualified Development.IDE.GHC.Compat.Util              as Util import           Development.IDE.GHC.Error import           Development.IDE.GHC.Util                     hiding@@ -130,15 +138,18 @@ import           Development.IDE.Types.HscEnvEq import           Development.IDE.Types.Location import           Development.IDE.Types.Options+import qualified Development.IDE.Types.Shake                  as Shake import qualified GHC.LanguageExtensions                       as LangExt+import           HIE.Bios.Ghc.Gap                             (hostIsDynamic) import qualified HieDb+import           Ide.Logger                                   (Pretty (pretty),+                                                               Recorder,+                                                               WithPriority,+                                                               cmapWithPrio,+                                                               logWith, nest,+                                                               vcat, (<+>))+import qualified Ide.Logger                                   as Logger import           Ide.Plugin.Config-import qualified Language.LSP.Server                          as LSP-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) import           Ide.Plugin.Properties                        (HasProperty,                                                                KeyNameProxy,                                                                Properties,@@ -146,28 +157,28 @@                                                                useProperty) import           Ide.Types                                    (DynFlagsModifications (dynFlagsModifyGlobal, dynFlagsModifyParser),                                                                PluginId)-import Control.Concurrent.STM.Stats (atomically)-import Language.LSP.Server (LspT)-import System.Info.Extra (isWindows)-import HIE.Bios.Ghc.Gap (hostIsDynamic)-import Ide.Logger (Recorder, logWith, cmapWithPrio, WithPriority, Pretty (pretty), (<+>), nest, vcat)-import qualified Development.IDE.Core.Shake as Shake-import qualified Ide.Logger as Logger-import qualified Development.IDE.Types.Shake as Shake-import           Data.Time.Clock.POSIX             (posixSecondsToUTCTime)-import Control.Monad.IO.Unlift+import           Language.LSP.Protocol.Message                (SMethod (SMethod_CustomMethod, SMethod_WindowShowMessage))+import           Language.LSP.Protocol.Types                  (MessageType (MessageType_Info),+                                                               ShowMessageParams (ShowMessageParams))+import           Language.LSP.Server                          (LspT)+import qualified Language.LSP.Server                          as LSP+import           Language.LSP.VFS+import           Prelude                                      hiding (mod)+import           System.Directory                             (doesFileExist,+                                                               makeAbsolute)+import           System.Info.Extra                            (isWindows)  -import GHC.Fingerprint+import           GHC.Fingerprint  -- See Note [Guidelines For Using CPP In GHCIDE Import Statements]  #if !MIN_VERSION_ghc(9,3,0)-import GHC (mgModSummaries)+import           GHC                                          (mgModSummaries) #endif  #if MIN_VERSION_ghc(9,3,0)-import qualified Data.IntMap as IM+import qualified Data.IntMap                                  as IM #endif  @@ -236,15 +247,6 @@ -- Rules -- These typically go from key to value and are oracles. -priorityTypeCheck :: Priority-priorityTypeCheck = Priority 0--priorityGenerateCore :: Priority-priorityGenerateCore = Priority (-1)--priorityFilesOfInterest :: Priority-priorityFilesOfInterest = Priority (-2)- -- | WARNING: -- We currently parse the module both with and without Opt_Haddock, and -- return the one with Haddocks if it -- succeeds. However, this may not work@@ -266,40 +268,7 @@      -- We still parse with Haddocks whether Opt_Haddock is True or False to collect information     -- but we no longer need to parse with and without Haddocks separately for above GHC90.-    res@(_,pmod) <- if Compat.ghcVersion >= Compat.GHC90 then-      liftIO $ (fmap.fmap.fmap) reset_ms $ getParsedModuleDefinition hsc opt file (withOptHaddock ms)-    else do-        let dflags    = ms_hspp_opts ms-            mainParse = getParsedModuleDefinition hsc opt file ms--        -- Parse again (if necessary) to capture Haddock parse errors-        if gopt Opt_Haddock dflags-            then-                liftIO $ (fmap.fmap.fmap) reset_ms mainParse-            else do-                let haddockParse = getParsedModuleDefinition hsc opt file (withOptHaddock ms)--                -- parse twice, with and without Haddocks, concurrently-                -- we cannot ignore Haddock parse errors because files of-                -- non-interest are always parsed with Haddocks-                -- If we can parse Haddocks, might as well use them-                ((diags,res),(diagsh,resh)) <- liftIO $ (fmap.fmap.fmap.fmap) reset_ms $ concurrently mainParse haddockParse--                -- Merge haddock and regular diagnostics so we can always report haddock-                -- parse errors-                let diagsM = mergeParseErrorsHaddock diags diagsh-                case resh of-                  Just _-                    | HaddockParse <- optHaddockParse opt-                    -> pure (diagsM, resh)-                  -- If we fail to parse haddocks, report the haddock diagnostics as well and-                  -- return the non-haddock parse.-                  -- This seems to be the correct behaviour because the Haddock flag is added-                  -- by us and not the user, so our IDE shouldn't stop working because of it.-                  _ -> pure (diagsM, res)-    -- Add dependencies on included files-    _ <- uses GetModificationTime $ map toNormalizedFilePath' (maybe [] pm_extra_src_files pmod)-    pure res+    liftIO $ (fmap.fmap.fmap) reset_ms $ getParsedModuleDefinition hsc opt file (withOptHaddock ms)  withOptHaddock :: ModSummary -> ModSummary withOptHaddock = withOption Opt_Haddock@@ -310,18 +279,6 @@ withoutOption :: GeneralFlag -> ModSummary -> ModSummary withoutOption opt ms = ms{ms_hspp_opts= gopt_unset (ms_hspp_opts ms) opt} --- | Given some normal parse errors (first) and some from Haddock (second), merge them.---   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 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--    fixMessage x | "parse error " `T.isPrefixOf` x = "Haddock " <> x-                 | otherwise = "Haddock: " <> x- -- | This rule provides a ParsedModule preserving all annotations, -- including keywords, punctuation and comments. -- So it is suitable for use cases where you need a perfect edit.@@ -713,7 +670,6 @@     -> ParsedModule     -> Action (IdeResult TcModuleResult) typeCheckRuleDefinition hsc pm = do-  setPriority priorityTypeCheck   IdeOptions { optDefer = defer } <- getIdeOptions    unlift <- askUnliftIO@@ -745,9 +701,20 @@     defineEarlyCutOffNoFile (cmapWithPrio LogShake recorder) $ \GhcSessionIO -> do         alwaysRerun         opts <- getIdeOptions+        config <- getClientConfigAction         res <- optGhcSession opts -        let fingerprint = LBS.toStrict $ B.encode $ hash (sessionVersion res)+        let fingerprint = LBS.toStrict $ LBS.concat+                [ B.encode (hash (sessionVersion res))+                -- When the session version changes, reload all session+                -- hsc env sessions+                , B.encode (show (sessionLoading config))+                -- The loading config affects session loading.+                -- Invalidate all build nodes.+                -- Changing the session loading config will increment+                -- the 'sessionVersion', thus we don't generate the same fingerprint+                -- twice by accident.+                ]         return (fingerprint, res)      defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GhcSession file -> do@@ -780,6 +747,7 @@     }  -- | Note [GhcSessionDeps]+--   ~~~~~~~~~~~~~~~~~~~~~ -- For a file 'Foo', GhcSessionDeps "Foo.hs" results in an HscEnv which includes -- 1. HomeModInfo's (in the HUG/HPT) for all modules in the transitive closure of "Foo", **NOT** including "Foo" itself. -- 2. ModSummary's (in the ModuleGraph) for all modules in the transitive closure of "Foo", including "Foo" itself.@@ -850,7 +818,7 @@       let m_old = case old of             Shake.Succeeded (Just old_version) v -> Just (v, old_version)             Shake.Stale _   (Just old_version) v -> Just (v, old_version)-            _ -> Nothing+            _                                    -> Nothing           recompInfo = RecompilationInfo             { source_version = ver             , old_value = m_old@@ -966,7 +934,6 @@ generateCore runSimplifier file = do     packageState <- hscEnv <$> use_ GhcSessionDeps file     tm <- use_ TypeCheck file-    setPriority priorityGenerateCore     liftIO $ compileModule runSimplifier packageState (tmrModSummary tm) (tmrTypechecked tm)  generateCoreRule :: Recorder (WithPriority Log) -> Rules ()@@ -1023,22 +990,14 @@      -- Embed haddocks in the interface file     (diags, mb_pm) <- liftIO $ getParsedModuleDefinition hsc opt f (withOptHaddock ms)-    (diags', mb_pm') <--        -- We no longer need to parse again if GHC version is above 9.0. https://github.com/haskell/haskell-language-server/issues/1892-        if Compat.ghcVersion >= Compat.GHC90 || isJust mb_pm then do-            return (diags, mb_pm)-        else do-            -- if parsing fails, try parsing again with Haddock turned off-            (diagsNoHaddock, mb_pm') <- liftIO $ getParsedModuleDefinition hsc opt f ms-            return (mergeParseErrorsHaddock diagsNoHaddock diags, mb_pm')-    case mb_pm' of-        Nothing -> return (diags', Nothing)+    case mb_pm of+        Nothing -> return (diags, Nothing)         Just pm -> do             -- Invoke typechecking directly to update it without incurring a dependency             -- on the parsed module and the typecheck rules-            (diags'', mtmr) <- typeCheckRuleDefinition hsc pm+            (diags', mtmr) <- typeCheckRuleDefinition hsc pm             case mtmr of-              Nothing -> pure (diags'', Nothing)+              Nothing -> pure (diags', Nothing)               Just tmr -> do                  let compile = liftIO $ compileModule (RunSimplifier True) hsc (pm_mod_summary pm) $ tmrTypechecked tmr@@ -1046,7 +1005,7 @@                 se <- getShakeExtras                  -- Bang pattern is important to avoid leaking 'tmr'-                (diags''', !res) <- writeCoreFileIfNeeded se hsc compNeeded compile tmr+                (diags'', !res) <- writeCoreFileIfNeeded se hsc compNeeded compile tmr                  -- Write hi file                 hiDiags <- case res of@@ -1070,7 +1029,7 @@                     pure (hiDiags <> gDiags <> concat wDiags)                   Nothing -> pure [] -                return (diags' <> diags'' <> diags''' <> hiDiags, res)+                return (diags <> diags' <> diags'' <> hiDiags, res)   -- | HscEnv should have deps included already@@ -1233,9 +1192,9 @@       -- 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+      fullModuleGraph        :: Bool     -- | Disable TH for improved performance in large codebases-    , enableTemplateHaskell :: Bool+    , enableTemplateHaskell  :: Bool     -- | Warning to show when TH is not supported by the current HLS binary     , templateHaskellWarning :: LspT Config IO ()     }

src/Development/IDE/Core/Service.hs view

@@ -22,8 +22,7 @@ import           Development.IDE.Core.OfInterest  hiding (Log, LogShake) import           Development.IDE.Graph import           Development.IDE.Types.Options    (IdeOptions (..))-import           Ide.Logger                       as Logger (Logger,-                                                             Pretty (pretty),+import           Ide.Logger                       as Logger (Pretty (pretty),                                                              Priority (Debug),                                                              Recorder,                                                              WithPriority,@@ -63,14 +62,13 @@            -> IdePlugins IdeState            -> Rules ()            -> Maybe (LSP.LanguageContextEnv Config)-           -> Logger            -> Debouncer LSP.NormalizedUri            -> IdeOptions            -> WithHieDb            -> IndexQueue            -> Monitoring            -> IO IdeState-initialise recorder defaultConfig plugins mainRule lspEnv logger debouncer options withHieDb hiedbChan metrics = do+initialise recorder defaultConfig plugins mainRule lspEnv debouncer options withHieDb hiedbChan metrics = do     shakeProfiling <- do         let fromConf = optShakeProfiling options         fromEnv <- lookupEnv "GHCIDE_BUILD_PROFILING"@@ -80,7 +78,6 @@         lspEnv         defaultConfig         plugins-        logger         debouncer         shakeProfiling         (optReportProgress options)

src/Development/IDE/Core/Shake.hs view

@@ -51,12 +51,10 @@     HLS.getClientConfig,     getPluginConfigAction,     knownTargets,-    setPriority,     ideLogger,     actionLogger,     getVirtualFile,     FileVersion(..),-    Priority(..),     updatePositionMapping,     updatePositionMappingHelper,     deleteValue, recordDirtyKeys,@@ -164,17 +162,16 @@ import qualified Language.LSP.Protocol.Lens             as L import           Language.LSP.Protocol.Message import           Language.LSP.Protocol.Types-import           Language.LSP.Protocol.Types            (SemanticTokens) import qualified Language.LSP.Protocol.Types            as LSP import qualified Language.LSP.Server                    as LSP import           Language.LSP.VFS                       hiding (start) import qualified "list-t" ListT import           OpenTelemetry.Eventlog                 hiding (addEvent)+import qualified Prettyprinter                          as Pretty import qualified StmContainers.Map                      as STM import           System.FilePath                        hiding (makeRelative) import           System.IO.Unsafe                       (unsafePerformIO) import           System.Time.Extra- -- See Note [Guidelines For Using CPP In GHCIDE Import Statements]  #if !MIN_VERSION_ghc(9,3,0)@@ -193,6 +190,12 @@   | LogDiagsDiffButNoLspEnv ![FileDiagnostic]   | LogDefineEarlyCutoffRuleNoDiagHasDiag !FileDiagnostic   | LogDefineEarlyCutoffRuleCustomNewnessHasDiag !FileDiagnostic+  | LogCancelledAction !T.Text+  | LogSessionInitialised+  | LogLookupPersistentKey !T.Text+  | LogShakeGarbageCollection !T.Text !Int !Seconds+  -- * OfInterest Log messages+  | LogSetFilesOfInterest ![(NormalizedFilePath, FileOfInterestStatus)]   deriving Show  instance Pretty Log where@@ -226,6 +229,16 @@     LogDefineEarlyCutoffRuleCustomNewnessHasDiag fileDiagnostic ->       "defineEarlyCutoff RuleWithCustomNewnessCheck - file diagnostic:"       <+> pretty (showDiagnosticsColored [fileDiagnostic])+    LogCancelledAction action ->+        pretty action <+> "was cancelled"+    LogSessionInitialised -> "Shake session initialized"+    LogLookupPersistentKey key ->+        "LOOKUP PERSISTENT FOR:" <+> pretty key+    LogShakeGarbageCollection label number duration ->+        pretty label <+> "of" <+> pretty number <+> "keys (took " <+> pretty (showDuration duration) <> ")"+    LogSetFilesOfInterest ofInterest ->+        "Set files of interst to" <> Pretty.line+            <> indent 4 (pretty $ fmap (first fromNormalizedFilePath) ofInterest)  -- | We need to serialize writes to the database, so we send any function that -- needs to write to the database over the channel, where it will be picked up by@@ -256,7 +269,7 @@     { --eventer :: LSP.FromServerMessage -> IO ()      lspEnv :: Maybe (LSP.LanguageContextEnv Config)     ,debouncer :: Debouncer NormalizedUri-    ,logger :: Logger+    ,shakeRecorder :: Recorder (WithPriority Log)     ,idePlugins :: IdePlugins IdeState     ,globals :: TVar (HMap.HashMap TypeRep Dynamic)       -- ^ Registry of global state used by rules.@@ -441,7 +454,7 @@           | otherwise = do           pmap <- readTVarIO persistentKeys           mv <- runMaybeT $ do-            liftIO $ Logger.logDebug (logger s) $ T.pack $ "LOOKUP PERSISTENT FOR: " ++ show k+            liftIO $ logWith (shakeRecorder s) Debug $ LogLookupPersistentKey (T.pack $ show k)             f <- MaybeT $ pure $ lookupKeyMap (newKey k) pmap             (dv,del,ver) <- MaybeT $ runIdeAction "lastValueIO" s $ f file             MaybeT $ pure $ (,del,ver) <$> fromDynamic dv@@ -604,7 +617,6 @@           -> Maybe (LSP.LanguageContextEnv Config)           -> Config           -> IdePlugins IdeState-          -> Logger           -> Debouncer NormalizedUri           -> Maybe FilePath           -> IdeReportProgress@@ -615,7 +627,7 @@           -> Monitoring           -> Rules ()           -> IO IdeState-shakeOpen recorder lspEnv defaultConfig idePlugins logger debouncer+shakeOpen recorder lspEnv defaultConfig idePlugins debouncer   shakeProfileDir (IdeReportProgress reportProgress)   ideTesting@(IdeTesting testing)   withHieDb indexQueue opts monitoring rules = mdo@@ -662,7 +674,7 @@         dirtyKeys <- newTVarIO mempty         -- Take one VFS snapshot at the start         vfsVar <- newTVarIO =<< vfsSnapshot lspEnv-        pure ShakeExtras{..}+        pure ShakeExtras{shakeRecorder = recorder, ..}     shakeDb  <-         shakeNewDatabase             opts { shakeExtra = newShakeExtra shakeExtras }@@ -709,7 +721,7 @@     vfs <- vfsSnapshot (lspEnv shakeExtras)     initSession <- newSession recorder shakeExtras (VFSModified vfs) shakeDb [] "shakeSessionInit"     putMVar shakeSession initSession-    logDebug (ideLogger ide) "Shake session initialized"+    logWith recorder Debug LogSessionInitialised  shakeShut :: IdeState -> IO () shakeShut IdeState{..} = do@@ -777,7 +789,7 @@ -- --   Appropriate for user actions other than edits. shakeEnqueue :: ShakeExtras -> DelayedAction a -> IO (IO a)-shakeEnqueue ShakeExtras{actionQueue, logger} act = do+shakeEnqueue ShakeExtras{actionQueue, shakeRecorder} act = do     (b, dai) <- instantiateDelayedAction act     atomicallyNamed "actionQueue - push" $ pushQueue dai actionQueue     let wait' barrier =@@ -786,7 +798,7 @@                     fail $ "internal bug: forever blocked on MVar for " <>                             actionName act)               , Handler (\e@AsyncCancelled -> do-                  logPriority logger Debug $ T.pack $ actionName act <> " was cancelled"+                  logWith shakeRecorder Debug $ LogCancelledAction (T.pack $ actionName act)                    atomicallyNamed "actionQueue - abort" $ abortQueue dai actionQueue                   throw e)@@ -910,13 +922,12 @@ garbageCollectKeys :: String -> Int -> CheckParents -> [(Key, Int)] -> Action [Key] garbageCollectKeys label maxAge checkParents agedKeys = do     start <- liftIO offsetTime-    ShakeExtras{state, dirtyKeys, lspEnv, logger, ideTesting} <- getShakeExtras+    ShakeExtras{state, dirtyKeys, lspEnv, shakeRecorder, ideTesting} <- getShakeExtras     (n::Int, garbage) <- liftIO $         foldM (removeDirtyKey dirtyKeys state) (0,[]) agedKeys     t <- liftIO start     when (n>0) $ liftIO $ do-        logDebug logger $ T.pack $-            label <> " of " <> show n <> " keys (took " <> showDuration t <> ")"+        logWith shakeRecorder Debug $ LogShakeGarbageCollection (T.pack label) n t     when (coerce ideTesting) $ liftIO $ mRunLspT lspEnv $         LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/GC"))                              (toJSON $ mapMaybe (fmap showKey . fromKeyType) garbage)@@ -1307,18 +1318,11 @@             | otherwise = c  -newtype Priority = Priority Double--setPriority :: Priority -> Action ()-setPriority (Priority p) = reschedule p--ideLogger :: IdeState -> Logger-ideLogger IdeState{shakeExtras=ShakeExtras{logger}} = logger+ideLogger :: IdeState -> Recorder (WithPriority Log)+ideLogger IdeState{shakeExtras=ShakeExtras{shakeRecorder}} = shakeRecorder -actionLogger :: Action Logger-actionLogger = do-    ShakeExtras{logger} <- getShakeExtras-    return logger+actionLogger :: Action (Recorder (WithPriority Log))+actionLogger = shakeRecorder <$> getShakeExtras  -------------------------------------------------------------------------------- type STMDiagnosticStore = STM.Map NormalizedUri StoreItem

src/Development/IDE/Core/Tracing.hs view

@@ -7,7 +7,7 @@     , otTracedGarbageCollection     , withTrace     , withEventTrace-    , withTelemetryLogger+    , withTelemetryRecorder     ) where @@ -26,7 +26,7 @@ import           Development.IDE.Types.Diagnostics (FileDiagnostic,                                                     showDiagnostics) import           Development.IDE.Types.Location    (Uri (..))-import           Ide.Logger                        (Logger (Logger))+import           Ide.Logger import           Ide.Types                         (PluginId (..)) import           Language.LSP.Protocol.Types       (NormalizedFilePath,                                                     fromNormalizedFilePath)@@ -51,16 +51,20 @@   | otherwise = act (\_ -> pure ())  -- | Returns a logger that produces telemetry events in a single span-withTelemetryLogger :: (MonadIO m, MonadMask m) => (Logger -> m a) -> m a-withTelemetryLogger k = withSpan "Logger" $ \sp ->+withTelemetryRecorder :: (MonadIO m, MonadMask m) => (Recorder (WithPriority (Doc a)) -> m c) -> m c+withTelemetryRecorder k = withSpan "Logger" $ \sp ->     -- Tracy doesn't like when we create a new span for every log line.     -- To workaround that, we create a single span for all log events.     -- This is fine since we don't care about the span itself, only about the events-    k $ Logger $ \p m ->-            addEvent sp (fromString $ show p) (encodeUtf8 $ trim m)-    where-        -- eventlog message size is limited by EVENT_PAYLOAD_SIZE_MAX = STG_WORD16_MAX-        trim = T.take (fromIntegral(maxBound :: Word16) - 10)+    k $ telemetryLogRecorder sp++-- | Returns a logger that produces telemetry events in a single span.+telemetryLogRecorder :: SpanInFlight -> Recorder (WithPriority (Doc a))+telemetryLogRecorder sp = Recorder $ \WithPriority {..} ->+  liftIO $ addEvent sp (fromString $ show priority) (encodeUtf8 $ trim $ renderStrict $ layoutCompact $ payload)+  where+    -- eventlog message size is limited by EVENT_PAYLOAD_SIZE_MAX = STG_WORD16_MAX+    trim = T.take (fromIntegral(maxBound :: Word16) - 10)  -- | Trace a handler using OpenTelemetry. Adds various useful info into tags in the OpenTelemetry span. otTracedHandler

src/Development/IDE/GHC/Compat.hs view

@@ -504,9 +504,7 @@ generatedNodeInfo = Map.lookup GeneratedInfo . getSourcedNodeInfo . sourcedNodeInfo  data GhcVersion-  = GHC810-  | GHC90-  | GHC92+  = GHC92   | GHC94   | GHC96   | GHC98

src/Development/IDE/GHC/Compat/Core.hs view

@@ -543,6 +543,7 @@ #endif  #if MIN_VERSION_ghc(9,3,0)+import GHC.Utils.Error (mkPlainErrorMsgEnvelope) import GHC.Driver.Env.KnotVars import GHC.Unit.Module.Graph import GHC.Driver.Errors.Types

src/Development/IDE/GHC/Error.hs view

@@ -91,6 +91,7 @@   Position (fromIntegral $ srcLocLine real - 1) (fromIntegral $ srcLocCol real - 1)  -- Note [Unicode support]+-- ~~~~~~~~~~~~~~~~~~~~~~ -- the current situation is: -- LSP Positions use UTF-16 code units(Unicode may count as variable columns); -- GHC use Unicode code points(Unicode count as one column).

src/Development/IDE/LSP/HoverDefinition.hs view

@@ -4,9 +4,9 @@  -- | Display information on hover. module Development.IDE.LSP.HoverDefinition-    (+    ( Log(..)     -- * For haskell-language-server-    hover+    , hover     , gotoDefinition     , gotoTypeDefinition     , documentHighlight@@ -18,8 +18,9 @@ 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 qualified Development.IDE.Core.Rules     as Shake+import           Development.IDE.Core.Shake     (IdeAction, IdeState (..),+                                                 ideLogger, runIdeAction) import           Development.IDE.Types.Location import           Ide.Logger import           Ide.Plugin.Error@@ -30,26 +31,37 @@  import qualified Data.Text                      as T -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)++data Log+  = LogWorkspaceSymbolRequest !T.Text+  | LogRequest !T.Text !Position !NormalizedFilePath+  deriving (Show)++instance Pretty Log where+  pretty = \case+    LogWorkspaceSymbolRequest query -> "Workspace symbols request:" <+> pretty query+    LogRequest label pos nfp ->+      pretty label <+> "request at position" <+> pretty (showPosition pos) <+>+        "in file:" <+> pretty (fromNormalizedFilePath nfp)++gotoDefinition     :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (MessageResult Method_TextDocumentDefinition)+hover              :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (Hover |? Null)+gotoTypeDefinition :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (MessageResult Method_TextDocumentTypeDefinition)+documentHighlight  :: Recorder (WithPriority Log) -> 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 :: PluginMethodHandler IdeState Method_TextDocumentReferences-references ide _ (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = do+references :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Method_TextDocumentReferences+references recorder 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 (show nfp)-  InL <$> (liftIO $ runAction "references" ide $ refsAtPoint nfp pos)+  liftIO $ logWith recorder Debug $ LogRequest "References" pos nfp+  InL <$> (liftIO $ Shake.runAction "references" ide $ refsAtPoint nfp pos) -wsSymbols :: PluginMethodHandler IdeState Method_WorkspaceSymbol-wsSymbols ide _ (WorkspaceSymbolParams _ _ query) = liftIO $ do-  logDebug (ideLogger ide) $ "Workspace symbols request: " <> query+wsSymbols :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Method_WorkspaceSymbol+wsSymbols recorder ide _ (WorkspaceSymbolParams _ _ query) = liftIO $ do+  logWith recorder Debug $ LogWorkspaceSymbolRequest query   runIdeAction "WorkspaceSymbols" (shakeExtras ide) $ InL . fromMaybe [] <$> workspaceSymbols query  foundHover :: (Maybe Range, [T.Text]) -> Hover |? Null@@ -62,19 +74,18 @@   -> (NormalizedFilePath -> Position -> IdeAction (Maybe a))   -> b   -> (a -> b)+  -> Recorder (WithPriority Log)   -> IdeState   -> TextDocumentPositionParams   -> ExceptT PluginError (LSP.LspM c) b-request label getResults notFound found ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = liftIO $ do+request label getResults notFound found recorder ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = liftIO $ do     mbResult <- case uriToFilePath' uri of-        Just path -> logAndRunRequest label getResults ide pos path+        Just path -> logAndRunRequest recorder label getResults ide pos path         Nothing   -> pure Nothing     pure $ maybe notFound found mbResult -logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> IdeAction b) -> IdeState -> Position -> String -> IO b-logAndRunRequest label getResults ide pos path = do+logAndRunRequest :: Recorder (WithPriority Log) -> T.Text -> (NormalizedFilePath -> Position -> IdeAction b) -> IdeState -> Position -> String -> IO b+logAndRunRequest recorder label getResults ide pos path = do   let filePath = toNormalizedFilePath' path-  logDebug (ideLogger ide) $-    label <> " request at position " <> T.pack (showPosition pos) <>-    " in file: " <> T.pack path+  logWith recorder Debug $ LogRequest label pos filePath   runIdeAction (T.unpack label) (shakeExtras ide) (getResults filePath pos)

src/Development/IDE/LSP/LanguageServer.hs view

@@ -42,7 +42,6 @@ import           Language.LSP.Server                   (LanguageContextEnv,                                                         LspServerLog,                                                         type (<~>))-import           System.IO.Unsafe                      (unsafeInterleaveIO) data Log   = LogRegisteringIdeConfig !IdeConfiguration   | LogReactorThreadException !SomeException@@ -51,6 +50,7 @@   | LogCancelledRequest !SomeLspId   | LogSession Session.Log   | LogLspServer LspServerLog+  | LogServerShutdownMessage   deriving Show  instance Pretty Log where@@ -74,6 +74,7 @@       "Cancelled request" <+> viaShow requestId     LogSession msg -> pretty msg     LogLspServer msg -> pretty msg+    LogServerShutdownMessage -> "Received shutdown message"  -- used to smuggle RankNType WithHieDb through dbMVar newtype WithHieDbShield = WithHieDbShield WithHieDb@@ -155,7 +156,7 @@           -- We want to avoid that the list of cancelled requests           -- keeps growing if we receive cancellations for requests           -- that do not exist or have already been processed.-          when (reqId `elem` queued) $+          when (reqId `Set.member` queued) $               modifyTVar cancelledRequests (Set.insert reqId)   let clearReqId reqId = atomically $ do           modifyTVar pendingRequests (Set.delete reqId)@@ -170,7 +171,7 @@         [ userHandlers         , cancelHandler cancelRequest         , exitHandler exit-        , shutdownHandler stopReactorLoop+        , shutdownHandler recorder stopReactorLoop         ]         -- Cancel requests are special since they need to be handled         -- out of order to be useful. Existing handlers are run afterwards.@@ -197,19 +198,11 @@     let root = LSP.resRootPath env     dir <- maybe getCurrentDirectory return root     dbLoc <- getHieDbLoc dir--    -- The database needs to be open for the duration of the reactor thread, but we need to pass in a reference-    -- to 'getIdeState', so we use this dirty trick-    dbMVar <- newEmptyMVar-    ~(WithHieDbShield withHieDb,hieChan) <- unsafeInterleaveIO $ takeMVar dbMVar--    ide <- getIdeState env root withHieDb hieChan-     let initConfig = parseConfiguration params-     logWith recorder Info $ LogRegisteringIdeConfig initConfig-    registerIdeConfiguration (shakeExtras ide) initConfig+    dbMVar <- newEmptyMVar +     let handleServerException (Left e) = do             logWith recorder Error $ LogReactorThreadException e             exitClientMsg@@ -245,6 +238,10 @@                     ReactorNotification act -> handle exceptionInHandler act                     ReactorRequest _id act k -> void $ async $ checkCancelled _id act k         logWith recorder Info LogReactorThreadStopped++    (WithHieDbShield withHieDb,hieChan) <- takeMVar dbMVar+    ide <- getIdeState env root withHieDb hieChan+    registerIdeConfiguration (shakeExtras ide) initConfig     pure $ Right (env,ide)  @@ -261,10 +258,10 @@         toLspId (InL x) = IdInt x         toLspId (InR y) = IdString y -shutdownHandler :: IO () -> LSP.Handlers (ServerM c)-shutdownHandler stopReactor = LSP.requestHandler SMethod_Shutdown $ \_ resp -> do+shutdownHandler :: Recorder (WithPriority Log) -> IO () -> LSP.Handlers (ServerM c)+shutdownHandler recorder stopReactor = LSP.requestHandler SMethod_Shutdown $ \_ resp -> do     (_, ide) <- ask-    liftIO $ logDebug (ideLogger ide) "Received shutdown message"+    liftIO $ logWith recorder Debug LogServerShutdownMessage     -- stop the reactor to free up the hiedb connection     liftIO stopReactor     -- flush out the Shake session to record a Shake profile if applicable

src/Development/IDE/LSP/Notifications.hs view

@@ -41,12 +41,25 @@ data Log   = LogShake Shake.Log   | LogFileStore FileStore.Log+  | LogOpenTextDocument !Uri+  | LogOpenedTextDocument !Uri+  | LogModifiedTextDocument !Uri+  | LogSavedTextDocument !Uri+  | LogClosedTextDocument !Uri+  | LogWatchedFileEvents !Text.Text+  | LogWarnNoWatchedFilesSupport   deriving Show  instance Pretty Log where   pretty = \case     LogShake msg     -> pretty msg     LogFileStore msg -> pretty msg+    LogOpenedTextDocument uri ->  "Opened text document:" <+> pretty (getUri uri)+    LogModifiedTextDocument uri -> "Modified text document:" <+> pretty (getUri uri)+    LogSavedTextDocument uri -> "Saved text document:" <+> pretty (getUri uri)+    LogClosedTextDocument uri -> "Closed text document:" <+> pretty (getUri uri)+    LogWatchedFileEvents msg -> "Watched file events:" <+> pretty msg+    LogWarnNoWatchedFilesSupport -> "Client does not support watched files. Falling back to OS polling"  whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO () whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath'@@ -61,7 +74,7 @@           -- For example, vscode restores previously unsaved contents on open           addFileOfInterest ide file Modified{firstOpen=True}           setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False file-          logDebug (ideLogger ide) $ "Opened text document: " <> getUri _uri+          logWith recorder Debug $ LogOpenedTextDocument _uri    , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidChange $       \ide vfs _ (DidChangeTextDocumentParams identifier@VersionedTextDocumentIdentifier{_uri} changes) -> liftIO $ do@@ -69,14 +82,14 @@         whenUriFile _uri $ \file -> do           addFileOfInterest ide file Modified{firstOpen=False}           setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False file-        logDebug (ideLogger ide) $ "Modified text document: " <> getUri _uri+        logWith recorder Debug $ LogModifiedTextDocument _uri    , 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+        logWith recorder Debug $ LogSavedTextDocument _uri    , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidClose $         \ide vfs _ (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do@@ -85,7 +98,7 @@               let msg = "Closed text document: " <> getUri _uri               scheduleGarbageCollection ide               setSomethingModified (VFSModified vfs) ide [] $ Text.unpack msg-              logDebug (ideLogger ide) msg+              logWith recorder Debug $ LogClosedTextDocument _uri    , mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeWatchedFiles $       \ide vfs _ (DidChangeWatchedFilesParams fileEvents) -> liftIO $ do@@ -102,7 +115,7 @@                 ]         unless (null fileEvents') $ do             let msg = show fileEvents'-            logDebug (ideLogger ide) $ "Watched file events: " <> Text.pack msg+            logWith recorder Debug $ LogWatchedFileEvents (Text.pack msg)             modifyFileExists ide fileEvents'             resetFileStore ide fileEvents'             setSomethingModified (VFSModified vfs) ide [] msg@@ -133,7 +146,7 @@       let globs = watchedGlobs opts       success <- registerFileWatches globs       unless success $-        liftIO $ logDebug (ideLogger ide) "Warning: Client does not support watched files. Falling back to OS polling"+        liftIO $ logWith recorder Warning LogWarnNoWatchedFilesSupport   ],      -- The ghcide descriptors should come last'ish so that the notification handlers

src/Development/IDE/Main.hs view

@@ -65,7 +65,6 @@ import qualified Development.IDE.LSP.LanguageServer       as LanguageServer import           Development.IDE.Main.HeapStats           (withHeapStats) import qualified Development.IDE.Main.HeapStats           as HeapStats-import qualified Development.IDE.Monitoring.EKG           as EKG import qualified Development.IDE.Monitoring.OpenTelemetry as OpenTelemetry import           Development.IDE.Plugin                   (Plugin (pluginHandlers, pluginModifyDynflags, pluginRules)) import           Development.IDE.Plugin.HLS               (asGhcIdePlugin)@@ -95,14 +94,13 @@ import           GHC.IO.Handle                            (hDuplicate) import           HIE.Bios.Cradle                          (findCradle) import qualified HieDb.Run                                as HieDb-import           Ide.Logger                               (Logger,-                                                           Pretty (pretty),+import           Ide.Logger                               (Pretty (pretty),                                                            Priority (Info),                                                            Recorder,                                                            WithPriority,                                                            cmapWithPrio,-                                                           logDebug, logWith,-                                                           nest, vsep, (<+>))+                                                           logWith, nest, vsep,+                                                           (<+>)) import           Ide.Plugin.Config                        (CheckParents (NeverCheck),                                                            Config, checkParents,                                                            checkProject,@@ -140,6 +138,7 @@   | LogLspStartDuration !Seconds   | LogShouldRunSubset !Bool   | LogSetInitialDynFlagsException !SomeException+  | LogConfigurationChange T.Text   | LogService Service.Log   | LogShake Shake.Log   | LogGhcIde GhcIde.Log@@ -164,6 +163,7 @@       "shouldRunSubset:" <+> pretty shouldRunSubset     LogSetInitialDynFlagsException e ->       "setInitialDynFlags:" <+> pretty (displayException e)+    LogConfigurationChange msg -> "Configuration changed:" <+> pretty msg     LogService msg -> pretty msg     LogShake msg -> pretty msg     LogGhcIde msg -> pretty msg@@ -210,7 +210,6 @@ data Arguments = Arguments     { argsProjectRoot           :: Maybe FilePath     , argCommand                :: Command-    , argsLogger                :: IO Logger     , argsRules                 :: Rules ()     , argsHlsPlugins            :: IdePlugins IdeState     , argsGhcidePlugin          :: Plugin Config  -- ^ Deprecated@@ -226,11 +225,10 @@     , argsMonitoring            :: IO Monitoring     } -defaultArguments :: Recorder (WithPriority Log) -> Logger -> IdePlugins IdeState -> Arguments-defaultArguments recorder logger plugins = Arguments+defaultArguments :: Recorder (WithPriority Log) -> IdePlugins IdeState -> Arguments+defaultArguments recorder plugins = Arguments         { argsProjectRoot = Nothing         , argCommand = LSP-        , argsLogger = pure logger         , argsRules = mainRule (cmapWithPrio LogRules recorder) def >> action kick         , argsGhcidePlugin = mempty         , argsHlsPlugins = pluginDescToIdePlugins (GhcIde.descriptors (cmapWithPrio LogGhcIde recorder)) <> plugins@@ -259,15 +257,15 @@                 -- the language server tests without the redirection.                 putStr " " >> hFlush stdout                 return newStdout-        , argsMonitoring = OpenTelemetry.monitoring <> EKG.monitoring logger 8999+        , argsMonitoring = OpenTelemetry.monitoring         }  -testing :: Recorder (WithPriority Log) -> Logger -> IdePlugins IdeState -> Arguments-testing recorder logger plugins =+testing :: Recorder (WithPriority Log) -> IdePlugins IdeState -> Arguments+testing recorder plugins =   let     arguments@Arguments{ argsHlsPlugins, argsIdeOptions } =-        defaultArguments recorder logger plugins+        defaultArguments recorder plugins     hlsPlugins = pluginDescToIdePlugins $       idePluginsToPluginDesc argsHlsPlugins       ++ [Test.blockCommandDescriptor "block-command", Test.plugin]@@ -288,7 +286,6 @@   fun = do     setLocaleEncoding utf8     pid <- T.pack . show <$> getProcessID-    logger <- argsLogger     hSetBuffering stderr LineBuffering      let hlsPlugin = asGhcIdePlugin (cmapWithPrio LogPluginHLS recorder) argsHlsPlugins@@ -347,7 +344,6 @@                       argsHlsPlugins                       rules                       (Just env)-                      logger                       debouncer                       ideOptions                       withHieDb@@ -366,7 +362,7 @@                     Nothing -> pure ()                     Just ide -> liftIO $ do                         let msg = T.pack $ show cfg-                        logDebug (Shake.ideLogger ide) $ "Configuration changed: " <> msg+                        logWith recorder Debug $ LogConfigurationChange msg                         modifyClientSettings ide (const $ Just cfgObj)                         setSomethingModified Shake.VFSUnmodified ide [toKey Rules.GetClientSettings emptyFilePath] "config change" @@ -403,7 +399,7 @@                         , optCheckProject = pure False                         , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins                         }-            ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing logger debouncer ideOptions hiedb hieChan mempty+            ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb hieChan mempty             shakeSessionInit (cmapWithPrio LogShake recorder) ide             registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) @@ -441,7 +437,7 @@                     , optCheckProject = pure False                     , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins                     }-            ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing logger debouncer ideOptions hiedb hieChan mempty+            ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb hieChan mempty             shakeSessionInit (cmapWithPrio LogShake recorder) ide             registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing)             c ide

− src/Development/IDE/Monitoring/EKG.hs

@@ -1,49 +0,0 @@-{-# LANGUAGE CPP #-}-module Development.IDE.Monitoring.EKG(monitoring) where--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           Ide.Logger                       (logInfo)-import qualified System.Metrics                   as Monitoring-import qualified System.Remote.Monitoring.Wai     as Monitoring---- | Monitoring using EKG-monitoring :: Logger -> Int -> IO Monitoring-monitoring logger port = do-    store <- Monitoring.newStore-    Monitoring.registerGcMetrics store-    let registerCounter name read = Monitoring.registerCounter name read store-        registerGauge name read = Monitoring.registerGauge name read store-        start = do-            server <- do-                let startServer = Monitoring.forkServerWith store "localhost" port-                -- this can fail if the port is busy, throwing an async exception back to us-                -- to handle that, wrap the server thread in an async-                mb_server <- async startServer >>= waitCatch-                case mb_server of-                    Right s -> do-                        logInfo logger $ pack $-                            "Started monitoring server on port " <> show port-                        return $ Just s-                    Left e -> do-                        logInfo logger $ pack $-                            "Unable to bind monitoring server on port "-                            <> show port <> ":" <> show e-                        return Nothing-            return $ forM_ server $ \s -> do-                logInfo logger "Stopping monitoring server"-                killThread $ Monitoring.serverThreadId s-    return $ Monitoring {..}--#else--monitoring :: Logger -> Int -> IO Monitoring-monitoring _ _ = mempty--#endif

src/Development/IDE/Plugin/HLS.hs view

@@ -359,6 +359,7 @@   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,

src/Development/IDE/Plugin/HLS/GhcIde.hs view

@@ -9,7 +9,7 @@   ) where import           Control.Monad.IO.Class import           Development.IDE-import           Development.IDE.LSP.HoverDefinition+import qualified Development.IDE.LSP.HoverDefinition as Hover import qualified Development.IDE.LSP.Notifications   as Notifications import           Development.IDE.LSP.Outline import qualified Development.IDE.Plugin.Completions  as Completions@@ -23,6 +23,7 @@   = LogNotifications Notifications.Log   | LogCompletions Completions.Log   | LogTypeLenses TypeLenses.Log+  | LogHover Hover.Log   deriving Show  instance Pretty Log where@@ -30,10 +31,11 @@     LogNotifications msg -> pretty msg     LogCompletions msg   -> pretty msg     LogTypeLenses msg    -> pretty msg+    LogHover msg         -> pretty msg  descriptors :: Recorder (WithPriority Log) -> [PluginDescriptor IdeState] descriptors recorder =-  [ descriptor "ghcide-hover-and-symbols",+  [ descriptor (cmapWithPrio LogHover recorder) "ghcide-hover-and-symbols",     Completions.descriptor (cmapWithPrio LogCompletions recorder) "ghcide-completions",     TypeLenses.descriptor (cmapWithPrio LogTypeLenses recorder) "ghcide-type-lenses",     Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core"@@ -41,18 +43,18 @@  -- --------------------------------------------------------------------- -descriptor :: PluginId -> PluginDescriptor IdeState-descriptor plId = (defaultPluginDescriptor plId desc)-  { pluginHandlers = mkPluginHandler SMethod_TextDocumentHover hover'+descriptor :: Recorder (WithPriority Hover.Log) -> PluginId -> PluginDescriptor IdeState+descriptor recorder plId = (defaultPluginDescriptor plId desc)+  { pluginHandlers = mkPluginHandler SMethod_TextDocumentHover (hover' recorder)                   <> mkPluginHandler SMethod_TextDocumentDocumentSymbol moduleOutline                   <> mkPluginHandler SMethod_TextDocumentDefinition (\ide _ DefinitionParams{..} ->-                      gotoDefinition ide TextDocumentPositionParams{..})+                      Hover.gotoDefinition recorder ide TextDocumentPositionParams{..})                   <> mkPluginHandler SMethod_TextDocumentTypeDefinition (\ide _ TypeDefinitionParams{..} ->-                      gotoTypeDefinition ide TextDocumentPositionParams{..})+                      Hover.gotoTypeDefinition recorder ide TextDocumentPositionParams{..})                   <> mkPluginHandler SMethod_TextDocumentDocumentHighlight (\ide _ DocumentHighlightParams{..} ->-                      documentHighlight ide TextDocumentPositionParams{..})-                  <> mkPluginHandler SMethod_TextDocumentReferences references-                  <> mkPluginHandler SMethod_WorkspaceSymbol wsSymbols,+                      Hover.documentHighlight recorder ide TextDocumentPositionParams{..})+                  <> mkPluginHandler SMethod_TextDocumentReferences (Hover.references recorder)+                  <> mkPluginHandler SMethod_WorkspaceSymbol (Hover.wsSymbols recorder),      pluginConfigDescriptor = defaultConfigDescriptor   }@@ -61,7 +63,6 @@  -- --------------------------------------------------------------------- -hover' :: PluginMethodHandler IdeState Method_TextDocumentHover-hover' ideState _ HoverParams{..} = do-    liftIO $ logDebug (ideLogger ideState) "GhcIde.hover entered (ideLogger)" -- AZ-    hover ideState TextDocumentPositionParams{..}+hover' :: Recorder (WithPriority Hover.Log) -> PluginMethodHandler IdeState Method_TextDocumentHover+hover' recorder ideState _ HoverParams{..} =+    Hover.hover recorder ideState TextDocumentPositionParams{..}

src/Development/IDE/Types/Exports.hs view

@@ -207,7 +207,7 @@  buildModuleExportMap:: [(ModuleName, HashSet IdentInfo)] -> ModuleNameEnv (HashSet IdentInfo) buildModuleExportMap exportsMap = do-  let lst = concatMap (Set.toList. snd) exportsMap+  let lst = concatMap (Set.toList . snd) exportsMap   let lstThree = map identInfoToKeyVal lst   sortAndGroup lstThree @@ -223,4 +223,4 @@   (modName, functionSet)  sortAndGroup :: [(ModuleName, IdentInfo)] -> ModuleNameEnv (HashSet IdentInfo)-sortAndGroup assocs = listToUFM_C (<>) [(k, Set.fromList [v]) | (k, v) <- assocs]+sortAndGroup assocs = listToUFM_C (<>) [(k, Set.singleton v) | (k, v) <- assocs]

− test/data/plugin-recorddot/RecordDot.hs

@@ -1,6 +0,0 @@-{-# LANGUAGE DuplicateRecordFields, TypeApplications, TypeFamilies, UndecidableInstances, FlexibleContexts, DataKinds, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}-{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-}-module RecordDot (Company(..), display) where-data Company = Company {name :: String}-display :: Company -> String-display c = c.name

− test/data/plugin-recorddot/cabal.project

@@ -1,1 +0,0 @@-packages: .

− test/data/plugin-recorddot/plugin.cabal

@@ -1,9 +0,0 @@-cabal-version:  1.18-name: plugin-version: 1.0.0-build-type: Simple--library-  build-depends: base, record-dot-preprocessor, record-hasfield-  exposed-modules: RecordDot-  hs-source-dirs: .

− test/exe/AsyncTests.hs

@@ -1,53 +0,0 @@-{-# 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 <- getAndResolveCodeLenses 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 <- getAndResolveCodeLenses doc-            liftIO $ [ _title | CodeLens{_command = Just Command{_title}} <- codeLenses] @=?-              [ "foo :: a -> a" ]-    ]

− test/exe/BootTests.hs

@@ -1,55 +0,0 @@-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-  ]

− test/exe/CPPTests.hs

@@ -1,56 +0,0 @@-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

− test/exe/ClientSettingsTests.hs

@@ -1,34 +0,0 @@-{-# LANGUAGE GADTs #-}-module ClientSettingsTests (tests) where--import           Control.Applicative.Combinators-import           Control.Monad-import           Data.Aeson                      (toJSON)-import           Data.Default-import qualified Data.Text                       as T-import           Ide.Types-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-            setIgnoringLogNotifications False-            void $ createDoc "A.hs" "haskell" "module A where"-            waitForProgressDone-            setConfigSection "haskell" $ toJSON (def :: Config)-            skipManyTill anyMessage restartingBuildSession--    ]-  where-    restartingBuildSession :: Session ()-    restartingBuildSession = do-        FromServerMess SMethod_WindowLogMessage TNotificationMessage{_params = LogMessageParams{..}} <- loggingNotification-        guard $ "Restarting build session" `T.isInfixOf` _message

− test/exe/CodeLensTests.hs

@@ -1,121 +0,0 @@-{-# LANGUAGE GADTs #-}--module CodeLensTests (tests) where--import           Control.Applicative.Combinators-import           Control.Lens                    ((^.))-import           Control.Monad                   (void)-import           Control.Monad.IO.Class          (liftIO)-import qualified Data.Aeson                      as A-import           Data.Maybe-import qualified Data.Text                       as T-import           Data.Tuple.Extra-import           Development.IDE.GHC.Compat      (GhcVersion (..), ghcVersion)-import qualified Language.LSP.Protocol.Lens      as L-import           Language.LSP.Protocol.Types     hiding-                                                 (SemanticTokenAbsolute (..),-                                                  SemanticTokenRelative (..),-                                                  SemanticTokensEdit (..),-                                                  mkRange)-import           Language.LSP.Test-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 ["plugin" A..= A.object ["ghcide-type-lenses" A..= A.object ["config" A..= A.object ["mode" A..= A.String mode]]]]-      sigSession testName enableGHCWarnings waitForDiags mode exported def others = testSession testName $ do-        let originalCode = before enableGHCWarnings exported def others-        let expectedCode = after' enableGHCWarnings exported def others-        setConfigSection "haskell" (createConfig mode)-        doc <- createDoc "Sigs.hs" "haskell" originalCode-        -- Because the diagnostics mode is really relying only on diagnostics now-        -- to generate the code lens we need to make sure we wait till the file-        -- is parsed before asking for codelenses, otherwise we will get nothing.-        if waitForDiags-          then void waitForDiagnostics-          else waitForProgressDone-        codeLenses <- getAndResolveCodeLenses doc-        if not $ null $ snd def-          then do-            liftIO $ length codeLenses == 1 @? "Expected 1 code lens, but got: " <> show codeLenses-            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")-        , ("aVeryLongSignature a b c d e f g h i j k l m n = a && b && c && d && e && f && g && h && i && j && k && l && m && n", "aVeryLongSignature :: Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool")-        ]-   in testGroup-        "add signature"-        [ testGroup "signatures are correct" [sigSession (T.unpack $ T.replace "\n" "\\n" def) False False "always" "" (def, Just sig) [] | (def, sig) <- cases]-        , sigSession "exported mode works" False False "exported" "xyz" ("xyz = True", Just "xyz :: Bool") (fst <$> take 3 cases)-        , testGroup-            "diagnostics mode works"-            [ sigSession "with GHC warnings" True True "diagnostics" "" (second Just $ head cases) []-            , sigSession "without GHC warnings" False False "diagnostics" "" (second (const Nothing) $ head cases) []-            ]-        , testSession "keep stale lens" $ do-            let content = T.unlines-                    [ "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]"--

− test/exe/CompletionTests.hs

@@ -1,575 +0,0 @@--{-# 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 [GHC90, GHC92, GHC94, GHC96, GHC98]) "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 1 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-    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

− test/exe/CradleTests.hs

@@ -1,241 +0,0 @@--{-# 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"   (multiTests "multi")-    ,ignoreFor (BrokenForGHC [GHC92]) "multiple units not supported on 9.2"-       $ testGroup "multi-unit" (multiTests "multi-unit")-    ,testGroup "sub-directory"   [simpleSubDirectoryTest]-    ,ignoreFor (BrokenForGHC [GHC92]) "multiple units not supported on 9.2"-      $ testGroup "multi-unit-rexport" [multiRexportTest]-    ]--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--multiTests :: FilePath -> [TestTree]-multiTests dir =-  [simpleMultiTest dir, simpleMultiTest2 dir, simpleMultiTest3 dir, simpleMultiDefTest dir]--multiTestName :: FilePath -> String -> String-multiTestName dir name = "simple-" ++ dir ++ "-" ++ name--simpleMultiTest :: FilePath -> TestTree-simpleMultiTest variant = testCase (multiTestName variant "test") $ withLongTimeout $ runWithExtraFiles variant $ \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 :: FilePath -> TestTree-simpleMultiTest2 variant = testCase (multiTestName variant "test2") $ runWithExtraFiles variant $ \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 :: FilePath -> TestTree-simpleMultiTest3 variant =-  testCase (multiTestName variant "test3") $ runWithExtraFiles variant $ \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 :: FilePath -> TestTree-simpleMultiDefTest variant = testCase (multiTestName variant "def-test") $ runWithExtraFiles variant $ \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--multiRexportTest :: TestTree-multiRexportTest =-  testCase "multi-unit-reexport-test"  $ runWithExtraFiles "multi-unit-reexport" $ \dir -> do-    let cPath = dir </> "c/C.hs"-    cdoc <- openDoc cPath "haskell"-    WaitForIdeRuleResult {} <- waitForAction "TypeCheck" cdoc-    locs <- getDefinitions cdoc (Position 3 7)-    let aPath = dir </> "a/A.hs"-    let fooL = mkL (filePathToUri aPath) 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\""-        ]

− test/exe/DependentFileTest.hs

@@ -1,62 +0,0 @@--{-# 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", [])]

− test/exe/DiagnosticTests.hs

@@ -1,593 +0,0 @@--{-# 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           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")])]-  , testSession' "bidirectional module dependency with hs-boot" $ \path -> do-      let cradle = unlines-            [ "cradle:"-            , "  direct: {arguments: [ModuleA, ModuleB]}"-            ]-      let contentA = T.unlines-            [ "module ModuleA where"-            , "import {-# SOURCE #-} ModuleB"-            ]-      let contentB = T.unlines-            [ "{-# OPTIONS -Wmissing-signatures#-}"-            , "module ModuleB where"-            , "import {-# SOURCE #-} ModuleA"-            -- introduce an artificial diagnostic-            , "foo = ()"-            ]-      let contentBboot = T.unlines-            [ "module ModuleB where"-            ]-      let contentAboot = T.unlines-            [ "module ModuleA where"-            ]-      liftIO $ writeFile (path </> "hie.yaml") cradle-      _ <- createDoc "ModuleA.hs" "haskell" contentA-      _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot-      _ <- 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

− test/exe/ExceptionTests.hs

@@ -1,156 +0,0 @@--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.Plugin.HandleRequestTypes     (RejectionReason (DisabledGlobally))-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 "error test") (PluginInvalidParams "error test")-      , pluginOrderTestCase recorder logger  "InvalidParams over InvalidUserState" (PluginInvalidParams "error test") (PluginInvalidUserState "error test")-      , pluginOrderTestCase recorder logger  "InvalidUserState over RequestRefused" (PluginInvalidUserState "error test") (PluginRequestRefused DisabledGlobally)-      ]-   ]--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 -> PluginError -> 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-                        ,mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do-                          throwError err2-                      ]-                  }]-      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) == re -> pure ()-                    | otherwise -> liftIO $ assertFailure "We caught an error, but it wasn't ours!"-            _ -> liftIO $ assertFailure $ show lens

− test/exe/FindDefinitionAndHoverTests.hs

@@ -1,249 +0,0 @@--{-# 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           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 17 24) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["x :: MyRecord"]]) "hover over parent"-        , tst (getHover, checkHover) (Position 17 25) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over dot shows child"-        , tst (getHover, checkHover) (Position 17 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"-  , test  yes    yes    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

− test/exe/FuzzySearch.hs

@@ -1,129 +0,0 @@-module FuzzySearch (tests) where--import           Data.Char                  (toLower)-import           Data.Maybe                 (catMaybes)-import qualified Data.Monoid.Textual        as T-import           Data.Text                  (Text, inits, pack)-import qualified Data.Text                  as Text-import           Prelude                    hiding (filter)-import           System.Directory           (doesFileExist)-import           System.IO.Unsafe           (unsafePerformIO)-import           Test.QuickCheck-import           Test.Tasty-import           Test.Tasty.ExpectedFailure-import           Test.Tasty.QuickCheck      (testProperty)-import qualified Text.Fuzzy                 as Fuzzy-import           Text.Fuzzy                 (Fuzzy (..))-import           Text.Fuzzy.Parallel--tests :: TestTree-tests =-  testGroup-    "Fuzzy search"-    [ needDictionary $-        testGroup-          "match works as expected on the english dictionary"-          [ testProperty "for legit words" propLegit,-            testProperty "for prefixes" propPrefix,-            testProperty "for typos" propTypo-          ]-    ]--test :: Text -> Bool-test candidate = do-  let previous =-        catMaybes-          [ (d,) . Fuzzy.score-              <$> referenceImplementation candidate d "" "" id-            | d <- dictionary-          ]-      new = catMaybes [(d,) <$> match candidate d | d <- dictionary]-  previous == new--propLegit :: Property-propLegit = forAll (elements dictionary) test--propPrefix :: Property-propPrefix = forAll (elements dictionary >>= elements . inits) test--propTypo :: Property-propTypo = forAll typoGen test--typoGen :: Gen Text-typoGen = do-  w <- elements dictionary-  l <- elements [0 .. Text.length w -1]-  let wl = Text.index w l-  c <- elements [ c | c <- ['a' .. 'z'], c /= wl]-  return $ replaceAt w l c--replaceAt :: Text -> Int -> Char -> Text-replaceAt t i c =-  let (l, r) = Text.splitAt i t-   in l <> Text.singleton c <> r--dictionaryPath :: FilePath-dictionaryPath = "/usr/share/dict/words"--{-# NOINLINE dictionary #-}-dictionary :: [Text]-dictionary = unsafePerformIO $ do-  existsDictionary <- doesFileExist dictionaryPath-  if existsDictionary-    then map pack . words <$> readFile dictionaryPath-    else pure []--referenceImplementation ::-  (T.TextualMonoid s) =>-  -- | Pattern in lowercase except for first character-  s ->-  -- | The value containing the text to search in.-  t ->-  -- | The text to add before each match.-  s ->-  -- | The text to add after each match.-  s ->-  -- | The function to extract the text from the container.-  (t -> s) ->-  -- | The original value, rendered string and score.-  Maybe (Fuzzy t s)-referenceImplementation pattern t pre post extract =-  if null pat then Just (Fuzzy t result totalScore) else Nothing-  where-    null :: (T.TextualMonoid s) => s -> Bool-    null = not . T.any (const True)--    s = extract t-    (totalScore, _currScore, result, pat, _) =-      T.foldl'-        undefined-        ( \(tot, cur, res, pat, isFirst) c ->-            case T.splitCharacterPrefix pat of-              Nothing -> (tot, 0, res <> T.singleton c, pat, isFirst)-              Just (x, xs) ->-                -- the case of the first character has to match-                -- otherwise use lower case since the pattern is assumed lower-                let !c' = if isFirst then c else toLower c-                 in if x == c'-                      then-                        let cur' = cur * 2 + 1-                         in ( tot + cur',-                              cur',-                              res <> pre <> T.singleton c <> post,-                              xs,-                              False-                            )-                      else (tot, 0, res <> T.singleton c, pat, isFirst)-        )-        ( 0,-          1, -- matching at the start gives a bonus (cur = 1)-          mempty,-          pattern,-          True-        )-        s--needDictionary :: TestTree -> TestTree-needDictionary-  | null dictionary = ignoreTestBecause ("not found: " <> dictionaryPath)-  | otherwise = id

− test/exe/GarbageCollectionTests.hs

@@ -1,94 +0,0 @@--{-# LANGUAGE OverloadedLabels #-}--module GarbageCollectionTests (tests) where--import           Control.Monad.IO.Class      (liftIO)-import           Data.Row-import qualified Data.Set                    as Set-import qualified Data.Text                   as T-import           Development.IDE.Test        (expectCurrentDiagnostics,-                                              getStoredKeys, waitForGC,-                                              waitForTypecheck)-import           Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..),-                                              SemanticTokenRelative (..),-                                              SemanticTokensEdit (..), mkRange)-import           Language.LSP.Test-import           System.FilePath--- import Test.QuickCheck.Instances ()-import           Test.Tasty-import           Test.Tasty.HUnit-import           TestUtils-import           Text.Printf                 (printf)--tests :: TestTree-tests = testGroup "garbage collection"-  [ testGroup "dirty keys"-        [ testSession' "are collected" $ \dir -> do-            liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A]}}"-            doc <- generateGarbage "A" dir-            closeDoc doc-            garbage <- waitForGC-            liftIO $ assertBool "no garbage was found" $ not $ null garbage--        , testSession' "are deleted from the state" $ \dir -> do-            liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A]}}"-            docA <- generateGarbage "A" dir-            keys0 <- getStoredKeys-            closeDoc docA-            garbage <- waitForGC-            liftIO $ assertBool "something is wrong with this test - no garbage found" $ not $ null garbage-            keys1 <- getStoredKeys-            liftIO $ assertBool "keys were not deleted from the state" (length keys1 < length keys0)--        , testSession' "are not regenerated unless needed" $ \dir -> do-            liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A.hs, B.hs]}}"-            docA <- generateGarbage "A" dir-            _docB <- generateGarbage "B" dir--            -- garbage collect A keys-            keysBeforeGC <- getStoredKeys-            closeDoc docA-            garbage <- waitForGC-            liftIO $ assertBool "something is wrong with this test - no garbage found" $ not $ null garbage-            keysAfterGC <- getStoredKeys-            liftIO $ assertBool "something is wrong with this test - keys were not deleted from the state"-                (length keysAfterGC < length keysBeforeGC)--            -- re-typecheck B and check that the keys for A have not materialized back-            _docB <- generateGarbage "B" dir-            keysB <- getStoredKeys-            let regeneratedKeys = Set.filter (not . isExpected) $-                    Set.intersection (Set.fromList garbage) (Set.fromList keysB)-            liftIO $ regeneratedKeys @?= mempty--        , testSession' "regenerate successfully" $ \dir -> do-            liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A]}}"-            docA <- generateGarbage "A" dir-            closeDoc docA-            garbage <- waitForGC-            liftIO $ assertBool "no garbage was found" $ not $ null garbage-            let edit = T.unlines-                        [ "module A where"-                        , "a :: Bool"-                        , "a = ()"-                        ]-            doc <- generateGarbage "A" dir-            changeDoc doc [TextDocumentContentChangeEvent . InR . (.==) #text $ edit]-            builds <- waitForTypecheck doc-            liftIO $ assertBool "it still builds" builds-            expectCurrentDiagnostics doc [(DiagnosticSeverity_Error, (2,4), "Couldn't match expected type")]-        ]-  ]-  where-    isExpected k = any (`T.isPrefixOf` k) ["GhcSessionIO"]--    generateGarbage :: String -> FilePath -> Session TextDocumentIdentifier-    generateGarbage modName dir = do-        let fp = modName <> ".hs"-            body = printf "module %s where" modName-        doc <- createDoc fp "haskell" (T.pack body)-        liftIO $ writeFile (dir </> fp) body-        builds <- waitForTypecheck doc-        liftIO $ assertBool "something is wrong with this test" builds-        return doc

− test/exe/HaddockTests.hs

@@ -1,90 +0,0 @@--module HaddockTests (tests) where--import           Development.IDE.Spans.Common--- import Test.QuickCheck.Instances ()-import           Test.Tasty-import           Test.Tasty.HUnit--tests :: TestTree-tests-  = testGroup "haddock"-      [ testCase "Num" $ checkHaddock-          (unlines-             [ "However, '(+)' and '(*)' are"-             , "customarily expected to define a ring and have the following properties:"-             , ""-             , "[__Associativity of (+)__]: @(x + y) + z@ = @x + (y + z)@"-             , "[__Commutativity of (+)__]: @x + y@ = @y + x@"-             , "[__@fromInteger 0@ is the additive identity__]: @x + fromInteger 0@ = @x@"-             ]-          )-          (unlines-             [ ""-             , ""-             , "However,  `(+)`  and  `(*)`  are"-             , "customarily expected to define a ring and have the following properties: "-             , "+ ****Associativity of (+)****: `(x + y) + z`  =  `x + (y + z)`"-             , "+ ****Commutativity of (+)****: `x + y`  =  `y + x`"-             , "+ ****`fromInteger 0`  is the additive identity****: `x + fromInteger 0`  =  `x`"-             ]-          )-      , testCase "unsafePerformIO" $ checkHaddock-          (unlines-             [ "may require"-             , "different precautions:"-             , ""-             , "  * Use @{\\-\\# NOINLINE foo \\#-\\}@ as a pragma on any function @foo@"-             , "        that calls 'unsafePerformIO'.  If the call is inlined,"-             , "        the I\\/O may be performed more than once."-             , ""-             , "  * Use the compiler flag @-fno-cse@ to prevent common sub-expression"-             , "        elimination being performed on the module."-             , ""-             ]-          )-          (unlines-             [ ""-             , ""-             , "may require"-             , "different precautions: "-             , "+ Use  `{-# NOINLINE foo #-}`  as a pragma on any function  `foo` "-             , "  that calls  `unsafePerformIO` .  If the call is inlined,"-             , "  the I/O may be performed more than once."-             , ""-             , "+ Use the compiler flag  `-fno-cse`  to prevent common sub-expression"-             , "  elimination being performed on the module."-             , ""-             ]-          )-      , testCase "ordered list" $ checkHaddock-          (unlines-             [ "may require"-             , "different precautions:"-             , ""-             , "  1. Use @{\\-\\# NOINLINE foo \\#-\\}@ as a pragma on any function @foo@"-             , "        that calls 'unsafePerformIO'.  If the call is inlined,"-             , "        the I\\/O may be performed more than once."-             , ""-             , "  2. Use the compiler flag @-fno-cse@ to prevent common sub-expression"-             , "        elimination being performed on the module."-             , ""-             ]-          )-          (unlines-             [ ""-             , ""-             , "may require"-             , "different precautions: "-             , "1. Use  `{-# NOINLINE foo #-}`  as a pragma on any function  `foo` "-             , "  that calls  `unsafePerformIO` .  If the call is inlined,"-             , "  the I/O may be performed more than once."-             , ""-             , "2. Use the compiler flag  `-fno-cse`  to prevent common sub-expression"-             , "  elimination being performed on the module."-             , ""-             ]-          )-      ]-  where-    checkHaddock s txt = spanDocToMarkdownForTest s @?= txt

− test/exe/HieDbRetry.hs

@@ -1,136 +0,0 @@-{-# LANGUAGE MultiWayIf #-}-module HieDbRetry (tests) where--import           Control.Concurrent.Extra (Var, modifyVar, newVar, readVar,-                                           withVar)-import           Control.Exception        (ErrorCall (ErrorCall), evaluate,-                                           throwIO, tryJust)-import           Control.Monad.IO.Class   (MonadIO (liftIO))-import           Data.Tuple.Extra         (dupe)-import qualified Database.SQLite.Simple   as SQLite-import           Development.IDE.Session  (retryOnException, retryOnSqliteBusy)-import qualified Development.IDE.Session  as Session-import           Ide.Logger               (Recorder (Recorder, logger_),-                                           WithPriority (WithPriority, payload),-                                           cmapWithPrio)-import qualified System.Random            as Random-import           Test.Tasty               (TestTree, testGroup)-import           Test.Tasty.HUnit         (assertFailure, testCase, (@?=))--data Log-  = LogSession Session.Log-  deriving Show--makeLogger :: Var [Log] -> Recorder (WithPriority Log)-makeLogger msgsVar =-  Recorder {-    logger_ = \WithPriority{ payload = msg } -> liftIO $ modifyVar msgsVar (\msgs -> pure (msg : msgs, ()))-  }--rng :: Random.StdGen-rng = Random.mkStdGen 0--retryOnSqliteBusyForTest :: Recorder (WithPriority Log) -> Int -> IO a -> IO a-retryOnSqliteBusyForTest recorder maxRetryCount = retryOnException isErrorBusy (cmapWithPrio LogSession recorder) 1 1 maxRetryCount rng--isErrorBusy :: SQLite.SQLError -> Maybe SQLite.SQLError-isErrorBusy e-  | SQLite.SQLError { sqlError = SQLite.ErrorBusy } <- e = Just e-  | otherwise = Nothing--errorBusy :: SQLite.SQLError-errorBusy = SQLite.SQLError{ sqlError = SQLite.ErrorBusy, sqlErrorDetails = "", sqlErrorContext = "" }--isErrorCall :: ErrorCall -> Maybe ErrorCall-isErrorCall e-  | ErrorCall _ <- e = Just e--tests :: TestTree-tests = testGroup "RetryHieDb"-  [ testCase "retryOnException throws exception after max retries" $ do-      logMsgsVar <- newVar []-      let logger = makeLogger logMsgsVar-      let maxRetryCount = 1--      result <- tryJust isErrorBusy (retryOnSqliteBusyForTest logger maxRetryCount (throwIO errorBusy))--      case result of-        Left exception -> do-          exception @?= errorBusy-          withVar logMsgsVar $ \logMsgs ->-            length logMsgs @?= 2-            -- uncomment if want to compare log msgs-            -- logMsgs @?= []-        Right _ -> assertFailure "Expected ErrorBusy exception"--   , testCase "retryOnException doesn't throw if given function doesn't throw" $ do-      let expected = 1 :: Int-      let maxRetryCount = 0--      actual <- retryOnSqliteBusyForTest mempty maxRetryCount (pure expected)--      actual @?= expected--   , testCase "retryOnException retries the number of times it should" $ do-      countVar <- newVar 0-      let maxRetryCount = 3-      let incrementThenThrow = modifyVar countVar (\count -> pure (dupe (count + 1))) >> throwIO errorBusy--      _ <- tryJust isErrorBusy (retryOnSqliteBusyForTest mempty maxRetryCount incrementThenThrow)--      withVar countVar $ \count ->-        count @?= maxRetryCount + 1--   , testCase "retryOnException doesn't retry if exception is not ErrorBusy" $ do-      countVar <- newVar (0 :: Int)-      let maxRetryCount = 1--      let throwThenIncrement = do-            count <- readVar countVar-            if count == 0 then-              evaluate (error "dummy exception")-            else-              modifyVar countVar (\count -> pure (dupe (count + 1)))---      _ <- tryJust isErrorCall (retryOnSqliteBusyForTest mempty maxRetryCount throwThenIncrement)--      withVar countVar $ \count ->-        count @?= 0--   , testCase "retryOnSqliteBusy retries on ErrorBusy" $ do-      countVar <- newVar (0 :: Int)--      let incrementThenThrowThenIncrement = do-            count <- readVar countVar-            if count == 0 then-              modifyVar countVar (\count -> pure (dupe (count + 1))) >> throwIO errorBusy-            else-              modifyVar countVar (\count -> pure (dupe (count + 1)))--      _ <- retryOnSqliteBusy mempty rng incrementThenThrowThenIncrement--      withVar countVar $ \count ->-        count @?= 2--    , testCase "retryOnException exponentially backs off" $ do-       logMsgsVar <- newVar ([] :: [Log])--       let maxDelay = 100-       let baseDelay = 1-       let maxRetryCount = 6-       let logger = makeLogger logMsgsVar--       result <- tryJust isErrorBusy (retryOnException isErrorBusy (cmapWithPrio LogSession logger) maxDelay baseDelay maxRetryCount rng (throwIO errorBusy))--       case result of-         Left _ -> do-           withVar logMsgsVar $ \logMsgs ->-             -- uses log messages to check backoff...-             if | (LogSession (Session.LogHieDbRetriesExhausted baseDelay maximumDelay maxRetryCount _) : _) <- logMsgs -> do-                  baseDelay @?= 64-                  maximumDelay @?= 100-                  maxRetryCount @?= 0-                | otherwise -> assertFailure "Expected more than 0 log messages"-         Right _ -> assertFailure "Expected ErrorBusy exception"-  ]

− test/exe/HighlightTests.hs

@@ -1,79 +0,0 @@--module HighlightTests (tests) where--import           Control.Monad.IO.Class         (liftIO)-import qualified Data.Text                      as T-import           Development.IDE.GHC.Compat     (GhcVersion (..))-import           Development.IDE.Types.Location-import           Language.LSP.Protocol.Types    hiding-                                                (SemanticTokenAbsolute (..),-                                                 SemanticTokenRelative (..),-                                                 SemanticTokensEdit (..),-                                                 mkRange)-import           Language.LSP.Test-import           Test.Tasty-import           Test.Tasty.HUnit-import           TestUtils--tests :: TestTree-tests = testGroup "highlight"-  [ testSessionWait "value" $ do-    doc <- createDoc "A.hs" "haskell" source-    _ <- waitForDiagnostics-    highlights <- getHighlights doc (Position 3 2)-    liftIO $ highlights @?=-            [ DocumentHighlight (R 2 0 2 3) (Just DocumentHighlightKind_Read)-            , DocumentHighlight (R 3 0 3 3) (Just DocumentHighlightKind_Write)-            , DocumentHighlight (R 4 6 4 9) (Just DocumentHighlightKind_Read)-            , DocumentHighlight (R 5 22 5 25) (Just DocumentHighlightKind_Read)-            ]-  , testSessionWait "type" $ do-    doc <- createDoc "A.hs" "haskell" source-    _ <- waitForDiagnostics-    highlights <- getHighlights doc (Position 2 8)-    liftIO $ highlights @?=-            [ DocumentHighlight (R 2 7 2 10) (Just DocumentHighlightKind_Read)-            , DocumentHighlight (R 3 11 3 14) (Just DocumentHighlightKind_Read)-            ]-  , testSessionWait "local" $ do-    doc <- createDoc "A.hs" "haskell" source-    _ <- waitForDiagnostics-    highlights <- getHighlights doc (Position 6 5)-    liftIO $ highlights @?=-            [ DocumentHighlight (R 6 4 6 7) (Just DocumentHighlightKind_Write)-            , DocumentHighlight (R 6 10 6 13) (Just DocumentHighlightKind_Read)-            , DocumentHighlight (R 7 12 7 15) (Just DocumentHighlightKind_Read)-            ]-  , knownBrokenForGhcVersions [GHC90, GHC92, GHC94, GHC96, GHC98] "Ghc9 highlights the constructor and not just this field" $-        testSessionWait "record" $ do-        doc <- createDoc "A.hs" "haskell" recsource-        _ <- waitForDiagnostics-        highlights <- getHighlights doc (Position 4 15)-        liftIO $ highlights @?=-          [ DocumentHighlight (R 4 8 4 10) (Just DocumentHighlightKind_Write)-          , DocumentHighlight (R 4 14 4 20) (Just DocumentHighlightKind_Read)-          ]-        highlights <- getHighlights doc (Position 3 17)-        liftIO $ highlights @?=-          [ DocumentHighlight (R 3 17 3 23) (Just DocumentHighlightKind_Write)-          , DocumentHighlight (R 4 8 4 10) (Just DocumentHighlightKind_Read)-          ]-  ]-  where-    source = T.unlines-      ["{-# OPTIONS_GHC -Wunused-binds #-}"-      ,"module Highlight () where"-      ,"foo :: Int"-      ,"foo = 3 :: Int"-      ,"bar = foo"-      ,"  where baz = let x = foo in x"-      ,"baz arg = arg + x"-      ,"  where x = arg"-      ]-    recsource = T.unlines-      ["{-# LANGUAGE RecordWildCards #-}"-      ,"{-# OPTIONS_GHC -Wunused-binds #-}"-      ,"module Highlight () where"-      ,"data Rec = Rec { field1 :: Int, field2 :: Char }"-      ,"foo Rec{..} = field2 + field1"-      ]

− test/exe/IfaceTests.hs

@@ -1,163 +0,0 @@--{-# LANGUAGE OverloadedLabels #-}--module IfaceTests (tests) where--import           Control.Monad.IO.Class        (liftIO)-import           Data.Row-import qualified Data.Text                     as T-import           Development.IDE.GHC.Util-import           Development.IDE.Test          (configureCheckProject,-                                                expectDiagnostics,-                                                expectNoMoreDiagnostics,-                                                getInterfaceFilesDir)-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.Tasty-import           Test.Tasty.HUnit-import           TestUtils--tests :: TestTree-tests = testGroup "Interface loading tests"-    [ -- https://github.com/haskell/ghcide/pull/645/-      ifaceErrorTest-    , ifaceErrorTest2-    , ifaceErrorTest3-    , ifaceTHTest-    ]----- | test that TH reevaluates across interfaces-ifaceTHTest :: TestTree-ifaceTHTest = testCase "iface-th-test" $ runWithExtraFiles "TH" $ \dir -> do-    let aPath = dir </> "THA.hs"-        bPath = dir </> "THB.hs"-        cPath = dir </> "THC.hs"--    aSource <- liftIO $ readFileUtf8 aPath -- [TH] a :: ()-    _bSource <- liftIO $ readFileUtf8 bPath -- a :: ()-    cSource <- liftIO $ readFileUtf8 cPath -- c = a :: ()--    cdoc <- createDoc cPath "haskell" cSource--    -- Change [TH]a from () to Bool-    liftIO $ writeFileUTF8 aPath (unlines $ init (lines $ T.unpack aSource) ++ ["th_a = [d| a = False|]"])--    -- Check that the change propagates to C-    changeDoc cdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ cSource]-    expectDiagnostics-      [("THC.hs", [(DiagnosticSeverity_Error, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")])-      ,("THB.hs", [(DiagnosticSeverity_Warning, (4,thDollarIdx), "Top-level binding")])]-    closeDoc cdoc--ifaceErrorTest :: TestTree-ifaceErrorTest = testCase "iface-error-test-1" $ runWithExtraFiles "recomp" $ \dir -> do-    configureCheckProject True-    let bPath = dir </> "B.hs"-        pPath = dir </> "P.hs"--    bSource <- liftIO $ readFileUtf8 bPath -- y :: Int-    pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int--    bdoc <- createDoc bPath "haskell" bSource-    expectDiagnostics-      [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")])] -- So what we know P has been loaded--    -- Change y from Int to B-    changeDoc bdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ T.unlines ["module B where", "y :: Bool", "y = undefined"]]-    -- save so that we can that the error propagates to A-    sendNotification SMethod_TextDocumentDidSave (DidSaveTextDocumentParams bdoc Nothing)---    -- Check that the error propagates to A-    expectDiagnostics-      [("A.hs", [(DiagnosticSeverity_Error, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])]--    -- Check that we wrote the interfaces for B when we saved-    hidir <- getInterfaceFilesDir bdoc-    hi_exists <- liftIO $ doesFileExist $ hidir </> "B.hi"-    liftIO $ assertBool ("Couldn't find B.hi in " ++ hidir) hi_exists--    pdoc <- openDoc pPath "haskell"-    expectDiagnostics-      [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")])-      ]-    changeDoc pdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ pSource <> "\nfoo = y :: Bool" ]-    -- Now in P we have-    -- bar = x :: Int-    -- foo = y :: Bool-    -- HOWEVER, in A...-    -- x = y  :: Int-    -- This is clearly inconsistent, and the expected outcome a bit surprising:-    --   - The diagnostic for A has already been received. Ghcide does not repeat diagnostics-    --   - P is being typechecked with the last successful artifacts for A.-    expectDiagnostics-      [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")])-      ,("P.hs", [(DiagnosticSeverity_Warning,(6,0), "Top-level binding")])-      ]-    expectNoMoreDiagnostics 2--ifaceErrorTest2 :: TestTree-ifaceErrorTest2 = testCase "iface-error-test-2" $ runWithExtraFiles "recomp" $ \dir -> do-    let bPath = dir </> "B.hs"-        pPath = dir </> "P.hs"--    bSource <- liftIO $ readFileUtf8 bPath -- y :: Int-    pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: 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-    changeDoc bdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ T.unlines ["module B where", "y :: Bool", "y = undefined"]]--    -- Add a new definition to P-    changeDoc pdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ pSource <> "\nfoo = y :: Bool" ]-    -- Now in P we have-    -- bar = x :: Int-    -- foo = y :: Bool-    -- HOWEVER, in A...-    -- x = y  :: Int-    expectDiagnostics-    -- As in the other test, P is being typechecked with the last successful artifacts for A-    -- (ot thanks to -fdeferred-type-errors)-      [("A.hs", [(DiagnosticSeverity_Error, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])-      ,("P.hs", [(DiagnosticSeverity_Warning, (4, 0), "Top-level binding")])-      ,("P.hs", [(DiagnosticSeverity_Warning, (6, 0), "Top-level binding")])-      ]--    expectNoMoreDiagnostics 2--ifaceErrorTest3 :: TestTree-ifaceErrorTest3 = testCase "iface-error-test-3" $ runWithExtraFiles "recomp" $ \dir -> do-    let bPath = dir </> "B.hs"-        pPath = dir </> "P.hs"--    bSource <- liftIO $ readFileUtf8 bPath -- y :: Int-    pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int--    bdoc <- createDoc bPath "haskell" bSource--    -- Change y from Int to B-    changeDoc bdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ T.unlines ["module B where", "y :: Bool", "y = undefined"]]--    -- P should not typecheck, as there are no last valid artifacts for A-    _pdoc <- createDoc pPath "haskell" pSource--    -- In this example the interface file for A should not exist (modulo the cache folder)-    -- Despite that P still type checks, as we can generate an interface file for A thanks to -fdeferred-type-errors-    expectDiagnostics-      [("A.hs", [(DiagnosticSeverity_Error, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])-      ,("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")])-      ]-    expectNoMoreDiagnostics 2

− test/exe/InitializeResponseTests.hs

@@ -1,97 +0,0 @@--{-# LANGUAGE DataKinds        #-}-{-# LANGUAGE OverloadedLabels #-}--module InitializeResponseTests (tests) where--import           Control.Monad-import           Data.List.Extra-import           Data.Row-import qualified Data.Text                         as T-import           Development.IDE.Plugin.TypeLenses (typeLensCommandId)-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           Control.Lens                      ((^.))-import           Development.IDE.Plugin.Test       (blockCommandId)-import           Test.Tasty-import           Test.Tasty.HUnit-import           TestUtils--tests :: TestTree-tests = withResource acquire release tests where--  -- these tests document and monitor the evolution of the-  -- capabilities announced by the server in the initialize-  -- response. Currently the server advertises almost no capabilities-  -- at all, in some cases failing to announce capabilities that it-  -- actually does provide! Hopefully this will change ...-  tests :: IO (TResponseMessage Method_Initialize) -> TestTree-  tests getInitializeResponse =-    testGroup "initialize response capabilities"-    [ chk "   text doc sync"             _textDocumentSync  tds-    , chk "   hover"                         _hoverProvider (Just $ InR (HoverOptions (Just False)))-    , chk "   completion"               _completionProvider (Just $ CompletionOptions (Just False) (Just ["."]) Nothing (Just True) Nothing)-    , chk "NO signature help"        _signatureHelpProvider Nothing-    , chk "   goto definition"          _definitionProvider (Just $ InR (DefinitionOptions (Just False)))-    , chk "   goto type definition" _typeDefinitionProvider (Just $ InR (InL (TypeDefinitionOptions (Just False))))-    -- BUG in lsp-test, this test fails, just change the accepted response-    -- for now-    , chk "NO goto implementation"  _implementationProvider Nothing-    , chk "   find references"          _referencesProvider (Just $ InR (ReferenceOptions (Just False)))-    , chk "   doc highlight"     _documentHighlightProvider (Just $ InR (DocumentHighlightOptions (Just False)))-    , chk "   doc symbol"           _documentSymbolProvider (Just $ InR (DocumentSymbolOptions (Just False) Nothing))-    , chk "   workspace symbol"    _workspaceSymbolProvider (Just $ InR (WorkspaceSymbolOptions (Just False) (Just False)))-    , chk "NO code action"             _codeActionProvider  Nothing-    , chk "   code lens"                 _codeLensProvider  (Just $ CodeLensOptions (Just False) (Just True))-    , chk "NO doc formatting"   _documentFormattingProvider Nothing-    , chk "NO doc range formatting"-                           _documentRangeFormattingProvider Nothing-    , chk "NO doc formatting on typing"-                          _documentOnTypeFormattingProvider Nothing-    , chk "NO renaming"                     _renameProvider Nothing-    , chk "NO doc link"               _documentLinkProvider Nothing-    , chk "NO color"                   (^. L.colorProvider) Nothing-    , chk "NO folding range"          _foldingRangeProvider Nothing-    , che "   execute command"      _executeCommandProvider [typeLensCommandId, blockCommandId]-    , chk "   workspace"                   (^. L.workspace) (Just $ #workspaceFolders .== Just WorkspaceFoldersServerCapabilities{_supported = Just True, _changeNotifications = Just ( InR True )}-                                                                 .+ #fileOperations   .== Nothing)-    , chk "NO experimental"             (^. L.experimental) Nothing-    ] where--      tds = Just (InL (TextDocumentSyncOptions-                              { _openClose = Just True-                              , _change    = Just TextDocumentSyncKind_Incremental-                              , _willSave  = Nothing-                              , _willSaveWaitUntil = Nothing-                              , _save = Just (InR $ SaveOptions {_includeText = Nothing})}))--      chk :: (Eq a, Show a) => TestName -> (ServerCapabilities -> a) -> a -> TestTree-      chk title getActual expected =-        testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir--      che :: TestName -> (ServerCapabilities -> Maybe ExecuteCommandOptions) -> [T.Text] -> TestTree-      che title getActual expected = testCase title $ do-        ir <- getInitializeResponse-        ExecuteCommandOptions {_commands = commands} <- case getActual $ innerCaps ir of-          Just eco -> pure eco-          Nothing -> assertFailure "Was expecting Just ExecuteCommandOptions, got Nothing"-        let commandNames = (!! 2) . T.splitOn ":" <$> commands-        zipWithM_ (\e o -> T.isSuffixOf e o @? show (e,o)) (sort expected) (sort commandNames)--  innerCaps :: TResponseMessage Method_Initialize -> ServerCapabilities-  innerCaps (TResponseMessage _ _ (Right (InitializeResult c _))) = c-  innerCaps (TResponseMessage _ _ (Left _)) = error "Initialization error"--  acquire :: IO (TResponseMessage Method_Initialize)-  acquire = run initializeResponse--  release :: TResponseMessage Method_Initialize -> IO ()-  release = mempty-

− test/exe/LogType.hs

@@ -1,21 +0,0 @@-module LogType (Log(..)) where--import qualified Development.IDE.LSP.Notifications as Notifications-import qualified Development.IDE.Main              as IDE-import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide--import           Ide.Logger                        (Pretty (pretty))-import           Language.LSP.VFS                  (VfsLog)--data Log-  = LogGhcIde Ghcide.Log-  | LogIDEMain IDE.Log-  | LogVfs VfsLog-  | LogNotifications Notifications.Log--instance Pretty Log where-  pretty = \case-    LogGhcIde log  -> pretty log-    LogIDEMain log -> pretty log-    LogVfs log     -> pretty log-    LogNotifications log -> pretty log

− test/exe/Main.hs

@@ -1,127 +0,0 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.--- SPDX-License-Identifier: Apache-2.0--{-- NOTE On enforcing determinism--   The tests below use two mechanisms to enforce deterministic LSP sequences:--    1. Progress reporting: waitForProgress(Begin|Done)-    2. Diagnostics: expectDiagnostics--    Either is fine, but diagnostics are generally more reliable.--    Mixing them both in the same test is NOT FINE as it will introduce race-    conditions since multiple interleavings are possible. In other words,-    the sequence of diagnostics and progress reports is not deterministic.-    For example:--    < do something >-    waitForProgressDone-    expectDiagnostics [...]--    - When the diagnostics arrive after the progress done message, as they usually do, the test will pass-    - When the diagnostics arrive before the progress done msg, when on a slow machine occasionally, the test will timeout--    Therefore, avoid mixing both progress reports and diagnostics in the same test- -}----module Main (main) where--- import Test.QuickCheck.Instances ()-import           Data.Function                            ((&))-import           Ide.Logger             (Logger (Logger),-                                                           LoggingColumn (DataColumn, PriorityColumn),-                                                           Pretty (pretty),-                                                           Priority (Debug),-                                                           Recorder (Recorder, logger_),-                                                           WithPriority (WithPriority, priority),-                                                           cfilter,-                                                           cmapWithPrio,-                                                           makeDefaultStderrRecorder)-import           GHC.Stack                                (emptyCallStack)-import qualified HieDbRetry-import           Test.Tasty-import           Test.Tasty.Ingredients.Rerun--import LogType ()-import OpenCloseTest-import InitializeResponseTests-import CompletionTests-import CPPTests-import DiagnosticTests-import CodeLensTests-import OutlineTests-import HighlightTests-import FindDefinitionAndHoverTests-import PluginSimpleTests-import PluginParsedResultTests-import PreprocessorTests-import THTests-import SymlinkTests-import SafeTests-import UnitTests-import HaddockTests-import PositionMappingTests-import WatchedFileTests-import CradleTests-import DependentFileTest-import NonLspCommandLine-import IfaceTests-import BootTests-import RootUriTests-import AsyncTests-import ClientSettingsTests-import ReferenceTests-import GarbageCollectionTests-import ExceptionTests--main :: IO ()-main = do-  docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn])--  let docWithFilteredPriorityRecorder@Recorder{ logger_ } =-        docWithPriorityRecorder-        & cfilter (\WithPriority{ priority } -> priority >= Debug)--  -- exists so old-style logging works. intended to be phased out-  let logger = Logger $ \p m -> logger_ (WithPriority p emptyCallStack (pretty m))--  let recorder = docWithFilteredPriorityRecorder-               & cmapWithPrio pretty--  -- We mess with env vars so run single-threaded.-  defaultMainWithRerun $ testGroup "ghcide"-    [ OpenCloseTest.tests-    , InitializeResponseTests.tests-    , CompletionTests.tests-    , CPPTests.tests-    , DiagnosticTests.tests-    , CodeLensTests.tests-    , OutlineTests.tests-    , HighlightTests.tests-    , FindDefinitionAndHoverTests.tests-    , PluginSimpleTests.tests-    , PluginParsedResultTests.tests-    , PreprocessorTests.tests-    , THTests.tests-    , SymlinkTests.tests-    , SafeTests.tests-    , UnitTests.tests recorder logger-    , HaddockTests.tests-    , PositionMappingTests.tests-    , WatchedFileTests.tests-    , CradleTests.tests-    , DependentFileTest.tests-    , NonLspCommandLine.tests-    , IfaceTests.tests-    , BootTests.tests-    , RootUriTests.tests-    , AsyncTests.tests-    , ClientSettingsTests.tests-    , ReferenceTests.tests-    , GarbageCollectionTests.tests-    , HieDbRetry.tests-    , ExceptionTests.tests recorder logger-    ]

− test/exe/NonLspCommandLine.hs

@@ -1,27 +0,0 @@--module NonLspCommandLine (tests) where--import           Development.IDE.Test.Runfiles-import           System.Environment.Blank      (setEnv)-import           System.Exit                   (ExitCode (ExitSuccess))-import           System.Process.Extra          (CreateProcess (cwd), proc,-                                                readCreateProcessWithExitCode)-import           Test.Tasty-import           Test.Tasty.HUnit-import           TestUtils----- A test to ensure that the command line ghcide workflow stays working-tests :: TestTree-tests = testGroup "ghcide command line"-  [ testCase "works" $ withTempDir $ \dir -> do-        ghcide <- locateGhcideExecutable-        copyTestDataFiles dir "multi"-        let cmd = (proc ghcide ["a/A.hs"]){cwd = Just dir}--        setEnv "HOME" "/homeless-shelter" False--        (ec, _, _) <- readCreateProcessWithExitCode cmd ""--        ec @?= ExitSuccess-  ]

− test/exe/OpenCloseTest.hs

@@ -1,18 +0,0 @@--module OpenCloseTest (tests) where--import           Control.Applicative.Combinators-import           Control.Monad-import           Language.LSP.Protocol.Message-import           Language.LSP.Test--- import Test.QuickCheck.Instances ()-import           Test.Tasty-import           TestUtils--tests :: TestTree-tests = testSession "open close" $ do-    doc <- createDoc "Testing.hs" "haskell" ""-    void (skipManyTill anyMessage $ message SMethod_WindowWorkDoneProgressCreate)-    waitForProgressBegin-    closeDoc doc-    waitForProgressDone

− test/exe/OutlineTests.hs

@@ -1,189 +0,0 @@--module OutlineTests (tests) where--import           Control.Monad.IO.Class      (liftIO)-import qualified Data.Text                   as T-import           Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..),-                                              SemanticTokenRelative (..),-                                              SemanticTokensEdit (..), mkRange)-import           Language.LSP.Test-import           Test.Tasty-import           Test.Tasty.HUnit-import           TestUtils--tests :: TestTree-tests = testGroup-  "outline"-  [ testSessionWait "type class" $ do-    let source = T.unlines ["module A where", "class A a where a :: a -> Bool"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Right-      [ moduleSymbol-          "A"-          (R 0 7 0 8)-          [ classSymbol "A a"-                        (R 1 0 1 30)-                        [docSymbol' "a" SymbolKind_Method (R 1 16 1 30) (R 1 16 1 17)]-          ]-      ]-  , testSessionWait "type class instance " $ do-    let source = T.unlines ["class A a where", "instance A () where"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Right-      [ classSymbol "A a" (R 0 0 0 15) []-      , docSymbol "A ()" SymbolKind_Interface (R 1 0 1 19)-      ]-  , testSessionWait "type family" $ do-    let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Right [docSymbolD "A" "type family" SymbolKind_Function (R 1 0 1 13)]-  , testSessionWait "type family instance " $ do-    let source = T.unlines-          [ "{-# language TypeFamilies #-}"-          , "type family A a"-          , "type instance A () = ()"-          ]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Right-      [ docSymbolD "A a"   "type family" SymbolKind_Function     (R 1 0 1 15)-      , docSymbol "A ()" SymbolKind_Interface (R 2 0 2 23)-      ]-  , testSessionWait "data family" $ do-    let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Right [docSymbolD "A" "data family" SymbolKind_Function (R 1 0 1 11)]-  , testSessionWait "data family instance " $ do-    let source = T.unlines-          [ "{-# language TypeFamilies #-}"-          , "data family A a"-          , "data instance A () = A ()"-          ]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Right-      [ docSymbolD "A a"   "data family" SymbolKind_Function     (R 1 0 1 11)-      , docSymbol "A ()" SymbolKind_Interface (R 2 0 2 25)-      ]-  , testSessionWait "constant" $ do-    let source = T.unlines ["a = ()"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Right-      [docSymbol "a" SymbolKind_Function (R 0 0 0 6)]-  , testSessionWait "pattern" $ do-    let source = T.unlines ["Just foo = Just 21"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Right-      [docSymbol "Just foo" SymbolKind_Function (R 0 0 0 18)]-  , testSessionWait "pattern with type signature" $ do-    let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Right-      [docSymbol "a :: ()" SymbolKind_Function (R 1 0 1 12)]-  , testSessionWait "function" $ do-    let source = T.unlines ["a _x = ()"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Right [docSymbol "a" SymbolKind_Function (R 0 0 0 9)]-  , testSessionWait "type synonym" $ do-    let source = T.unlines ["type A = Bool"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Right-      [docSymbol' "A" SymbolKind_TypeParameter (R 0 0 0 13) (R 0 5 0 6)]-  , testSessionWait "datatype" $ do-    let source = T.unlines ["data A = C"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Right-      [ docSymbolWithChildren "A"-                              SymbolKind_Struct-                              (R 0 0 0 10)-                              [docSymbol "C" SymbolKind_Constructor (R 0 9 0 10)]-      ]-  , testSessionWait "record fields" $ do-    let source = T.unlines ["data A = B {", "  x :: Int", "  , y :: Int}"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Right-      [ docSymbolWithChildren "A" SymbolKind_Struct (R 0 0 2 13)-          [ docSymbolWithChildren' "B" SymbolKind_Constructor (R 0 9 2 13) (R 0 9 0 10)-            [ docSymbol "x" SymbolKind_Field (R 1 2 1 3)-            , docSymbol "y" SymbolKind_Field (R 2 4 2 5)-            ]-          ]-      ]-  , testSessionWait "import" $ do-    let source = T.unlines ["import Data.Maybe ()"]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Right-      [docSymbolWithChildren "imports"-                             SymbolKind_Module-                             (R 0 0 0 20)-                             [ docSymbol "import Data.Maybe" SymbolKind_Module (R 0 0 0 20)-                             ]-      ]-  , testSessionWait "multiple import" $ do-    let source = T.unlines ["", "import Data.Maybe ()", "", "import Control.Exception ()", ""]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Right-      [docSymbolWithChildren "imports"-                             SymbolKind_Module-                             (R 1 0 3 27)-                             [ docSymbol "import Data.Maybe" SymbolKind_Module (R 1 0 1 20)-                             , docSymbol "import Control.Exception" SymbolKind_Module (R 3 0 3 27)-                             ]-      ]-  , testSessionWait "foreign import" $ do-    let source = T.unlines-          [ "{-# language ForeignFunctionInterface #-}"-          , "foreign import ccall \"a\" a :: Int"-          ]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Right [docSymbolD "a" "import" SymbolKind_Object (R 1 0 1 33)]-  , testSessionWait "foreign export" $ do-    let source = T.unlines-          [ "{-# language ForeignFunctionInterface #-}"-          , "foreign export ccall odd :: Int -> Bool"-          ]-    docId   <- createDoc "A.hs" "haskell" source-    symbols <- getDocumentSymbols docId-    liftIO $ symbols @?= Right [docSymbolD "odd" "export" SymbolKind_Object (R 1 0 1 39)]-  ]- where-  docSymbol name kind loc =-    DocumentSymbol name Nothing kind Nothing Nothing loc loc Nothing-  docSymbol' name kind loc selectionLoc =-    DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc Nothing-  docSymbolD name detail kind loc =-    DocumentSymbol name (Just detail) kind Nothing Nothing loc loc Nothing-  docSymbolWithChildren name kind loc cc =-    DocumentSymbol name Nothing kind Nothing Nothing loc loc (Just cc)-  docSymbolWithChildren' name kind loc selectionLoc cc =-    DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc (Just cc)-  moduleSymbol name loc cc = DocumentSymbol name-                                            Nothing-                                            SymbolKind_File-                                            Nothing-                                            Nothing-                                            (R 0 0 maxBound 0)-                                            loc-                                            (Just cc)-  classSymbol name loc cc = DocumentSymbol name-                                           (Just "class")-                                           SymbolKind_Interface-                                           Nothing-                                           Nothing-                                           loc-                                           loc-                                           (Just cc)

− test/exe/PluginParsedResultTests.hs

@@ -1,16 +0,0 @@--module PluginParsedResultTests (tests) where--import           Development.IDE.Test (expectNoMoreDiagnostics)-import           Language.LSP.Test-import           System.FilePath--- import Test.QuickCheck.Instances ()-import           Test.Tasty-import           TestUtils--tests :: TestTree-tests =-  ignoreForGHC92Plus "No need for this plugin anymore!" $-  testSessionWithExtraFiles "plugin-recorddot" "parsedResultAction plugin" $ \dir -> do-    _ <- openDoc (dir</> "RecordDot.hs") "haskell"-    expectNoMoreDiagnostics 2

− test/exe/PluginSimpleTests.hs

@@ -1,50 +0,0 @@--module PluginSimpleTests (tests) where--import           Control.Monad.IO.Class      (liftIO)-import           Development.IDE.GHC.Compat  (GhcVersion (..))-import           Development.IDE.Test        (expectDiagnostics)-import           Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..),-                                              SemanticTokenRelative (..),-                                              SemanticTokensEdit (..), mkRange)-import           Language.LSP.Test-import           System.FilePath--- import Test.QuickCheck.Instances ()-import           Test.Tasty-import           TestUtils--tests :: TestTree-tests =-  -- Build profile: -w ghc-9.4.2 -O1-  -- In order, the following will be built (use -v for more details):-  -- - ghc-typelits-natnormalise-0.7.7 (lib) (requires build)-  -- - ghc-typelits-knownnat-0.7.7 (lib) (requires build)-  -- - plugin-1.0.0 (lib) (first run)-  -- Starting     ghc-typelits-natnormalise-0.7.7 (lib)-  -- Building     ghc-typelits-natnormalise-0.7.7 (lib)--  -- Failed to build ghc-typelits-natnormalise-0.7.7.-  -- Build log (-  -- C:\cabal\logs\ghc-9.4.2\ghc-typelits-_-0.7.7-3f036a52a0d9bfc3389d1852a87da2e87c6de2e4.log-  -- ):-  -- Preprocessing library for ghc-typelits-natnormalise-0.7.7..-  -- Building library for ghc-typelits-natnormalise-0.7.7..-  -- [1 of 3] Compiling GHC.TypeLits.Normalise.SOP ( src\GHC\TypeLits\Normalise\SOP.hs, dist\build\GHC\TypeLits\Normalise\SOP.o )-  -- [2 of 3] Compiling GHC.TypeLits.Normalise.Unify ( src\GHC\TypeLits\Normalise\Unify.hs, dist\build\GHC\TypeLits\Normalise\Unify.o )-  -- [3 of 3] Compiling GHC.TypeLits.Normalise ( src-ghc-9.4\GHC\TypeLits\Normalise.hs, dist\build\GHC\TypeLits\Normalise.o )-  -- C:\tools\ghc-9.4.2\lib\../mingw/bin/llvm-ar.exe: error: dist\build\objs-5156\libHSghc-typelits-_-0.7.7-3f036a52a0d9bfc3389d1852a87da2e87c6de2e4.a: No such file or directory--  -- Error: cabal: Failed to build ghc-typelits-natnormalise-0.7.7 (which is-  -- required by plugin-1.0.0). See the build log above for details.-  ignoreFor (BrokenForGHC [GHC96, GHC98]) "fragile, frequently times out" $-  ignoreFor (BrokenSpecific Windows [GHC94]) "ghc-typelist-natnormalise fails to build on GHC 9.4.2 for windows only" $-  testSessionWithExtraFiles "plugin-knownnat" "simple plugin" $ \dir -> do-    _ <- openDoc (dir </> "KnownNat.hs") "haskell"-    liftIO $ writeFile (dir</>"hie.yaml")-      "cradle: {cabal: [{path: '.', component: 'lib:plugin'}]}"--    expectDiagnostics-      [ ( "KnownNat.hs",-          [(DiagnosticSeverity_Error, (9, 15), "Variable not in scope: c")]-          )-      ]

− test/exe/PositionMappingTests.hs

@@ -1,222 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE OverloadedLabels    #-}--module PositionMappingTests (tests) where--import qualified Data.EnumMap.Strict                  as EM-import           Data.Row-import qualified Data.Text                            as T-import           Data.Text.Utf16.Rope.Mixed           (Rope)-import qualified Data.Text.Utf16.Rope.Mixed           as Rope-import           Development.IDE.Core.PositionMapping (PositionResult (..),-                                                       fromCurrent,-                                                       positionResultToMaybe,-                                                       toCurrent,-                                                       toCurrentPosition)-import           Development.IDE.Types.Location-import           Language.LSP.Protocol.Types          hiding-                                                      (SemanticTokenAbsolute (..),-                                                       SemanticTokenRelative (..),-                                                       SemanticTokensEdit (..),-                                                       mkRange)-import           Language.LSP.VFS                     (applyChange)-import           Test.QuickCheck--- import Test.QuickCheck.Instances ()-import           Control.Arrow                        (second)-import           Data.Functor.Identity                (runIdentity)-import           Data.Text                            (Text)-import           Development.IDE.Core.Shake           (updatePositionMappingHelper)-import           Test.Tasty-import           Test.Tasty.HUnit-import           Test.Tasty.QuickCheck--enumMapMappingTest :: TestTree-enumMapMappingTest = testCase "enumMapMappingTest" $ do-  let mkChangeEvent :: Range -> Text -> TextDocumentContentChangeEvent-      mkChangeEvent r t = TextDocumentContentChangeEvent $ InL $ #range .== r .+ #rangeLength .== Nothing .+ #text .== t-      mkCE :: UInt -> UInt -> UInt -> UInt -> Text -> TextDocumentContentChangeEvent-      mkCE l1 c1 l2 c2 = mkChangeEvent (Range (Position l1 c1) (Position l2 c2))-      events :: [(Int32, [TextDocumentContentChangeEvent])]-      events = map (second return) [(0, mkCE 0 0 0 0 ""), (1, mkCE 0 1 0 1 " "), (2, mkCE 0 2 0 2 " "), (3, mkCE 0 3 0 3 " "), (4, mkCE 0 4 0 4 " "), (5, mkCE 0 5 0 5 " ")]-      finalMap = Prelude.foldl (\m (i, e) -> updatePositionMappingHelper i e m) mempty events-  let updatePose fromPos = do-        mapping <- snd <$> EM.lookup 0 finalMap-        toCurrentPosition mapping fromPos-  updatePose (Position 0 4) @?= Just (Position 0 9)-  updatePose (Position 0 5) @?= Just (Position 0 10)---tests ::  TestTree-tests =-    testGroup "position mapping"-        [-        enumMapMappingTest-        , testGroup "toCurrent"-              [ testCase "before" $-                toCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "ab"-                    (Position 0 0) @?= PositionExact (Position 0 0)-              , testCase "after, same line, same length" $-                toCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "ab"-                    (Position 0 3) @?= PositionExact (Position 0 3)-              , testCase "after, same line, increased length" $-                toCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "abc"-                    (Position 0 3) @?= PositionExact (Position 0 4)-              , testCase "after, same line, decreased length" $-                toCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "a"-                    (Position 0 3) @?= PositionExact (Position 0 2)-              , testCase "after, next line, no newline" $-                toCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "abc"-                    (Position 1 3) @?= PositionExact (Position 1 3)-              , testCase "after, next line, newline" $-                toCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "abc\ndef"-                    (Position 1 0) @?= PositionExact (Position 2 0)-              , testCase "after, same line, newline" $-                toCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "abc\nd"-                    (Position 0 4) @?= PositionExact (Position 1 2)-              , testCase "after, same line, newline + newline at end" $-                toCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "abc\nd\n"-                    (Position 0 4) @?= PositionExact (Position 2 1)-              , testCase "after, same line, newline + newline at end" $-                toCurrent-                    (Range (Position 0 1) (Position 0 1))-                    "abc"-                    (Position 0 1) @?= PositionExact (Position 0 4)-              ]-        , testGroup "fromCurrent"-              [ testCase "before" $-                fromCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "ab"-                    (Position 0 0) @?= PositionExact (Position 0 0)-              , testCase "after, same line, same length" $-                fromCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "ab"-                    (Position 0 3) @?= PositionExact (Position 0 3)-              , testCase "after, same line, increased length" $-                fromCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "abc"-                    (Position 0 4) @?= PositionExact (Position 0 3)-              , testCase "after, same line, decreased length" $-                fromCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "a"-                    (Position 0 2) @?= PositionExact (Position 0 3)-              , testCase "after, next line, no newline" $-                fromCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "abc"-                    (Position 1 3) @?= PositionExact (Position 1 3)-              , testCase "after, next line, newline" $-                fromCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "abc\ndef"-                    (Position 2 0) @?= PositionExact (Position 1 0)-              , testCase "after, same line, newline" $-                fromCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "abc\nd"-                    (Position 1 2) @?= PositionExact (Position 0 4)-              , testCase "after, same line, newline + newline at end" $-                fromCurrent-                    (Range (Position 0 1) (Position 0 3))-                    "abc\nd\n"-                    (Position 2 1) @?= PositionExact (Position 0 4)-              , testCase "after, same line, newline + newline at end" $-                fromCurrent-                    (Range (Position 0 1) (Position 0 1))-                    "abc"-                    (Position 0 4) @?= PositionExact (Position 0 1)-              ]-        , adjustOption (\(QuickCheckTests i) -> QuickCheckTests (max 1000 i)) $ testGroup "properties"-              [ testProperty "fromCurrent r t <=< toCurrent r t" $ do-                -- Note that it is important to use suchThatMap on all values at once-                -- instead of only using it on the position. Otherwise you can get-                -- into situations where there is no position that can be mapped back-                -- for the edit which will result in QuickCheck looping forever.-                let gen = do-                        rope <- genRope-                        range <- genRange rope-                        PrintableText replacement <- arbitrary-                        oldPos <- genPosition rope-                        pure (range, replacement, oldPos)-                forAll-                    (suchThatMap gen-                        (\(range, replacement, oldPos) -> positionResultToMaybe $ (range, replacement, oldPos,) <$> toCurrent range replacement oldPos)) $-                    \(range, replacement, oldPos, newPos) ->-                    fromCurrent range replacement newPos === PositionExact oldPos-              , testProperty "toCurrent r t <=< fromCurrent r t" $ do-                let gen = do-                        rope <- genRope-                        range <- genRange rope-                        PrintableText replacement <- arbitrary-                        let newRope = runIdentity $ applyChange mempty rope-                                (TextDocumentContentChangeEvent $ InL $ #range .== range-                                                                     .+ #rangeLength .== Nothing-                                                                     .+ #text .== replacement)-                        newPos <- genPosition newRope-                        pure (range, replacement, newPos)-                forAll-                    (suchThatMap gen-                        (\(range, replacement, newPos) -> positionResultToMaybe $ (range, replacement, newPos,) <$> fromCurrent range replacement newPos)) $-                    \(range, replacement, newPos, oldPos) ->-                    toCurrent range replacement oldPos === PositionExact newPos-              ]-        ]--newtype PrintableText = PrintableText { getPrintableText :: T.Text }-    deriving Show--instance Arbitrary PrintableText where-    arbitrary = PrintableText . T.pack . getPrintableString <$> arbitrary--genRope :: Gen Rope-genRope = Rope.fromText . getPrintableText <$> arbitrary--genPosition :: Rope -> Gen Position-genPosition r = do-    let rows :: Int = fromIntegral $ Rope.lengthInLines r-    row <- choose (0, max 0 $ rows - 1) `suchThat` inBounds @UInt-    let columns = T.length (nthLine (fromIntegral row) r)-    column <- choose (0, max 0 $ columns - 1) `suchThat` inBounds @UInt-    pure $ Position (fromIntegral row) (fromIntegral column)--genRange :: Rope -> Gen Range-genRange r = do-    let rows :: Int = fromIntegral $ Rope.lengthInLines r-    startPos@(Position startLine startColumn) <- genPosition r-    let maxLineDiff = max 0 $ rows - 1 - fromIntegral startLine-    endLine <- choose (fromIntegral startLine, fromIntegral startLine + maxLineDiff) `suchThat` inBounds @UInt-    let columns = T.length (nthLine (fromIntegral endLine) r)-    endColumn <--        if fromIntegral startLine == endLine-            then choose (fromIntegral startColumn, columns)-            else choose (0, max 0 $ columns - 1)-        `suchThat` inBounds @UInt-    pure $ Range startPos (Position (fromIntegral endLine) (fromIntegral endColumn))--inBounds :: forall b a . (Integral a, Integral b, Bounded b) => a -> Bool-inBounds a = let i = toInteger a in i <= toInteger (maxBound @b) && i >= toInteger (minBound @b)---- | Get the ith line of a rope, starting from 0. Trailing newline not included.-nthLine :: Int -> Rope -> T.Text-nthLine i r-    | Rope.null r = ""-    | otherwise = Rope.lines r !! i

− test/exe/PreprocessorTests.hs

@@ -1,27 +0,0 @@--module PreprocessorTests (tests) where--import qualified Data.Text                   as T-import           Development.IDE.Test        (expectDiagnostics)-import           Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..),-                                              SemanticTokenRelative (..),-                                              SemanticTokensEdit (..), mkRange)-import           Language.LSP.Test--- import Test.QuickCheck.Instances ()-import           Test.Tasty-import           TestUtils--tests :: TestTree-tests = testSessionWait "preprocessor" $ do-  let content =-        T.unlines-          [ "{-# OPTIONS_GHC -F -pgmF=ghcide-test-preprocessor #-}"-          , "module Testing where"-          , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic-          ]-  _ <- createDoc "Testing.hs" "haskell" content-  expectDiagnostics-    [ ( "Testing.hs",-        [(DiagnosticSeverity_Error, (2, 8), "Variable not in scope: z")]-      )-    ]

− test/exe/Progress.hs

@@ -1,60 +0,0 @@-{-# LANGUAGE PackageImports #-}-module Progress (tests) where--import           Control.Concurrent.STM-import           Data.Foldable                          (for_)-import qualified Data.HashMap.Strict                    as Map-import           Development.IDE                        (NormalizedFilePath)-import           Development.IDE.Core.ProgressReporting-import qualified "list-t" ListT-import qualified StmContainers.Map                      as STM-import           Test.Tasty-import           Test.Tasty.HUnit--tests :: TestTree-tests = testGroup "Progress"-    [ reportProgressTests-    ]--data InProgressModel = InProgressModel {-    done, todo :: Int,-    current    :: Map.HashMap NormalizedFilePath Int-}--reportProgressTests :: TestTree-reportProgressTests = testGroup "recordProgress"-    [ test "addNew"   addNew-    , test "increase" increase-    , test "decrease" decrease-    , test "done" done-    ]-    where-        p0 = pure $ InProgressModel 0 0 mempty-        addNew = recordProgressModel "A" succ p0-        increase = recordProgressModel "A" succ addNew-        decrease = recordProgressModel "A" succ increase-        done = recordProgressModel "A" pred decrease-        recordProgressModel key change state =-            model state $ \st -> recordProgress st key change-        model stateModelIO k = do-            state <- fromModel =<< stateModelIO-            _ <- k state-            toModel state-        test name p = testCase name $ do-            InProgressModel{..} <- p-            (done, todo) @?= (length (filter (==0) (Map.elems current)), Map.size current)--fromModel :: InProgressModel -> IO InProgressState-fromModel InProgressModel{..} = do-    doneVar <- newTVarIO done-    todoVar <- newTVarIO todo-    currentVar <- STM.newIO-    atomically $ for_ (Map.toList current) $ \(k,v) -> STM.insert v k currentVar-    return InProgressState{..}--toModel :: InProgressState -> IO InProgressModel-toModel InProgressState{..} = atomically $ do-    done <- readTVar doneVar-    todo <- readTVar todoVar-    current <- Map.fromList <$> ListT.toList (STM.listT currentVar)-    return InProgressModel{..}

− test/exe/ReferenceTests.hs

@@ -1,199 +0,0 @@--module ReferenceTests (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 qualified Data.Set                        as Set-import           Development.IDE.Test            (configureCheckProject,-                                                  referenceReady)-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.Directory-import           System.FilePath--- import Test.QuickCheck.Instances ()-import           Control.Lens                    ((^.))-import           Data.Tuple.Extra-import           Test.Tasty-import           Test.Tasty.ExpectedFailure-import           Test.Tasty.HUnit-import           TestUtils---tests :: TestTree-tests = testGroup "references"-    [ testGroup "can get references to FOIs"-          [ referenceTest "can get references to symbols"-                          ("References.hs", 4, 7)-                          YesIncludeDeclaration-                          [ ("References.hs", 4, 6)-                          , ("References.hs", 6, 0)-                          , ("References.hs", 6, 14)-                          , ("References.hs", 9, 7)-                          , ("References.hs", 10, 11)-                          ]--          , referenceTest "can get references to data constructor"-                          ("References.hs", 13, 2)-                          YesIncludeDeclaration-                          [ ("References.hs", 13, 2)-                          , ("References.hs", 16, 14)-                          , ("References.hs", 19, 21)-                          ]--          , referenceTest "getting references works in the other module"-                          ("OtherModule.hs", 6, 0)-                          YesIncludeDeclaration-                          [ ("OtherModule.hs", 6, 0)-                          , ("OtherModule.hs", 8, 16)-                          ]--          , referenceTest "getting references works in the Main module"-                          ("Main.hs", 9, 0)-                          YesIncludeDeclaration-                          [ ("Main.hs", 9, 0)-                          , ("Main.hs", 10, 4)-                          ]--          , referenceTest "getting references to main works"-                          ("Main.hs", 5, 0)-                          YesIncludeDeclaration-                          [ ("Main.hs", 4, 0)-                          , ("Main.hs", 5, 0)-                          ]--          , referenceTest "can get type references"-                          ("Main.hs", 9, 9)-                          YesIncludeDeclaration-                          [ ("Main.hs", 9, 0)-                          , ("Main.hs", 9, 9)-                          , ("Main.hs", 10, 0)-                          ]--          , expectFailBecause "references provider does not respect includeDeclaration parameter" $- referenceTest "works when we ask to exclude declarations"-                          ("References.hs", 4, 7)-                          NoExcludeDeclaration-                          [ ("References.hs", 6, 0)-                          , ("References.hs", 6, 14)-                          , ("References.hs", 9, 7)-                          , ("References.hs", 10, 11)-                          ]--          , referenceTest "INCORRECTLY returns declarations when we ask to exclude them"-                          ("References.hs", 4, 7)-                          NoExcludeDeclaration-                          [ ("References.hs", 4, 6)-                          , ("References.hs", 6, 0)-                          , ("References.hs", 6, 14)-                          , ("References.hs", 9, 7)-                          , ("References.hs", 10, 11)-                          ]-          ]--    , testGroup "can get references to non FOIs"-          [ referenceTest "can get references to symbol defined in a module we import"-                          ("References.hs", 22, 4)-                          YesIncludeDeclaration-                          [ ("References.hs", 22, 4)-                          , ("OtherModule.hs", 0, 20)-                          , ("OtherModule.hs", 4, 0)-                          ]--          , referenceTest "can get references in modules that import us to symbols we define"-                          ("OtherModule.hs", 4, 0)-                          YesIncludeDeclaration-                          [ ("References.hs", 22, 4)-                          , ("OtherModule.hs", 0, 20)-                          , ("OtherModule.hs", 4, 0)-                          ]--          , referenceTest "can get references to symbol defined in a module we import transitively"-                          ("References.hs", 24, 4)-                          YesIncludeDeclaration-                          [ ("References.hs", 24, 4)-                          , ("OtherModule.hs", 0, 48)-                          , ("OtherOtherModule.hs", 2, 0)-                          ]--          , referenceTest "can get references in modules that import us transitively to symbols we define"-                          ("OtherOtherModule.hs", 2, 0)-                          YesIncludeDeclaration-                          [ ("References.hs", 24, 4)-                          , ("OtherModule.hs", 0, 48)-                          , ("OtherOtherModule.hs", 2, 0)-                          ]--          , referenceTest "can get type references to other modules"-                          ("Main.hs", 12, 10)-                          YesIncludeDeclaration-                          [ ("Main.hs", 12, 7)-                          , ("Main.hs", 13, 0)-                          , ("References.hs", 12, 5)-                          , ("References.hs", 16, 0)-                          ]-          ]-    ]---- | When we ask for all references to symbol "foo", should the declaration "foo--- = 2" be among the references returned?-data IncludeDeclaration =-    YesIncludeDeclaration-    | NoExcludeDeclaration--getReferences' :: SymbolLocation -> IncludeDeclaration -> Session ([Location])-getReferences' (file, l, c) includeDeclaration = do-    doc <- openDoc file "haskell"-    getReferences doc (Position l c) $ toBool includeDeclaration-    where toBool YesIncludeDeclaration = True-          toBool NoExcludeDeclaration  = False--referenceTestSession :: String -> FilePath -> [FilePath] -> (FilePath -> Session ()) -> TestTree-referenceTestSession name thisDoc docs' f = testSessionWithExtraFiles "references" name $ \dir -> do-  -- needed to build whole project indexing-  configureCheckProject True-  let docs = map (dir </>) $ delete thisDoc $ nubOrd docs'-  -- Initial Index-  docid <- openDoc thisDoc "haskell"-  let-    loop :: [FilePath] -> Session ()-    loop [] = pure ()-    loop docs = do-      doc <- skipManyTill anyMessage $ referenceReady (`elem` docs)-      loop (delete doc docs)-  loop docs-  f dir-  closeDoc docid---- | Given a location, lookup the symbol and all references to it. Make sure--- they are the ones we expect.-referenceTest :: String -> SymbolLocation -> IncludeDeclaration -> [SymbolLocation] -> TestTree-referenceTest name loc includeDeclaration expected =-    referenceTestSession name (fst3 loc) docs $ \dir -> do-        actual <- getReferences' loc includeDeclaration-        liftIO $ actual `expectSameLocations` map (first3 (dir </>)) expected-  where-    docs = map fst3 expected--type SymbolLocation = (FilePath, UInt, UInt)--expectSameLocations :: [Location] -> [SymbolLocation] -> Assertion-expectSameLocations actual expected = do-    let actual' =-            Set.map (\location -> (location ^. L.uri-                                   , location ^. L.range . L.start . L.line . Lens.to fromIntegral-                                   , location ^. L.range . L.start . L.character . Lens.to fromIntegral))-            $ Set.fromList actual-    expected' <- Set.fromList <$>-        (forM expected $ \(file, l, c) -> do-                              fp <- canonicalizePath file-                              return (filePathToUri fp, l, c))-    actual' @?= expected'

− test/exe/RootUriTests.hs

@@ -1,26 +0,0 @@--module RootUriTests (tests) where--import           Control.Monad.IO.Class   (liftIO)-import           Development.IDE.GHC.Util-import           Development.IDE.Test     (expectNoMoreDiagnostics)-import           Language.LSP.Test-import           System.FilePath--- import Test.QuickCheck.Instances ()-import           Test.Tasty-import           Test.Tasty.HUnit-import           TestUtils----- | checks if we use InitializeParams.rootUri for loading session-tests :: TestTree-tests = testCase "use rootUri" . runTest "dirA" "dirB" $ \dir -> do-  let bPath = dir </> "dirB/Foo.hs"-  liftIO $ copyTestDataFiles dir "rootUri"-  bSource <- liftIO $ readFileUtf8 bPath-  _ <- createDoc "Foo.hs" "haskell" bSource-  expectNoMoreDiagnostics 0.5-  where-    -- similar to run' except we can configure where to start ghcide and session-    runTest :: FilePath -> FilePath -> (FilePath -> Session ()) -> IO ()-    runTest dir1 dir2 s = withTempDir $ \dir -> runInDir' dir dir1 dir2 [] (s dir)

− test/exe/SafeTests.hs

@@ -1,38 +0,0 @@--module SafeTests (tests) where--import qualified Data.Text            as T-import           Development.IDE.Test (expectNoMoreDiagnostics)-import           Language.LSP.Test--import           Test.Tasty-import           TestUtils--tests :: TestTree-tests =-  testGroup-    "SafeHaskell"-    [ -- Test for https://github.com/haskell/ghcide/issues/424-      testSessionWait "load" $ do-        let sourceA =-              T.unlines-                ["{-# LANGUAGE Trustworthy #-}"-                ,"module A where"-                ,"import System.IO.Unsafe"-                ,"import System.IO ()"-                ,"trustWorthyId :: a -> a"-                ,"trustWorthyId i = unsafePerformIO $ do"-                ,"  putStrLn \"I'm safe\""-                ,"  return i"]-            sourceB =-              T.unlines-                ["{-# LANGUAGE Safe #-}"-                ,"module B where"-                ,"import A"-                ,"safeId :: a -> a"-                ,"safeId = trustWorthyId"-                ]--        _ <- createDoc "A.hs" "haskell" sourceA-        _ <- createDoc "B.hs" "haskell" sourceB-        expectNoMoreDiagnostics 1 ]

− test/exe/SymlinkTests.hs

@@ -1,27 +0,0 @@--module SymlinkTests (tests) where--import           Control.Monad.IO.Class      (liftIO)-import           Development.IDE.Test        (expectDiagnosticsWithTags)-import           Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..),-                                              SemanticTokenRelative (..),-                                              SemanticTokensEdit (..), mkRange)-import           Language.LSP.Test-import           System.Directory-import           System.FilePath--import           Test.Tasty-import           Test.Tasty.HUnit-import           TestUtils---- | Tests for projects that use symbolic links one way or another-tests :: TestTree-tests =-  testGroup "Projects using Symlinks"-    [ testCase "Module is symlinked" $ runWithExtraFiles "symlink" $ \dir -> do-        liftIO $ createFileLink (dir </> "some_loc" </> "Sym.hs") (dir </> "other_loc" </> "Sym.hs")-        let fooPath = dir </> "src" </> "Foo.hs"-        _ <- openDoc fooPath "haskell"-        expectDiagnosticsWithTags  [("src" </> "Foo.hs", [(DiagnosticSeverity_Warning, (2, 0), "The import of 'Sym' is redundant", Just DiagnosticTag_Unnecessary)])]-        pure ()-    ]

− test/exe/THTests.hs

@@ -1,194 +0,0 @@--{-# LANGUAGE OverloadedLabels #-}--module THTests (tests) where--import           Control.Monad.IO.Class      (liftIO)-import           Data.Row-import qualified Data.Text                   as T-import           Development.IDE.GHC.Util-import           Development.IDE.Test        (expectCurrentDiagnostics,-                                              expectDiagnostics,-                                              expectNoMoreDiagnostics)-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-    "TemplateHaskell"-    [ -- Test for https://github.com/haskell/ghcide/pull/212-      testSessionWait "load" $ do-        let sourceA =-              T.unlines-                [ "{-# LANGUAGE PackageImports #-}",-                  "{-# LANGUAGE TemplateHaskell #-}",-                  "module A where",-                  "import \"template-haskell\" Language.Haskell.TH",-                  "a :: Integer",-                  "a = $(litE $ IntegerL 3)"-                ]-            sourceB =-              T.unlines-                [ "{-# LANGUAGE PackageImports #-}",-                  "{-# LANGUAGE TemplateHaskell #-}",-                  "module B where",-                  "import A",-                  "import \"template-haskell\" Language.Haskell.TH",-                  "b :: Integer",-                  "b = $(litE $ IntegerL $ a) + n"-                ]-        _ <- createDoc "A.hs" "haskell" sourceA-        _ <- createDoc "B.hs" "haskell" sourceB-        expectDiagnostics [ ( "B.hs", [(DiagnosticSeverity_Error, (6, 29), "Variable not in scope: n")] ) ]-    , testSessionWait "newtype-closure" $ do-        let sourceA =-              T.unlines-                [ "{-# LANGUAGE DeriveDataTypeable #-}"-                  ,"{-# LANGUAGE TemplateHaskell #-}"-                  ,"module A (a) where"-                  ,"import Data.Data"-                  ,"import Language.Haskell.TH"-                  ,"newtype A = A () deriving (Data)"-                  ,"a :: ExpQ"-                  ,"a = [| 0 |]"]-        let sourceB =-              T.unlines-                [ "{-# LANGUAGE TemplateHaskell #-}"-                ,"module B where"-                ,"import A"-                ,"b :: Int"-                ,"b = $( a )" ]-        _ <- createDoc "A.hs" "haskell" sourceA-        _ <- createDoc "B.hs" "haskell" sourceB-        return ()-    , thReloadingTest False-    , thLoadingTest-    , thCoreTest-    , ignoreInWindowsBecause "Broken in windows" $ thReloadingTest True-    -- Regression test for https://github.com/haskell/haskell-language-server/issues/891-    , thLinkingTest False-    , ignoreInWindowsBecause "Broken in windows" $ thLinkingTest True-    , testSessionWait "findsTHIdentifiers" $ do-        let sourceA =-              T.unlines-                [ "{-# LANGUAGE TemplateHaskell #-}"-                , "module A (a) where"-                , "import Language.Haskell.TH (ExpQ)"-                , "a :: ExpQ" -- TH 2.17 requires an explicit type signature since splices are polymorphic-                , "a = [| glorifiedID |]"-                , "glorifiedID :: a -> a"-                , "glorifiedID = id" ]-        let sourceB =-              T.unlines-                [ "{-# OPTIONS_GHC -Wall #-}"-                , "{-# LANGUAGE TemplateHaskell #-}"-                , "module B where"-                , "import A"-                , "main = $a (putStrLn \"success!\")"]-        _ <- createDoc "A.hs" "haskell" sourceA-        _ <- createDoc "B.hs" "haskell" sourceB-        expectDiagnostics [ ( "B.hs", [(DiagnosticSeverity_Warning, (4, 0), "Top-level binding with no type signature: main :: IO ()")] ) ]-    , testCase "findsTHnewNameConstructor" $ runWithExtraFiles "THNewName" $ \dir -> do--    -- This test defines a TH value with the meaning "data A = A" in A.hs-    -- Loads and export the template in B.hs-    -- And checks wether the constructor A can be loaded in C.hs-    -- This test does not fail when either A and B get manually loaded before C.hs-    -- or when we remove the seemingly unnecessary TH pragma from C.hs--    let cPath = dir </> "C.hs"-    _ <- openDoc cPath "haskell"-    expectDiagnostics [ ( cPath, [(DiagnosticSeverity_Warning, (3, 0), "Top-level binding with no type signature: a :: A")] ) ]-    ]----- | Test that all modules have linkables-thLoadingTest :: TestTree-thLoadingTest = testCase "Loading linkables" $ runWithExtraFiles "THLoading" $ \dir -> do-    let thb = dir </> "THB.hs"-    _ <- openDoc thb "haskell"-    expectNoMoreDiagnostics 1--thCoreTest :: TestTree-thCoreTest = testCase "Verifying TH core files" $ runWithExtraFiles "THCoreFile" $ \dir -> do-    let thc = dir </> "THC.hs"-    _ <- openDoc thc "haskell"-    expectNoMoreDiagnostics 1---- | test that TH is reevaluated on typecheck-thReloadingTest :: Bool -> TestTree-thReloadingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do--    let aPath = dir </> "THA.hs"-        bPath = dir </> "THB.hs"-        cPath = dir </> "THC.hs"--    aSource <- liftIO $ readFileUtf8 aPath --  th = [d|a = ()|]-    bSource <- liftIO $ readFileUtf8 bPath --  $th-    cSource <- liftIO $ readFileUtf8 cPath --  c = a :: ()--    adoc <- createDoc aPath "haskell" aSource-    bdoc <- createDoc bPath "haskell" bSource-    cdoc <- createDoc cPath "haskell" cSource--    expectDiagnostics [("THB.hs", [(DiagnosticSeverity_Warning, (4,thDollarIdx), "Top-level binding")])]--    -- Change th from () to Bool-    let aSource' = T.unlines $ init (T.lines aSource) ++ ["th_a = [d| a = False|]"]-    changeDoc adoc [TextDocumentContentChangeEvent . InR . (.==) #text $ aSource']-    -- generate an artificial warning to avoid timing out if the TH change does not propagate-    changeDoc cdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ cSource <> "\nfoo=()"]--    -- Check that the change propagates to C-    expectDiagnostics-        [("THC.hs", [(DiagnosticSeverity_Error, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")])-        ,("THC.hs", [(DiagnosticSeverity_Warning, (6,0), "Top-level binding")])-        ,("THB.hs", [(DiagnosticSeverity_Warning, (4,thDollarIdx), "Top-level bindin")])-        ]--    closeDoc adoc-    closeDoc bdoc-    closeDoc cdoc-  where-    name = "reloading-th-test" <> if unboxed then "-unboxed" else ""-    dir | unboxed = "THUnboxed"-        | otherwise = "TH"--thLinkingTest :: Bool -> TestTree-thLinkingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do--    let aPath = dir </> "THA.hs"-        bPath = dir </> "THB.hs"--    aSource <- liftIO $ readFileUtf8 aPath --  th_a = [d|a :: ()|]-    bSource <- liftIO $ readFileUtf8 bPath --  $th_a--    adoc <- createDoc aPath "haskell" aSource-    bdoc <- createDoc bPath "haskell" bSource--    expectDiagnostics [("THB.hs", [(DiagnosticSeverity_Warning, (4,thDollarIdx), "Top-level binding")])]--    let aSource' = T.unlines $ init (init (T.lines aSource)) ++ ["th :: DecsQ", "th = [d| a = False|]"]-    changeDoc adoc [TextDocumentContentChangeEvent . InR . (.==) #text $ aSource']--    -- modify b too-    let bSource' = T.unlines $ init (T.lines bSource) ++ ["$th"]-    changeDoc bdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ bSource']-    waitForProgressBegin-    waitForAllProgressDone--    expectCurrentDiagnostics bdoc [(DiagnosticSeverity_Warning, (4,thDollarIdx), "Top-level binding")]--    closeDoc adoc-    closeDoc bdoc-  where-    name = "th-linking-test" <> if unboxed then "-unboxed" else ""-    dir | unboxed = "THUnboxed"-        | otherwise = "TH"

− test/exe/TestUtils.hs

@@ -1,325 +0,0 @@--{-# LANGUAGE GADTs           #-}-{-# LANGUAGE PatternSynonyms #-}--module TestUtils where--import           Control.Applicative.Combinators-import           Control.Concurrent.Async-import           Control.Exception               (bracket_, finally)-import           Control.Lens                    ((.~))-import qualified Control.Lens                    as Lens-import qualified Control.Lens.Extras             as Lens-import           Control.Monad-import           Control.Monad.IO.Class          (liftIO)-import           Data.Foldable-import           Data.Function                   ((&))-import           Data.Maybe-import qualified Data.Text                       as T-import           Development.IDE.GHC.Compat      (GhcVersion (..), ghcVersion)-import           Development.IDE.GHC.Util-import qualified Development.IDE.Main            as IDE-import           Development.IDE.Test            (canonicalizeUri,-                                                  configureCheckProject,-                                                  expectNoMoreDiagnostics)-import           Development.IDE.Test.Runfiles-import           Development.IDE.Types.Location-import           Development.Shake               (getDirectoryFilesIO)-import           Ide.Logger                      (Recorder, WithPriority,-                                                  cmapWithPrio)-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.Environment.Blank        (getEnv, setEnv, unsetEnv)-import           System.FilePath-import           System.Info.Extra               (isMac, isWindows)-import qualified System.IO.Extra-import           System.Process.Extra            (createPipe)-import           Test.Tasty-import           Test.Tasty.ExpectedFailure-import           Test.Tasty.HUnit--import           LogType---- | Wait for the next progress begin step-waitForProgressBegin :: Session ()-waitForProgressBegin = skipManyTill anyMessage $ satisfyMaybe $ \case-  FromServerMess  SMethod_Progress  (TNotificationMessage _ _ (ProgressParams _ v)) | Lens.is _workDoneProgressBegin v-> Just ()-  _ -> Nothing---- | Wait for the first progress end step--- Also implemented in hls-test-utils Test.Hls-waitForProgressDone :: Session ()-waitForProgressDone = skipManyTill anyMessage $ satisfyMaybe $ \case-  FromServerMess  SMethod_Progress  (TNotificationMessage _ _ (ProgressParams _ v)) | Lens.is _workDoneProgressEnd v -> Just ()-  _ -> Nothing---- | Wait for all progress to be done--- Needs at least one progress done notification to return--- Also implemented in hls-test-utils Test.Hls-waitForAllProgressDone :: Session ()-waitForAllProgressDone = loop-  where-    loop = do-      ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case-        FromServerMess  SMethod_Progress  (TNotificationMessage _ _ (ProgressParams _ v)) |Lens.is _workDoneProgressEnd v-> Just ()-        _ -> Nothing-      done <- null <$> getIncompleteProgressSessions-      unless done loop--run :: Session a -> IO a-run s = run' (const s)--run' :: (FilePath -> Session a) -> IO a-run' s = withTempDir $ \dir -> runInDir dir (s dir)--runInDir :: FilePath -> Session a -> IO a-runInDir dir = runInDir' dir "." "." []---- | Takes a directory as well as relative paths to where we should launch the executable as well as the session root.-runInDir' :: FilePath -> FilePath -> FilePath -> [String] -> Session a -> IO a-runInDir' = runInDir'' lspTestCaps--runInDir''-    :: ClientCapabilities-    -> FilePath-    -> FilePath-    -> FilePath-    -> [String]-    -> Session b-    -> IO b-runInDir'' lspCaps dir startExeIn startSessionIn extraOptions s = do--  ghcideExe <- locateGhcideExecutable-  let startDir = dir </> startExeIn-  let projDir = dir </> startSessionIn--  createDirectoryIfMissing True startDir-  createDirectoryIfMissing True projDir-  -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56-  -- since the package import test creates "Data/List.hs", which otherwise has no physical home-  createDirectoryIfMissing True $ projDir ++ "/Data"--  shakeProfiling <- getEnv "SHAKE_PROFILING"-  let cmd = unwords $-       [ghcideExe, "--lsp", "--test", "--verify-core-file", "--verbose", "-j2", "--cwd", startDir-       ] ++ ["--shake-profiling=" <> dir | Just dir <- [shakeProfiling]-       ] ++ extraOptions-  -- HIE calls getXgdDirectory which assumes that HOME is set.-  -- Only sets HOME if it wasn't already set.-  setEnv "HOME" "/homeless-shelter" False-  conf <- getConfigFromEnv-  runSessionWithConfig conf cmd lspCaps projDir $ do-      configureCheckProject False-      s---- | Version of 'System.IO.Extra.withTempDir' that canonicalizes the path--- Which we need to do on macOS since the $TMPDIR can be in @/private/var@ or--- @/var@-withTempDir :: (FilePath -> IO a) -> IO a-withTempDir f = System.IO.Extra.withTempDir $ \dir -> do-  dir' <- canonicalizePath dir-  f dir'--lspTestCaps :: ClientCapabilities-lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities (Just True) Nothing Nothing }--getConfigFromEnv :: IO SessionConfig-getConfigFromEnv = do-  logColor <- fromMaybe True <$> checkEnv "LSP_TEST_LOG_COLOR"-  timeoutOverride <- fmap read <$> getEnv "LSP_TIMEOUT"-  return defaultConfig-    { messageTimeout = fromMaybe (messageTimeout defaultConfig) timeoutOverride-    , logColor-    }-  where-    checkEnv :: String -> IO (Maybe Bool)-    checkEnv s = fmap convertVal <$> getEnv s-    convertVal "0" = False-    convertVal _   = True--testSessionWait :: HasCallStack => String -> Session () -> TestTree-testSessionWait name = testSession name .-      -- Check that any diagnostics produced were already consumed by the test case.-      ---      -- If in future we add test cases where we don't care about checking the diagnostics,-      -- this could move elsewhere.-      ---      -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear.-      ( >> expectNoMoreDiagnostics 0.5)--testSession :: String -> Session () -> TestTree-testSession name = testCase name . run--xfail :: TestTree -> String -> TestTree-xfail = flip expectFailBecause--ignoreInWindowsBecause :: String -> TestTree -> TestTree-ignoreInWindowsBecause = ignoreFor (BrokenForOS Windows)--ignoreForGHC92Plus :: String -> TestTree -> TestTree-ignoreForGHC92Plus = ignoreFor (BrokenForGHC [GHC92, GHC94, GHC96, GHC98])--knownBrokenForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree-knownBrokenForGhcVersions ghcVers = knownBrokenFor (BrokenForGHC ghcVers)--data BrokenOS = Linux | MacOS | Windows deriving (Show)--data IssueSolution = Broken | Ignore deriving (Show)--data BrokenTarget =-    BrokenSpecific BrokenOS [GhcVersion]-    -- ^Broken for `BrokenOS` with `GhcVersion`-    | BrokenForOS BrokenOS-    -- ^Broken for `BrokenOS`-    | BrokenForGHC [GhcVersion]-    -- ^Broken for `GhcVersion`-    deriving (Show)---- | Ignore test for specific os and ghc with reason.-ignoreFor :: BrokenTarget -> String -> TestTree -> TestTree-ignoreFor = knownIssueFor Ignore---- | Known broken for specific os and ghc with reason.-knownBrokenFor :: BrokenTarget -> String -> TestTree -> TestTree-knownBrokenFor = knownIssueFor Broken---- | Deal with `IssueSolution` for specific OS and GHC.-knownIssueFor :: IssueSolution -> BrokenTarget -> String -> TestTree -> TestTree-knownIssueFor solution = go . \case-    BrokenSpecific bos vers -> isTargetOS bos && isTargetGhc vers-    BrokenForOS bos         -> isTargetOS bos-    BrokenForGHC vers       -> isTargetGhc vers-    where-        isTargetOS = \case-            Windows -> isWindows-            MacOS   -> isMac-            Linux   -> not isWindows && not isMac--        isTargetGhc = elem ghcVersion--        go True = case solution of-            Broken -> expectFailBecause-            Ignore -> ignoreTestBecause-        go False = const id--data Expect-  = ExpectRange Range -- Both gotoDef and hover should report this range-  | ExpectLocation Location---  | ExpectDefRange Range -- Only gotoDef should report this range-  | ExpectHoverRange Range -- Only hover should report this range-  | ExpectHoverText [T.Text] -- the hover message must contain these snippets-  | ExpectHoverExcludeText [T.Text] -- the hover message must _not_ contain these snippets-  | ExpectHoverTextRegex T.Text -- the hover message must match this pattern-  | ExpectExternFail -- definition lookup in other file expected to fail-  | ExpectNoDefinitions-  | ExpectNoHover---  | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples-  deriving Eq--mkR :: UInt -> UInt -> UInt -> UInt -> Expect-mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn--mkL :: Uri -> UInt -> UInt -> UInt -> UInt -> Expect-mkL uri startLine startColumn endLine endColumn = ExpectLocation $ Location uri $ mkRange startLine startColumn endLine endColumn----testSessionWithExtraFiles :: FilePath -> String -> (FilePath -> Session ()) -> TestTree-testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix--testSession' :: String -> (FilePath -> Session ()) -> TestTree-testSession' name = testCase name . run'----mkRange :: UInt -> UInt -> UInt -> UInt -> Range-mkRange a b c d = Range (Position a b) (Position c d)---runWithExtraFiles :: FilePath -> (FilePath -> Session a) -> IO a-runWithExtraFiles prefix s = withTempDir $ \dir -> do-  copyTestDataFiles dir prefix-  runInDir dir (s dir)--copyTestDataFiles :: FilePath -> FilePath -> IO ()-copyTestDataFiles dir prefix = do-  -- Copy all the test data files to the temporary workspace-  testDataFiles <- getDirectoryFilesIO ("test/data" </> prefix) ["//*"]-  for_ testDataFiles $ \f -> do-    createDirectoryIfMissing True $ dir </> takeDirectory f-    copyFile ("test/data" </> prefix </> f) (dir </> f)--withLongTimeout :: IO a -> IO a-withLongTimeout = bracket_ (setEnv "LSP_TIMEOUT" "120" True) (unsetEnv "LSP_TIMEOUT")----lspTestCapsNoFileWatches :: ClientCapabilities-lspTestCapsNoFileWatches = lspTestCaps & L.workspace . Lens._Just . L.didChangeWatchedFiles .~ Nothing--openTestDataDoc :: FilePath -> Session TextDocumentIdentifier-openTestDataDoc path = do-  source <- liftIO $ readFileUtf8 $ "test/data" </> path-  createDoc path "haskell" source--pattern R :: UInt -> UInt -> UInt -> UInt -> Range-pattern R x y x' y' = Range (Position x y) (Position x' y')--checkDefs :: Definition |? ([DefinitionLink] |? Null) -> Session [Expect] -> Session ()-checkDefs (defToLocation -> defs) mkExpectations = traverse_ check =<< mkExpectations where-  check (ExpectRange expectedRange) = do-    def <- assertOneDefinitionFound defs-    assertRangeCorrect def expectedRange-  check (ExpectLocation expectedLocation) = do-    def <- assertOneDefinitionFound defs-    liftIO $ do-      canonActualLoc <- canonicalizeLocation def-      canonExpectedLoc <- canonicalizeLocation expectedLocation-      canonActualLoc @?= canonExpectedLoc-  check ExpectNoDefinitions = do-    liftIO $ assertBool "Expecting no definitions" $ null defs-  check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"-  check _ = pure () -- all other expectations not relevant to getDefinition--  assertOneDefinitionFound :: [Location] -> Session Location-  assertOneDefinitionFound [def] = pure def-  assertOneDefinitionFound xs = liftIO . assertFailure $ "Expecting exactly one definition, got " <> show (length xs)--  assertRangeCorrect Location{_range = foundRange} expectedRange =-    liftIO $ expectedRange @=? foundRange--canonicalizeLocation :: Location -> IO Location-canonicalizeLocation (Location uri range) = Location <$> canonicalizeUri uri <*> pure range--defToLocation :: Definition |? ([DefinitionLink] |? Null) -> [Location]-defToLocation (InL (Definition (InL l))) = [l]-defToLocation (InL (Definition (InR ls))) = ls-defToLocation (InR (InL defLink)) = (\(DefinitionLink LocationLink{_targetUri,_targetRange}) -> Location _targetUri _targetRange) <$> defLink-defToLocation (InR (InR Null)) = []---- | Ghc 9 doesn't include the $-sign in TH warnings like earlier versions did-thDollarIdx :: UInt-thDollarIdx | ghcVersion >= GHC90 = 1-            | otherwise = 0--testIde :: Recorder (WithPriority Log) -> IDE.Arguments -> Session () -> IO ()-testIde recorder arguments session = do-    config <- getConfigFromEnv-    cwd <- getCurrentDirectory-    (hInRead, hInWrite) <- createPipe-    (hOutRead, hOutWrite) <- createPipe-    let projDir = "."-    let server = IDE.defaultMain (cmapWithPrio LogIDEMain recorder) arguments-            { IDE.argsHandleIn = pure hInRead-            , IDE.argsHandleOut = pure hOutWrite-            }--    flip finally (setCurrentDirectory cwd) $ withAsync server $ \_ ->-        runSessionWithHandles hInWrite hOutRead config lspTestCaps projDir session

− test/exe/UnitTests.hs

@@ -1,110 +0,0 @@--module UnitTests (tests) where--import           Control.Concurrent-import           Control.Monad.IO.Class            (liftIO)-import           Data.IORef-import           Data.IORef.Extra                  (atomicModifyIORef_)-import           Data.List.Extra-import           Data.String                       (IsString (fromString))-import qualified Data.Text                         as T-import           Development.IDE.Core.FileStore    (getModTime)-import qualified Development.IDE.Main              as IDE-import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide-import qualified Development.IDE.Types.Diagnostics as Diagnostics-import           Development.IDE.Types.Location-import qualified FuzzySearch-import           Ide.Logger                        (Logger, Recorder,-                                                    WithPriority, cmapWithPrio)-import           Ide.PluginUtils                   (pluginDescToIdePlugins)-import           Ide.Types-import           Language.LSP.Protocol.Message-import           Language.LSP.Protocol.Types       hiding-                                                   (SemanticTokenAbsolute (..),-                                                    SemanticTokenRelative (..),-                                                    SemanticTokensEdit (..),-                                                    mkRange)-import           Language.LSP.Test-import           LogType                           (Log (..))-import           Network.URI-import qualified Progress-import           System.IO.Extra                   hiding (withTempDir)-import           System.Mem                        (performGC)-import           Test.Tasty-import           Test.Tasty.ExpectedFailure-import           Test.Tasty.HUnit-import           TestUtils-import           Text.Printf                       (printf)--tests :: Recorder (WithPriority Log) -> Logger -> TestTree-tests recorder logger = do-  testGroup "Unit"-     [ testCase "empty file path does NOT work with the empty String literal" $-         uriToFilePath' (fromNormalizedUri $ filePathToUri' "") @?= Just "."-     , testCase "empty file path works using toNormalizedFilePath'" $-         uriToFilePath' (fromNormalizedUri $ filePathToUri' (toNormalizedFilePath' "")) @?= Just ""-     , testCase "empty path URI" $ do-         Just URI{..} <- pure $ parseURI (T.unpack $ getUri $ fromNormalizedUri emptyPathUri)-         uriScheme @?= "file:"-         uriPath @?= ""-     , testCase "from empty path URI" $ do-         let uri = Uri "file://"-         uriToFilePath' uri @?= Just ""-     , testCase "showDiagnostics prints ranges 1-based (like vscode)" $ do-         let diag = ("", Diagnostics.ShowDiag, Diagnostic-               {  _codeDescription = Nothing-                , _data_ = Nothing-                , _range = Range-                   { _start = Position{_line = 0, _character = 1}-                   , _end = Position{_line = 2, _character = 3}-                   }-               , _severity = Nothing-               , _code = Nothing-               , _source = Nothing-               , _message = ""-               , _relatedInformation = Nothing-               , _tags = Nothing-               })-         let shown = T.unpack (Diagnostics.showDiagnostics [diag])-         let expected = "1:2-3:4"-         assertBool (unwords ["expected to find range", expected, "in diagnostic", shown]) $-             expected `isInfixOf` shown-     , testCase "notification handlers run in priority order" $ do-        orderRef <- newIORef []-        let plugins = pluginDescToIdePlugins $-                [ (priorityPluginDescriptor i)-                    { pluginNotificationHandlers = mconcat-                        [ mkPluginNotificationHandler SMethod_TextDocumentDidOpen $ \_ _ _ _ ->-                            liftIO $ atomicModifyIORef_ orderRef (i:)-                        ]-                    }-                    | i <- [1..20]-                ] ++ Ghcide.descriptors (cmapWithPrio LogGhcIde recorder)-            priorityPluginDescriptor i = (defaultPluginDescriptor (fromString $ show i) ""){pluginPriority = i}--        testIde recorder (IDE.testing (cmapWithPrio LogIDEMain recorder) logger plugins) $ do-            _ <- createDoc "A.hs" "haskell" "module A where"-            waitForProgressDone-            actualOrder <- liftIO $ reverse <$> readIORef orderRef--            -- Handlers are run in priority descending order-            liftIO $ actualOrder @?= [20, 19 .. 1]-     , ignoreTestBecause "The test fails sometimes showing 10000us" $-         testCase "timestamps have millisecond resolution" $ do-           resolution_us <- findResolution_us 1-           let msg = printf "Timestamps do not have millisecond resolution: %dus" resolution_us-           assertBool msg (resolution_us <= 1000)-     , Progress.tests-     , FuzzySearch.tests-     ]--findResolution_us :: Int -> IO Int-findResolution_us delay_us | delay_us >= 1000000 = error "Unable to compute timestamp resolution"-findResolution_us delay_us = withTempFile $ \f -> withTempFile $ \f' -> do-    performGC-    writeFile f ""-    threadDelay delay_us-    writeFile f' ""-    t <- getModTime f-    t' <- getModTime f'-    if t /= t' then return delay_us else findResolution_us (delay_us * 10)

− test/exe/WatchedFileTests.hs

@@ -1,84 +0,0 @@--{-# LANGUAGE GADTs #-}--module WatchedFileTests (tests) where--import           Control.Applicative.Combinators-import           Control.Monad.IO.Class          (liftIO)-import qualified Data.Aeson                      as A-import qualified Data.Text                       as T-import           Development.IDE.Test            (expectDiagnostics)-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 Test.QuickCheck.Instances ()-import           Test.Tasty-import           Test.Tasty.HUnit-import           TestUtils--tests :: TestTree-tests = testGroup "watched files"-  [ testGroup "Subscriptions"-    [ testSession' "workspace files" $ \sessionDir -> do-        liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"WatchedFilesMissingModule\"]}}"-        _doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule"-        setIgnoringRegistrationRequests False-        watchedFileRegs <- getWatchedFilesSubscriptionsUntil SMethod_TextDocumentPublishDiagnostics--        -- Expect 2 subscriptions: one for all .hs files and one for the hie.yaml cradle-        liftIO $ length watchedFileRegs @?= 2--    , testSession' "non workspace file" $ \sessionDir -> do-        tmpDir <- liftIO getTemporaryDirectory-        let yaml = "cradle: {direct: {arguments: [\"-i" <> tail(init(show tmpDir)) <> "\", \"A\", \"WatchedFilesMissingModule\"]}}"-        liftIO $ writeFile (sessionDir </> "hie.yaml") yaml-        _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule"-        setIgnoringRegistrationRequests False-        watchedFileRegs <- getWatchedFilesSubscriptionsUntil SMethod_TextDocumentPublishDiagnostics--        -- Expect 2 subscriptions: one for all .hs files and one for the hie.yaml cradle-        liftIO $ length watchedFileRegs @?= 2--    -- TODO add a test for didChangeWorkspaceFolder-    ]-  , testGroup "Changes"-    [-      testSession' "workspace files" $ \sessionDir -> do-        liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"B\"]}}"-        liftIO $ writeFile (sessionDir </> "B.hs") $ unlines-          ["module B where"-          ,"b :: Bool"-          ,"b = False"]-        _doc <- createDoc "A.hs" "haskell" $ T.unlines-          ["module A where"-          ,"import B"-          ,"a :: ()"-          ,"a = b"-          ]-        expectDiagnostics [("A.hs", [(DiagnosticSeverity_Error, (3, 4), "Couldn't match expected type '()' with actual type 'Bool'")])]-        -- modify B off editor-        liftIO $ writeFile (sessionDir </> "B.hs") $ unlines-          ["module B where"-          ,"b :: Int"-          ,"b = 0"]-        sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $-               [FileEvent (filePathToUri $ sessionDir </> "B.hs") FileChangeType_Changed ]-        expectDiagnostics [("A.hs", [(DiagnosticSeverity_Error, (3, 4), "Couldn't match expected type '()' with actual type 'Int'")])]-    ]-  ]--getWatchedFilesSubscriptionsUntil :: forall m. SServerMethod m -> Session [DidChangeWatchedFilesRegistrationOptions]-getWatchedFilesSubscriptionsUntil m = do-      msgs <- manyTill (Just <$> message SMethod_ClientRegisterCapability <|> Nothing <$ anyMessage) (message m)-      return-            [ x-            | Just TRequestMessage{_params = RegistrationParams regs} <- msgs-            , Registration _id "workspace/didChangeWatchedFiles" (Just args) <- regs-            , Just x@(DidChangeWatchedFilesRegistrationOptions _) <- [A.decode . A.encode $ args]-            ]

test/src/Development/IDE/Test.hs view

@@ -175,7 +175,7 @@  checkDiagnosticsForDoc :: HasCallStack => TextDocumentIdentifier -> [(DiagnosticSeverity, Cursor, T.Text)] -> [Diagnostic] -> Session () checkDiagnosticsForDoc TextDocumentIdentifier {_uri} expected obtained = do-    let expected' = Map.fromList [(nuri, map (\(ds, c, t) -> (ds, c, t, Nothing)) expected)]+    let expected' = Map.singleton nuri (map (\(ds, c, t) -> (ds, c, t, Nothing)) expected)         nuri = toNormalizedUri _uri     expectDiagnosticsWithTags' (return (_uri, obtained)) expected'