mirror of
https://github.com/haskell/ghcide.git
synced 2024-10-05 17:48:19 +03:00
Fix diagnostics update bug (#959)
* Preventively switch to uninterruptible mask in withMVar' withMVar' is used to update the shakeSession var and it's crucial that the third argument is not interrupted. 'mask' can still be interrupted for I/O actions and, while we were careful to ensure none was used, if it ever breaks it will lead to very hard to debug problems. * refactor: move to RuleTypes * Add a TestRequest to wait for arbitrary ide actions Closes #955 * expectCurrentDiagnostics * Add a test suite for cancellation * Introduce --test-no-kick to fix cancellation tests reliability * delete unsafeClearDiagnostics (unused) * GetModSummaryWithoutTimestamps - remove StringBuffer Since the contents of the buffer are not tracked by the fingerprint. * Fix diagnostics bug Given a FOI F with non null typechecking diagnostics D, imagine the following scenario: 1. An edit notification for F is received, creating a new version 2. GetModTime is executed, producing 0 diagnostics. 2.1 updateFileDiagnostics is called 2.2 setStageDiagnostics is called 2.3 LSP.updateDiagnostics is called with a new version, resetting all the diagnostics for F 2.4 newDiags=[] in updateFileDiagnostics, which is different from D (the last published diagnostics), which enqueues a new publishDiagnostics [] in the Debouncer 3. An edit notification for F is received before typechecking has a chance to run which undoes the previous edit 4. The debouncer publishes the empty set of diagnostics after waiting 0.1s 5. GetFileContents runs and since the contents of the file haven't changed since the last time it ran, early cutoff skips everything donwstream Since TypeCheck is skipped, the empty set of diagnostics stays published until another edit comes. The goal of this change is to prevent setStageDiagnostics from losing diagnostics from other stages. To achieve this, we recover the old diagnostics for all stages and merge them with the new stage. * Fix hlint * Use Map.insert for clarity * Fix redundant imports * Fix "code actions after edit" experiment"
This commit is contained in:
Pepe Iborra
GitHub
parent
22d9fde844
commit
0d4e3b9499
@ -115,7 +115,13 @@ experiments =
|
||||
)
|
||||
( \p doc -> do
|
||||
changeDoc doc [hygienicEdit]
|
||||
whileM (null <$> waitForDiagnostics)
|
||||
waitForProgressDone
|
||||
-- NOTE ghcide used to clear and reinstall the diagnostics here
|
||||
-- new versions no longer do, but keep this logic around
|
||||
-- to benchmark old versions sucessfully
|
||||
diags <- getCurrentDiagnostics doc
|
||||
when (null diags) $
|
||||
whileM (null <$> waitForDiagnostics)
|
||||
not . null <$> getCodeActions doc (Range p p)
|
||||
)
|
||||
]
|
||||
|
||||
@ -14,6 +14,7 @@ data Arguments = Arguments
|
||||
,argsShakeProfiling :: Maybe FilePath
|
||||
,argsOTMemoryProfiling :: Bool
|
||||
,argsTesting :: Bool
|
||||
,argsDisableKick :: Bool
|
||||
,argsThreads :: Int
|
||||
,argsVerbose :: Bool
|
||||
}
|
||||
@ -35,5 +36,6 @@ arguments = Arguments
|
||||
<*> optional (strOption $ long "shake-profiling" <> metavar "DIR" <> help "Dump profiling reports to this directory")
|
||||
<*> switch (long "ot-memory-profiling" <> help "Record OpenTelemetry info to the eventlog. Needs the -l RTS flag to have an effect")
|
||||
<*> switch (long "test" <> help "Enable additional lsp messages used by the testsuite")
|
||||
<*> switch (long "test-no-kick" <> help "Disable kick. Useful for testing cancellation")
|
||||
<*> option auto (short 'j' <> help "Number of threads (0: automatic)" <> metavar "NUM" <> value 0 <> showDefault)
|
||||
<*> switch (long "verbose" <> help "Include internal events in logging output")
|
||||
|
||||
10
exe/Main.hs
10
exe/Main.hs
@ -118,7 +118,15 @@ main = do
|
||||
}
|
||||
logLevel = if argsVerbose then minBound else Info
|
||||
debouncer <- newAsyncDebouncer
|
||||
initialise caps (mainRule >> pluginRules plugins >> action kick)
|
||||
let rules = do
|
||||
-- install the main and ghcide-plugin rules
|
||||
mainRule
|
||||
pluginRules plugins
|
||||
-- install the kick action, which triggers a typecheck on every
|
||||
-- Shake database restart, i.e. on every user edit.
|
||||
unless argsDisableKick $
|
||||
action kick
|
||||
initialise caps rules
|
||||
getLspId event wProg wIndefProg (logger logLevel) debouncer options vfs
|
||||
else do
|
||||
-- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error
|
||||
|
||||
@ -41,6 +41,7 @@ library
|
||||
base == 4.*,
|
||||
binary,
|
||||
bytestring,
|
||||
case-insensitive,
|
||||
containers,
|
||||
data-default,
|
||||
deepseq,
|
||||
|
||||
@ -28,7 +28,6 @@ import Development.IDE.Core.Shake as X
|
||||
ShakeExtras,
|
||||
IdeRule,
|
||||
define, defineEarlyCutoff,
|
||||
GetModificationTime(GetModificationTime),
|
||||
use, useNoFile, uses, useWithStale, useWithStaleFast, useWithStaleFast',
|
||||
FastResult(..),
|
||||
use_, useNoFile_, uses_, useWithStale_,
|
||||
|
||||
@ -28,7 +28,6 @@ import Control.Monad.Extra
|
||||
import Development.Shake
|
||||
import Development.Shake.Classes
|
||||
import Control.Exception
|
||||
import GHC.Generics
|
||||
import Data.Either.Extra
|
||||
import Data.Int (Int64)
|
||||
import Data.Time
|
||||
@ -100,15 +99,6 @@ isFileOfInterestRule = defineEarlyCutoff $ \IsFileOfInterest f -> do
|
||||
let res = maybe NotFOI IsFOI $ f `HM.lookup` filesOfInterest
|
||||
return (Just $ BS.pack $ show $ hash res, ([], Just res))
|
||||
|
||||
-- | Get the contents of a file, either dirty (if the buffer is modified) or Nothing to mean use from disk.
|
||||
type instance RuleResult GetFileContents = (FileVersion, Maybe T.Text)
|
||||
|
||||
data GetFileContents = GetFileContents
|
||||
deriving (Eq, Show, Generic)
|
||||
instance Hashable GetFileContents
|
||||
instance NFData GetFileContents
|
||||
instance Binary GetFileContents
|
||||
|
||||
getModificationTimeRule :: VFSHandle -> Rules ()
|
||||
getModificationTimeRule vfs =
|
||||
defineEarlyCutoff $ \(GetModificationTime_ missingFileDiags) file -> do
|
||||
|
||||
@ -2,6 +2,7 @@
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
|
||||
@ -37,6 +38,8 @@ import Language.Haskell.LSP.Types (NormalizedFilePath)
|
||||
import TcRnMonad (TcGblEnv)
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import Development.IDE.Types.Options (IdeGhcSession)
|
||||
import Data.Text (Text)
|
||||
import Data.Int (Int64)
|
||||
|
||||
data LinkableType = ObjectLinkable | BCOLinkable
|
||||
deriving (Eq,Ord,Show)
|
||||
@ -190,6 +193,55 @@ type instance RuleResult GetModIface = HiFileResult
|
||||
-- For better early cuttoff
|
||||
type instance RuleResult GetModIfaceWithoutLinkable = HiFileResult
|
||||
|
||||
-- | Get the contents of a file, either dirty (if the buffer is modified) or Nothing to mean use from disk.
|
||||
type instance RuleResult GetFileContents = (FileVersion, Maybe Text)
|
||||
|
||||
-- The Shake key type for getModificationTime queries
|
||||
data GetModificationTime = GetModificationTime_
|
||||
{ missingFileDiagnostics :: Bool
|
||||
-- ^ If false, missing file diagnostics are not reported
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
|
||||
instance Eq GetModificationTime where
|
||||
-- Since the diagnostics are not part of the answer, the query identity is
|
||||
-- independent from the 'missingFileDiagnostics' field
|
||||
_ == _ = True
|
||||
|
||||
instance Hashable GetModificationTime where
|
||||
-- Since the diagnostics are not part of the answer, the query identity is
|
||||
-- independent from the 'missingFileDiagnostics' field
|
||||
hashWithSalt salt _ = salt
|
||||
|
||||
instance NFData GetModificationTime
|
||||
instance Binary GetModificationTime
|
||||
|
||||
pattern GetModificationTime :: GetModificationTime
|
||||
pattern GetModificationTime = GetModificationTime_ {missingFileDiagnostics=True}
|
||||
|
||||
-- | Get the modification time of a file.
|
||||
type instance RuleResult GetModificationTime = FileVersion
|
||||
|
||||
data FileVersion
|
||||
= VFSVersion !Int
|
||||
| ModificationTime
|
||||
!Int64 -- ^ Large unit (platform dependent, do not make assumptions)
|
||||
!Int64 -- ^ Small unit (platform dependent, do not make assumptions)
|
||||
deriving (Show, Generic)
|
||||
|
||||
instance NFData FileVersion
|
||||
|
||||
vfsVersion :: FileVersion -> Maybe Int
|
||||
vfsVersion (VFSVersion i) = Just i
|
||||
vfsVersion ModificationTime{} = Nothing
|
||||
|
||||
data GetFileContents = GetFileContents
|
||||
deriving (Eq, Show, Generic)
|
||||
instance Hashable GetFileContents
|
||||
instance NFData GetFileContents
|
||||
instance Binary GetFileContents
|
||||
|
||||
|
||||
data FileOfInterestStatus = OnDisk | Modified
|
||||
deriving (Eq, Show, Typeable, Generic)
|
||||
instance Hashable FileOfInterestStatus
|
||||
|
||||
@ -734,7 +734,7 @@ getModSummaryRule = do
|
||||
getModSummaryFromImports session fp modTime (textToStringBuffer <$> mFileContent)
|
||||
case modS of
|
||||
Right res@(ms,_) -> do
|
||||
let fingerPrint = hash (computeFingerprint f dflags ms, hashUTC modTime)
|
||||
let fingerPrint = hash (computeFingerprint f (fromJust $ ms_hspp_buf ms) dflags ms, hashUTC modTime)
|
||||
return ( Just (BS.pack $ show fingerPrint) , ([], Just res))
|
||||
Left diags -> return (Nothing, (diags, Nothing))
|
||||
|
||||
@ -742,16 +742,18 @@ getModSummaryRule = do
|
||||
ms <- use GetModSummary f
|
||||
case ms of
|
||||
Just res@(msWithTimestamps,_) -> do
|
||||
let ms = msWithTimestamps { ms_hs_date = error "use GetModSummary instead of GetModSummaryWithoutTimestamps" }
|
||||
let ms = msWithTimestamps {
|
||||
ms_hs_date = error "use GetModSummary instead of GetModSummaryWithoutTimestamps",
|
||||
ms_hspp_buf = error "use GetModSummary instead of GetModSummaryWithoutTimestamps"
|
||||
}
|
||||
dflags <- hsc_dflags . hscEnv <$> use_ GhcSession f
|
||||
-- include the mod time in the fingerprint
|
||||
let fp = BS.pack $ show $ hash (computeFingerprint f dflags ms)
|
||||
let fp = BS.pack $ show $ hash (computeFingerprint f (fromJust $ ms_hspp_buf msWithTimestamps) dflags ms)
|
||||
return (Just fp, ([], Just res))
|
||||
Nothing -> return (Nothing, ([], Nothing))
|
||||
where
|
||||
-- Compute a fingerprint from the contents of `ModSummary`,
|
||||
-- eliding the timestamps and other non relevant fields.
|
||||
computeFingerprint f dflags ModSummary{..} =
|
||||
computeFingerprint f sb dflags ModSummary{..} =
|
||||
let fingerPrint =
|
||||
( moduleNameString (moduleName ms_mod)
|
||||
, ms_hspp_file
|
||||
@ -761,7 +763,7 @@ getModSummaryRule = do
|
||||
, fingerPrintImports ms_textual_imps
|
||||
)
|
||||
fingerPrintImports = map (fmap uniq *** (moduleNameString . unLoc))
|
||||
opts = Hdr.getOptions dflags (fromJust ms_hspp_buf) (fromNormalizedFilePath f)
|
||||
opts = Hdr.getOptions dflags sb (fromNormalizedFilePath f)
|
||||
in fingerPrint
|
||||
|
||||
hashUTC UTCTime{..} = (fromEnum utctDay, fromEnum utctDayTime)
|
||||
|
||||
@ -13,7 +13,7 @@ module Development.IDE.Core.Service(
|
||||
IdeState, initialise, shutdown,
|
||||
runAction,
|
||||
writeProfile,
|
||||
getDiagnostics, unsafeClearDiagnostics,
|
||||
getDiagnostics,
|
||||
ideLogger,
|
||||
updatePositionMapping,
|
||||
) where
|
||||
|
||||
@ -7,7 +7,6 @@
|
||||
{-# LANGUAGE RecursiveDo #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
|
||||
-- | A Shake implementation of the compiler service.
|
||||
--
|
||||
@ -38,7 +37,7 @@ module Development.IDE.Core.Shake(
|
||||
useWithStale, usesWithStale,
|
||||
useWithStale_, usesWithStale_,
|
||||
define, defineEarlyCutoff, defineOnDisk, needOnDisk, needOnDisks,
|
||||
getDiagnostics, unsafeClearDiagnostics,
|
||||
getDiagnostics,
|
||||
getHiddenDiagnostics,
|
||||
IsIdeGlobal, addIdeGlobal, addIdeGlobalExtras, getIdeGlobalState, getIdeGlobalAction,
|
||||
getIdeGlobalExtras,
|
||||
@ -84,6 +83,7 @@ import Development.IDE.Core.Debouncer
|
||||
import Development.IDE.GHC.Compat (NameCacheUpdater(..), upNameCache )
|
||||
import Development.IDE.GHC.Orphans ()
|
||||
import Development.IDE.Core.PositionMapping
|
||||
import Development.IDE.Core.RuleTypes
|
||||
import Development.IDE.Types.Action
|
||||
import Development.IDE.Types.Logger hiding (Priority)
|
||||
import Development.IDE.Types.KnownTargets
|
||||
@ -124,7 +124,6 @@ import Data.IORef
|
||||
import NameCache
|
||||
import UniqSupply
|
||||
import PrelInfo
|
||||
import Data.Int (Int64)
|
||||
import Language.Haskell.LSP.Types.Capabilities
|
||||
import OpenTelemetry.Eventlog
|
||||
|
||||
@ -502,7 +501,7 @@ shakeShut IdeState{..} = withMVar shakeSession $ \runner -> do
|
||||
-- | This is a variant of withMVar where the first argument is run unmasked and if it throws
|
||||
-- an exception, the previous value is restored while the second argument is executed masked.
|
||||
withMVar' :: MVar a -> (a -> IO b) -> (b -> IO (a, c)) -> IO c
|
||||
withMVar' var unmasked masked = mask $ \restore -> do
|
||||
withMVar' var unmasked masked = uninterruptibleMask $ \restore -> do
|
||||
a <- takeMVar var
|
||||
b <- restore (unmasked a) `onException` putMVar var a
|
||||
(a', c) <- masked b
|
||||
@ -652,11 +651,6 @@ getHiddenDiagnostics IdeState{shakeExtras = ShakeExtras{hiddenDiagnostics}} = do
|
||||
val <- readVar hiddenDiagnostics
|
||||
return $ getAllDiagnostics val
|
||||
|
||||
-- | FIXME: This function is temporary! Only required because the files of interest doesn't work
|
||||
unsafeClearDiagnostics :: IdeState -> IO ()
|
||||
unsafeClearDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} =
|
||||
writeVar diagnostics mempty
|
||||
|
||||
-- | Clear the results for all files that do not match the given predicate.
|
||||
garbageCollect :: (NormalizedFilePath -> Bool) -> Action ()
|
||||
garbageCollect keep = do
|
||||
@ -998,25 +992,19 @@ updateFileDiagnostics :: MonadIO m
|
||||
updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, state, debouncer, eventer} current = liftIO $ do
|
||||
modTime <- (currentValue =<<) <$> getValues state GetModificationTime fp
|
||||
let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current
|
||||
uri = filePathToUri' fp
|
||||
ver = vfsVersion =<< modTime
|
||||
updateDiagnosticsWithForcing new store = do
|
||||
store' <- evaluate $ setStageDiagnostics uri ver (T.pack $ show k) new store
|
||||
new' <- evaluate $ getUriDiagnostics uri store'
|
||||
return (store', new')
|
||||
mask_ $ do
|
||||
-- Mask async exceptions to ensure that updated diagnostics are always
|
||||
-- published. Otherwise, we might never publish certain diagnostics if
|
||||
-- an exception strikes between modifyVar but before
|
||||
-- publishDiagnosticsNotification.
|
||||
newDiags <- modifyVar diagnostics $ \old -> do
|
||||
let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime)
|
||||
(T.pack $ show k) (map snd currentShown) old
|
||||
let newDiags = getFileDiagnostics fp newDiagsStore
|
||||
_ <- evaluate newDiagsStore
|
||||
_ <- evaluate newDiags
|
||||
pure (newDiagsStore, newDiags)
|
||||
modifyVar_ hiddenDiagnostics $ \old -> do
|
||||
let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime)
|
||||
(T.pack $ show k) (map snd currentHidden) old
|
||||
let newDiags = getFileDiagnostics fp newDiagsStore
|
||||
_ <- evaluate newDiagsStore
|
||||
_ <- evaluate newDiags
|
||||
return newDiagsStore
|
||||
newDiags <- modifyVar diagnostics $ updateDiagnosticsWithForcing $ map snd currentShown
|
||||
_ <- modifyVar hiddenDiagnostics $ updateDiagnosticsWithForcing $ map snd currentHidden
|
||||
let uri = filePathToUri' fp
|
||||
let delay = if null newDiags then 0.1 else 0
|
||||
registerEvent debouncer delay uri $ do
|
||||
@ -1051,45 +1039,6 @@ actionLogger = do
|
||||
return logger
|
||||
|
||||
|
||||
-- The Shake key type for getModificationTime queries
|
||||
data GetModificationTime = GetModificationTime_
|
||||
{ missingFileDiagnostics :: Bool
|
||||
-- ^ If false, missing file diagnostics are not reported
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
|
||||
instance Eq GetModificationTime where
|
||||
-- Since the diagnostics are not part of the answer, the query identity is
|
||||
-- independent from the 'missingFileDiagnostics' field
|
||||
_ == _ = True
|
||||
|
||||
instance Hashable GetModificationTime where
|
||||
-- Since the diagnostics are not part of the answer, the query identity is
|
||||
-- independent from the 'missingFileDiagnostics' field
|
||||
hashWithSalt salt _ = salt
|
||||
|
||||
instance NFData GetModificationTime
|
||||
instance Binary GetModificationTime
|
||||
|
||||
pattern GetModificationTime :: GetModificationTime
|
||||
pattern GetModificationTime = GetModificationTime_ {missingFileDiagnostics=True}
|
||||
|
||||
-- | Get the modification time of a file.
|
||||
type instance RuleResult GetModificationTime = FileVersion
|
||||
|
||||
data FileVersion
|
||||
= VFSVersion !Int
|
||||
| ModificationTime
|
||||
!Int64 -- ^ Large unit (platform dependent, do not make assumptions)
|
||||
!Int64 -- ^ Small unit (platform dependent, do not make assumptions)
|
||||
deriving (Show, Generic)
|
||||
|
||||
instance NFData FileVersion
|
||||
|
||||
vfsVersion :: FileVersion -> Maybe Int
|
||||
vfsVersion (VFSVersion i) = Just i
|
||||
vfsVersion ModificationTime{} = Nothing
|
||||
|
||||
getDiagnosticsFromStore :: StoreItem -> [Diagnostic]
|
||||
getDiagnosticsFromStore (StoreItem _ diags) = concatMap SL.fromSortedList $ Map.elems diags
|
||||
|
||||
@ -1097,17 +1046,24 @@ getDiagnosticsFromStore (StoreItem _ diags) = concatMap SL.fromSortedList $ Map.
|
||||
-- | Sets the diagnostics for a file and compilation step
|
||||
-- if you want to clear the diagnostics call this with an empty list
|
||||
setStageDiagnostics
|
||||
:: NormalizedFilePath
|
||||
:: NormalizedUri
|
||||
-> TextDocumentVersion -- ^ the time that the file these diagnostics originate from was last edited
|
||||
-> T.Text
|
||||
-> [LSP.Diagnostic]
|
||||
-> DiagnosticStore
|
||||
-> DiagnosticStore
|
||||
setStageDiagnostics fp timeM stage diags ds =
|
||||
updateDiagnostics ds uri timeM diagsBySource
|
||||
where
|
||||
diagsBySource = Map.singleton (Just stage) (SL.toSortedList diags)
|
||||
uri = filePathToUri' fp
|
||||
setStageDiagnostics uri ver stage diags ds = newDiagsStore where
|
||||
-- When 'ver' is a new version, updateDiagnostics throws away diagnostics from all stages
|
||||
-- This interacts bady with early cutoff, so we make sure to preserve diagnostics
|
||||
-- from other stages when calling updateDiagnostics
|
||||
-- But this means that updateDiagnostics cannot be called concurrently
|
||||
-- for different stages anymore
|
||||
updatedDiags = Map.insert (Just stage) (SL.toSortedList diags) oldDiags
|
||||
oldDiags = case HMap.lookup uri ds of
|
||||
Just (StoreItem _ byStage) -> byStage
|
||||
_ -> Map.empty
|
||||
newDiagsStore = updateDiagnostics ds uri ver updatedDiags
|
||||
|
||||
|
||||
getAllDiagnostics ::
|
||||
DiagnosticStore ->
|
||||
@ -1115,13 +1071,13 @@ getAllDiagnostics ::
|
||||
getAllDiagnostics =
|
||||
concatMap (\(k,v) -> map (fromUri k,ShowDiag,) $ getDiagnosticsFromStore v) . HMap.toList
|
||||
|
||||
getFileDiagnostics ::
|
||||
NormalizedFilePath ->
|
||||
getUriDiagnostics ::
|
||||
NormalizedUri ->
|
||||
DiagnosticStore ->
|
||||
[LSP.Diagnostic]
|
||||
getFileDiagnostics fp ds =
|
||||
getUriDiagnostics uri ds =
|
||||
maybe [] getDiagnosticsFromStore $
|
||||
HMap.lookup (filePathToUri' fp) ds
|
||||
HMap.lookup uri ds
|
||||
|
||||
filterDiagnostics ::
|
||||
(NormalizedFilePath -> Bool) ->
|
||||
|
||||
@ -1,11 +1,16 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
-- | A plugin that adds custom messages for use in tests
|
||||
module Development.IDE.Plugin.Test (TestRequest(..), plugin) where
|
||||
module Development.IDE.Plugin.Test
|
||||
( TestRequest(..)
|
||||
, WaitForIdeRuleResult(..)
|
||||
, plugin
|
||||
) where
|
||||
|
||||
import Control.Monad.STM
|
||||
import Data.Aeson
|
||||
import Data.Aeson.Types
|
||||
import Data.CaseInsensitive (CI, original)
|
||||
import Development.IDE.Core.Service
|
||||
import Development.IDE.Core.Shake
|
||||
import Development.IDE.GHC.Compat
|
||||
@ -21,16 +26,25 @@ import Language.Haskell.LSP.Types
|
||||
import System.Time.Extra
|
||||
import Development.IDE.Core.RuleTypes
|
||||
import Control.Monad
|
||||
import Development.Shake (Action)
|
||||
import Data.Maybe (isJust)
|
||||
import Data.Bifunctor
|
||||
import Data.Text (pack, Text)
|
||||
import Data.String
|
||||
import Development.IDE.Types.Location (fromUri)
|
||||
|
||||
data TestRequest
|
||||
= BlockSeconds Seconds -- ^ :: Null
|
||||
| GetInterfaceFilesDir FilePath -- ^ :: String
|
||||
| GetShakeSessionQueueCount -- ^ :: Number
|
||||
| WaitForShakeQueue
|
||||
-- ^ Block until the Shake queue is empty. Returns Null
|
||||
| WaitForShakeQueue -- ^ Block until the Shake queue is empty. Returns Null
|
||||
| WaitForIdeRule String Uri -- ^ :: WaitForIdeRuleResult
|
||||
deriving Generic
|
||||
deriving anyclass (FromJSON, ToJSON)
|
||||
|
||||
newtype WaitForIdeRuleResult = WaitForIdeRuleResult { ideResultSuccess::Bool}
|
||||
deriving newtype (FromJSON, ToJSON)
|
||||
|
||||
plugin :: Plugin c
|
||||
plugin = Plugin {
|
||||
pluginRules = return (),
|
||||
@ -69,4 +83,24 @@ requestHandler _ s WaitForShakeQueue = do
|
||||
n <- countQueue $ actionQueue $ shakeExtras s
|
||||
when (n>0) retry
|
||||
return $ Right Null
|
||||
requestHandler _ s (WaitForIdeRule k file) = do
|
||||
let nfp = fromUri $ toNormalizedUri file
|
||||
success <- runAction ("WaitForIdeRule " <> k <> " " <> show file) s $ parseAction (fromString k) nfp
|
||||
let res = WaitForIdeRuleResult <$> success
|
||||
return $ bimap mkResponseError toJSON res
|
||||
|
||||
mkResponseError :: Text -> ResponseError
|
||||
mkResponseError msg = ResponseError InvalidRequest msg Nothing
|
||||
|
||||
parseAction :: CI String -> NormalizedFilePath -> Action (Either Text Bool)
|
||||
parseAction "typecheck" fp = Right . isJust <$> use TypeCheck fp
|
||||
parseAction "getLocatedImports" fp = Right . isJust <$> use GetLocatedImports fp
|
||||
parseAction "getmodsummary" fp = Right . isJust <$> use GetModSummary fp
|
||||
parseAction "getmodsummarywithouttimestamps" fp = Right . isJust <$> use GetModSummaryWithoutTimestamps fp
|
||||
parseAction "getparsedmodule" fp = Right . isJust <$> use GetParsedModule fp
|
||||
parseAction "ghcsession" fp = Right . isJust <$> use GhcSession fp
|
||||
parseAction "ghcsessiondeps" fp = Right . isJust <$> use GhcSessionDeps fp
|
||||
parseAction "gethieast" fp = Right . isJust <$> use GetHieAst fp
|
||||
parseAction "getDependencies" fp = Right . isJust <$> use GetDependencies fp
|
||||
parseAction "getFileContents" fp = Right . isJust <$> use GetFileContents fp
|
||||
parseAction other _ = return $ Left $ "Cannot parse ide rule: " <> pack (original other)
|
||||
|
||||
@ -58,7 +58,8 @@ import Test.Tasty.HUnit
|
||||
import Test.Tasty.QuickCheck
|
||||
import System.Time.Extra
|
||||
import Development.IDE.Plugin.CodeAction (typeSignatureCommandId, blockCommandId, matchRegExMultipleImports)
|
||||
import Development.IDE.Plugin.Test (TestRequest(BlockSeconds,GetInterfaceFilesDir))
|
||||
import Development.IDE.Plugin.Test (WaitForIdeRuleResult(..), TestRequest(WaitForIdeRule, BlockSeconds,GetInterfaceFilesDir))
|
||||
import Control.Monad.Extra (whenJust)
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
@ -556,7 +557,91 @@ diagnosticTests = testGroup "diagnostics"
|
||||
changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines
|
||||
[ "module Foo() where" , "import MissingModule" ] ]
|
||||
expectDiagnostics [("Foo.hs", [(DsError, (1,7), "Could not find module 'MissingModule'")])]
|
||||
|
||||
, testGroup "Cancellation"
|
||||
[ cancellationTestGroup "edit header" editHeader yesDepends yesSession noParse noTc
|
||||
, cancellationTestGroup "edit import" editImport noDepends noSession yesParse noTc
|
||||
, cancellationTestGroup "edit body" editBody yesDepends yesSession yesParse yesTc
|
||||
]
|
||||
]
|
||||
where
|
||||
editPair x y = let p = Position x y ; p' = Position x (y+2) in
|
||||
(TextDocumentContentChangeEvent {_range=Just (Range p p), _rangeLength=Nothing, _text="fd"}
|
||||
,TextDocumentContentChangeEvent {_range=Just (Range p p'), _rangeLength=Nothing, _text=""})
|
||||
editHeader = editPair 0 0
|
||||
editImport = editPair 2 10
|
||||
editBody = editPair 3 10
|
||||
|
||||
noParse = False
|
||||
yesParse = True
|
||||
|
||||
noDepends = False
|
||||
yesDepends = True
|
||||
|
||||
noSession = False
|
||||
yesSession = True
|
||||
|
||||
noTc = False
|
||||
yesTc = True
|
||||
|
||||
cancellationTestGroup :: TestName -> (TextDocumentContentChangeEvent, TextDocumentContentChangeEvent) -> Bool -> Bool -> Bool -> Bool -> TestTree
|
||||
cancellationTestGroup name edits dependsOutcome 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 ("GetDependencies", dependsOutcome)
|
||||
, 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 = [(DsWarning, (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
|
||||
Right 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
|
||||
|
||||
waitForAction key TextDocumentIdentifier{_uri} = do
|
||||
waitId <- sendRequest (CustomClientMethod "test") (WaitForIdeRule key _uri)
|
||||
ResponseMessage{_result} <- skipManyTill anyMessage $ responseForId waitId
|
||||
return _result
|
||||
|
||||
typeCheck doc = do
|
||||
Right 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
|
||||
|
||||
codeActionTests :: TestTree
|
||||
codeActionTests = testGroup "code actions"
|
||||
@ -3652,7 +3737,7 @@ rootUriTests = testCase "use rootUri" . runTest "dirA" "dirB" $ \dir -> do
|
||||
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)
|
||||
runTest dir1 dir2 s = withTempDir $ \dir -> runInDir' dir dir1 dir2 [] (s dir)
|
||||
|
||||
-- | Test if ghcide asynchronously handles Commands and user Requests
|
||||
asyncTests :: TestTree
|
||||
@ -3765,11 +3850,11 @@ run' :: (FilePath -> Session a) -> IO a
|
||||
run' s = withTempDir $ \dir -> runInDir dir (s dir)
|
||||
|
||||
runInDir :: FilePath -> Session a -> IO a
|
||||
runInDir dir = runInDir' dir "." "."
|
||||
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 -> Session a -> IO a
|
||||
runInDir' dir startExeIn startSessionIn s = do
|
||||
runInDir' :: FilePath -> FilePath -> FilePath -> [String] -> Session a -> IO a
|
||||
runInDir' dir startExeIn startSessionIn extraOptions s = do
|
||||
ghcideExe <- locateGhcideExecutable
|
||||
let startDir = dir </> startExeIn
|
||||
let projDir = dir </> startSessionIn
|
||||
@ -3780,7 +3865,8 @@ runInDir' dir startExeIn startSessionIn s = do
|
||||
-- since the package import test creates "Data/List.hs", which otherwise has no physical home
|
||||
createDirectoryIfMissing True $ projDir ++ "/Data"
|
||||
|
||||
let cmd = unwords [ghcideExe, "--lsp", "--test", "--verbose", "--cwd", startDir]
|
||||
let cmd = unwords $
|
||||
[ghcideExe, "--lsp", "--test", "--verbose", "--cwd", startDir] ++ extraOptions
|
||||
-- HIE calls getXgdDirectory which assumes that HOME is set.
|
||||
-- Only sets HOME if it wasn't already set.
|
||||
setEnv "HOME" "/homeless-shelter" False
|
||||
|
||||
@ -11,9 +11,11 @@ module Development.IDE.Test
|
||||
, expectDiagnostics
|
||||
, expectDiagnosticsWithTags
|
||||
, expectNoMoreDiagnostics
|
||||
, expectCurrentDiagnostics
|
||||
, checkDiagnosticsForDoc
|
||||
, canonicalizeUri
|
||||
, standardizeQuotes
|
||||
) where
|
||||
,flushMessages) where
|
||||
|
||||
import Control.Applicative.Combinators
|
||||
import Control.Lens hiding (List)
|
||||
@ -78,12 +80,21 @@ expectNoMoreDiagnostics timeout = do
|
||||
liftIO $ assertFailure $
|
||||
"Got unexpected diagnostics for " <> show fileUri <>
|
||||
" got " <> show actual
|
||||
handleCustomMethodResponse =
|
||||
-- the CustomClientMethod triggers a RspCustomServer
|
||||
-- handle that and then exit
|
||||
void (LspTest.message :: Session CustomResponse)
|
||||
ignoreOthers = void anyMessage >> handleMessages
|
||||
|
||||
handleCustomMethodResponse :: Session ()
|
||||
handleCustomMethodResponse =
|
||||
-- the CustomClientMethod triggers a RspCustomServer
|
||||
-- handle that and then exit
|
||||
void (LspTest.message :: Session CustomResponse)
|
||||
|
||||
flushMessages :: Session ()
|
||||
flushMessages = do
|
||||
void $ sendRequest (CustomClientMethod "non-existent-method") ()
|
||||
handleCustomMethodResponse <|> ignoreOthers
|
||||
where
|
||||
ignoreOthers = void anyMessage >> flushMessages
|
||||
|
||||
-- | It is not possible to use 'expectDiagnostics []' to assert the absence of diagnostics,
|
||||
-- only that existing diagnostics have been cleared.
|
||||
--
|
||||
@ -94,42 +105,67 @@ expectDiagnostics
|
||||
= expectDiagnosticsWithTags
|
||||
. map (second (map (\(ds, c, t) -> (ds, c, t, Nothing))))
|
||||
|
||||
expectDiagnosticsWithTags :: [(FilePath, [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)])] -> Session ()
|
||||
expectDiagnosticsWithTags [] = do
|
||||
diagsNot <- skipManyTill anyMessage diagnostic
|
||||
let actual = diagsNot ^. params . diagnostics
|
||||
unwrapDiagnostic :: PublishDiagnosticsNotification -> (Uri, List Diagnostic)
|
||||
unwrapDiagnostic diagsNot = (diagsNot^.params.uri, diagsNot^.params.diagnostics)
|
||||
|
||||
expectDiagnosticsWithTags :: [(String, [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)])] -> Session ()
|
||||
expectDiagnosticsWithTags expected = do
|
||||
let f = getDocUri >=> liftIO . canonicalizeUri >=> pure . toNormalizedUri
|
||||
next = unwrapDiagnostic <$> skipManyTill anyMessage diagnostic
|
||||
expected' <- Map.fromListWith (<>) <$> traverseOf (traverse . _1) f expected
|
||||
expectDiagnosticsWithTags' next expected'
|
||||
|
||||
expectDiagnosticsWithTags' ::
|
||||
MonadIO m =>
|
||||
m (Uri, List Diagnostic) ->
|
||||
Map.Map NormalizedUri [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)] ->
|
||||
m ()
|
||||
expectDiagnosticsWithTags' next m | null m = do
|
||||
(_,actual) <- next
|
||||
case actual of
|
||||
List [] ->
|
||||
return ()
|
||||
_ ->
|
||||
liftIO $ assertFailure $ "Got unexpected diagnostics:" <> show actual
|
||||
expectDiagnosticsWithTags expected = do
|
||||
let f = getDocUri >=> liftIO . canonicalizeUri >=> pure . toNormalizedUri
|
||||
expected' <- Map.fromListWith (<>) <$> traverseOf (traverse . _1) f expected
|
||||
go expected'
|
||||
where
|
||||
go m
|
||||
| Map.null m = pure ()
|
||||
| otherwise = do
|
||||
diagsNot <- skipManyTill anyMessage diagnostic
|
||||
let fileUri = diagsNot ^. params . uri
|
||||
canonUri <- liftIO $ toNormalizedUri <$> canonicalizeUri fileUri
|
||||
case Map.lookup canonUri m of
|
||||
Nothing -> do
|
||||
let actual = diagsNot ^. params . diagnostics
|
||||
liftIO $ assertFailure $
|
||||
"Got diagnostics for " <> show fileUri <>
|
||||
" but only expected diagnostics for " <> show (Map.keys m) <>
|
||||
" got " <> show actual
|
||||
Just expected -> do
|
||||
let actual = diagsNot ^. params . diagnostics
|
||||
liftIO $ mapM_ (requireDiagnostic actual) expected
|
||||
liftIO $ unless (length expected == length actual) $
|
||||
assertFailure $
|
||||
"Incorrect number of diagnostics for " <> show fileUri <>
|
||||
", expected " <> show expected <>
|
||||
" but got " <> show actual
|
||||
go $ Map.delete canonUri m
|
||||
|
||||
expectDiagnosticsWithTags' next expected = go expected
|
||||
where
|
||||
go m
|
||||
| Map.null m = pure ()
|
||||
| otherwise = do
|
||||
(fileUri, actual) <- next
|
||||
canonUri <- liftIO $ toNormalizedUri <$> canonicalizeUri fileUri
|
||||
case Map.lookup canonUri m of
|
||||
Nothing -> do
|
||||
liftIO $
|
||||
assertFailure $
|
||||
"Got diagnostics for " <> show fileUri
|
||||
<> " but only expected diagnostics for "
|
||||
<> show (Map.keys m)
|
||||
<> " got "
|
||||
<> show actual
|
||||
Just expected -> do
|
||||
liftIO $ mapM_ (requireDiagnostic actual) expected
|
||||
liftIO $
|
||||
unless (length expected == length actual) $
|
||||
assertFailure $
|
||||
"Incorrect number of diagnostics for " <> show fileUri
|
||||
<> ", expected "
|
||||
<> show expected
|
||||
<> " but got "
|
||||
<> show actual
|
||||
go $ Map.delete canonUri m
|
||||
|
||||
expectCurrentDiagnostics :: TextDocumentIdentifier -> [(DiagnosticSeverity, Cursor, T.Text)] -> Session ()
|
||||
expectCurrentDiagnostics doc expected = do
|
||||
diags <- getCurrentDiagnostics doc
|
||||
checkDiagnosticsForDoc doc expected diags
|
||||
|
||||
checkDiagnosticsForDoc :: 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)]
|
||||
nuri = toNormalizedUri _uri
|
||||
expectDiagnosticsWithTags' (return $ (_uri, List obtained)) expected'
|
||||
|
||||
canonicalizeUri :: Uri -> IO Uri
|
||||
canonicalizeUri uri = filePathToUri <$> canonicalizePath (fromJust (uriToFilePath uri))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user