diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ +### 0.6.0.2 (2020-12-26) +* Fix disappearing diagnostics bug (#959) - (Pepe Iborra) +* Use qualified module name from diagnostics in suggestNewImport (#945) - (Potato Hatsue) +* Disable auto extend import snippets in completions (these need a bit more work) + ### 0.6.0.1 (2020-12-13) * Fix build with GHC 8.8.2 and 8.8.3 - (Javier Neira) * Update old URLs still pointing to digital-asset - (Jan Hrcek) diff --git a/bench/lib/Experiments.hs b/bench/lib/Experiments.hs --- a/bench/lib/Experiments.hs +++ b/bench/lib/Experiments.hs @@ -115,7 +115,13 @@ ) ( \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) ) ] diff --git a/exe/Arguments.hs b/exe/Arguments.hs --- a/exe/Arguments.hs +++ b/exe/Arguments.hs @@ -14,6 +14,7 @@ ,argsShakeProfiling :: Maybe FilePath ,argsOTMemoryProfiling :: Bool ,argsTesting :: Bool + ,argsDisableKick :: Bool ,argsThreads :: Int ,argsVerbose :: Bool } @@ -35,5 +36,6 @@ <*> 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") diff --git a/exe/Main.hs b/exe/Main.hs --- a/exe/Main.hs +++ b/exe/Main.hs @@ -118,7 +118,15 @@ } 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 @@ -150,6 +158,8 @@ -- , optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling , optTesting = IdeTesting argsTesting , optThreads = argsThreads + , optCheckParents = NeverCheck + , optCheckProject = CheckProject False } logLevel = if argsVerbose then minBound else Info ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) dummyWithProg (const (const id)) (logger logLevel) debouncer options vfs diff --git a/ghcide.cabal b/ghcide.cabal --- a/ghcide.cabal +++ b/ghcide.cabal @@ -2,7 +2,7 @@ build-type: Simple category: Development name: ghcide -version: 0.6.0.1 +version: 0.6.0.2 license: Apache-2.0 license-file: LICENSE author: Digital Asset and Ghcide contributors @@ -41,6 +41,7 @@ base == 4.*, binary, bytestring, + case-insensitive, containers, data-default, deepseq, @@ -149,6 +150,7 @@ Development.IDE.LSP.Protocol Development.IDE.LSP.Server Development.IDE.Spans.Common + Development.IDE.Spans.Documentation Development.IDE.Spans.AtPoint Development.IDE.Spans.LocalBindings Development.IDE.Types.Diagnostics @@ -183,7 +185,6 @@ Development.IDE.GHC.Warnings Development.IDE.Import.FindImports Development.IDE.LSP.Notifications - Development.IDE.Spans.Documentation Development.IDE.Plugin.CodeAction.PositionIndexed Development.IDE.Plugin.CodeAction.Rules Development.IDE.Plugin.CodeAction.RuleTypes diff --git a/src/Development/IDE.hs b/src/Development/IDE.hs --- a/src/Development/IDE.hs +++ b/src/Development/IDE.hs @@ -28,7 +28,6 @@ ShakeExtras, IdeRule, define, defineEarlyCutoff, - GetModificationTime(GetModificationTime), use, useNoFile, uses, useWithStale, useWithStaleFast, useWithStaleFast', FastResult(..), use_, useNoFile_, uses_, useWithStale_, diff --git a/src/Development/IDE/Core/FileStore.hs b/src/Development/IDE/Core/FileStore.hs --- a/src/Development/IDE/Core/FileStore.hs +++ b/src/Development/IDE/Core/FileStore.hs @@ -28,7 +28,6 @@ import Development.Shake import Development.Shake.Classes import Control.Exception -import GHC.Generics import Data.Either.Extra import Data.Int (Int64) import Data.Time @@ -99,15 +98,6 @@ filesOfInterest <- getFilesOfInterest 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 = diff --git a/src/Development/IDE/Core/RuleTypes.hs b/src/Development/IDE/Core/RuleTypes.hs --- a/src/Development/IDE/Core/RuleTypes.hs +++ b/src/Development/IDE/Core/RuleTypes.hs @@ -2,6 +2,7 @@ -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DerivingStrategies #-} @@ -37,6 +38,8 @@ 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) @@ -189,6 +192,55 @@ -- | Get a module interface details, without the Linkable -- 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) diff --git a/src/Development/IDE/Core/Rules.hs b/src/Development/IDE/Core/Rules.hs --- a/src/Development/IDE/Core/Rules.hs +++ b/src/Development/IDE/Core/Rules.hs @@ -553,16 +553,18 @@ getDocMapRule :: Rules () getDocMapRule = define $ \GetDocMap file -> do - (tmrTypechecked -> tc,_) <- useWithStale_ TypeCheck file - (hscEnv -> hsc,_) <-useWithStale_ GhcSessionDeps file - (refMap -> rf, _) <- useWithStale_ GetHieAst file + -- Stale data for the scenario where a broken module has previously typechecked + -- but we never generated a DocMap for it + (tmrTypechecked -> tc, _) <- useWithStale_ TypeCheck file + (hscEnv -> hsc, _) <- useWithStale_ GhcSessionDeps file + (refMap -> rf, _) <- useWithStale_ GetHieAst file -- When possible, rely on the haddocks embedded in our interface files -- This creates problems on ghc-lib, see comment on 'getDocumentationTryGhc' #if !defined(GHC_LIB) let parsedDeps = [] #else - deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file + deps <- fromMaybe (TransitiveDependencies [] [] []) <$> use GetDependencies file let tdeps = transitiveModuleDeps deps parsedDeps <- uses_ GetParsedModule tdeps #endif @@ -664,8 +666,8 @@ ghcSessionDepsDefinition file = do env <- use_ GhcSession file let hsc = hscEnv env - ((ms,_),_) <- useWithStale_ GetModSummaryWithoutTimestamps file - (deps,_) <- useWithStale_ GetDependencies file + (ms,_) <- use_ GetModSummaryWithoutTimestamps file + deps <- use_ GetDependencies file let tdeps = transitiveModuleDeps deps uses_th_qq = xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags @@ -732,7 +734,7 @@ 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)) @@ -740,16 +742,18 @@ 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 @@ -759,7 +763,7 @@ , 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) @@ -894,7 +898,15 @@ needsCompilationRule :: Rules () needsCompilationRule = defineEarlyCutoff $ \NeedsCompilation file -> do - ((ms,_),_) <- useWithStale_ GetModSummaryWithoutTimestamps file + -- It's important to use stale data here to avoid wasted work. + -- if NeedsCompilation fails for a module M its result will be under-approximated + -- to False in its dependencies. However, if M actually used TH, this will + -- cause a re-evaluation of GetModIface for all dependencies + -- (since we don't need to generate object code anymore). + -- Once M is fixed we will discover that we actually needed all the object code + -- that we just threw away, and thus have to recompile all dependencies once + -- again, this time keeping the object code. + (ms,_) <- fst <$> useWithStale_ GetModSummaryWithoutTimestamps file -- A file needs object code if it uses TemplateHaskell or any file that depends on it uses TemplateHaskell res <- if uses_th_qq ms diff --git a/src/Development/IDE/Core/Service.hs b/src/Development/IDE/Core/Service.hs --- a/src/Development/IDE/Core/Service.hs +++ b/src/Development/IDE/Core/Service.hs @@ -13,7 +13,7 @@ IdeState, initialise, shutdown, runAction, writeProfile, - getDiagnostics, unsafeClearDiagnostics, + getDiagnostics, ideLogger, updatePositionMapping, ) where diff --git a/src/Development/IDE/Core/Shake.hs b/src/Development/IDE/Core/Shake.hs --- a/src/Development/IDE/Core/Shake.hs +++ b/src/Development/IDE/Core/Shake.hs @@ -7,7 +7,6 @@ {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE PatternSynonyms #-} -- | A Shake implementation of the compiler service. -- @@ -38,7 +37,7 @@ 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.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 NameCache import UniqSupply import PrelInfo -import Data.Int (Int64) import Language.Haskell.LSP.Types.Capabilities import OpenTelemetry.Eventlog @@ -502,7 +501,7 @@ -- | 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 @@ 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 @@ -830,7 +824,7 @@ :: IdeRule k v => (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v)) -> Rules () -defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file $ do +defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file isSuccess $ do extras@ShakeExtras{state, inProgress} <- getShakeExtras -- don't do progress for GetFileExists, as there are lots of non-nodes for just that one key (if show key == "GetFileExists" then id else withProgressVar inProgress file) $ do @@ -880,8 +874,9 @@ -- least 1000 modifications. where f shift = modifyVar_ var $ \x -> evaluate $ HMap.insertWith (\_ x -> shift x) file (shift 0) x - - +isSuccess :: RunResult (A v) -> Bool +isSuccess (RunResult _ _ (A Failed)) = False +isSuccess _ = True -- | Rule type, input file data QDisk k = QDisk k NormalizedFilePath @@ -997,25 +992,19 @@ 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 @@ -1050,45 +1039,6 @@ 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 @@ -1096,31 +1046,38 @@ -- | 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 -> [FileDiagnostic] 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) -> diff --git a/src/Development/IDE/Core/Tracing.hs b/src/Development/IDE/Core/Tracing.hs --- a/src/Development/IDE/Core/Tracing.hs +++ b/src/Development/IDE/Core/Tracing.hs @@ -13,7 +13,7 @@ readVar, threadDelay) import Control.Exception (evaluate) import Control.Exception.Safe (catch, SomeException) -import Control.Monad (forM_, forever, (>=>)) +import Control.Monad (unless, forM_, forever, (>=>)) import Control.Monad.Extra (whenJust) import Control.Seq (r0, seqList, seqTuple2, using) import Data.Dynamic (Dynamic) @@ -56,16 +56,20 @@ :: Show k => k -- ^ The Action's Key -> NormalizedFilePath -- ^ Path to the file the action was run for + -> (a -> Bool) -- ^ Did this action succeed? -> Action a -- ^ The action -> Action a -otTracedAction key file act = actionBracket +otTracedAction key file success act = actionBracket (do sp <- beginSpan (fromString (show key)) setTag sp "File" (fromString $ fromNormalizedFilePath file) return sp ) endSpan - (const act) + (\sp -> do + res <- act + unless (success res) $ setTag sp "error" "1" + return res) startTelemetry :: Logger -> Var Values -> IO () startTelemetry logger stateRef = do diff --git a/src/Development/IDE/Plugin/CodeAction.hs b/src/Development/IDE/Plugin/CodeAction.hs --- a/src/Development/IDE/Plugin/CodeAction.hs +++ b/src/Development/IDE/Plugin/CodeAction.hs @@ -49,10 +49,8 @@ import Data.Maybe import Data.List.Extra import qualified Data.Text as T -import Data.Tuple.Extra ((&&&)) import Text.Regex.TDFA (mrAfter, (=~), (=~~)) import Outputable (ppr, showSDocUnsafe) -import GHC.LanguageExtensions.Type (Extension) import Data.Function import Control.Arrow ((>>>)) import Data.Functor @@ -157,8 +155,7 @@ -> [(T.Text, [TextEdit])] suggestAction packageExports ideOptions parsedModule text diag = concat -- Order these suggestions by priority - [ suggestAddExtension diag -- Highest priority - , suggestSignature True diag + [ suggestSignature True diag , suggestExtendImport packageExports text diag , suggestFillTypeWildcard diag , suggestFixConstructorImport text diag @@ -518,40 +515,6 @@ = [("Use type signature: ‘" <> typeSignature <> "’", [TextEdit _range typeSignature])] | otherwise = [] -suggestAddExtension :: Diagnostic -> [(T.Text, [TextEdit])] -suggestAddExtension Diagnostic{_range=_range,..} --- File.hs:22:8: error: --- Illegal lambda-case (use -XLambdaCase) --- File.hs:22:6: error: --- Illegal view pattern: x -> foo --- Use ViewPatterns to enable view patterns --- File.hs:26:8: error: --- Illegal `..' in record pattern --- Use RecordWildCards to permit this --- File.hs:53:28: error: --- Illegal tuple section: use TupleSections --- File.hs:238:29: error: --- * Can't make a derived instance of `Data FSATrace': --- You need DeriveDataTypeable to derive an instance for this class --- * In the data declaration for `FSATrace' --- C:\Neil\shake\src\Development\Shake\Command.hs:515:31: error: --- * Illegal equational constraint a ~ () --- (Use GADTs or TypeFamilies to permit this) --- * In the context: a ~ () --- While checking an instance declaration --- In the instance declaration for `Unit (m a)' - | exts@(_:_) <- filter (`Map.member` ghcExtensions) $ T.split (not . isAlpha) $ T.replace "-X" "" _message - = [("Add " <> x <> " extension", [TextEdit (Range (Position 0 0) (Position 0 0)) $ "{-# LANGUAGE " <> x <> " #-}\n"]) | x <- exts] - | otherwise = [] - --- | All the GHC extensions -ghcExtensions :: Map.HashMap T.Text Extension -ghcExtensions = Map.fromList . filter notStrictFlag . map ( ( T.pack . flagSpecName ) &&& flagSpecFlag ) $ xFlags - where - -- Strict often causes false positives, as in Data.Map.Strict imports. - -- See discussion at https://github.com/haskell/ghcide/pull/638 - notStrictFlag (name, _) = name /= "Strict" - suggestModuleTypo :: Diagnostic -> [(T.Text, [TextEdit])] suggestModuleTypo Diagnostic{_range=_range,..} -- src/Development/IDE/Core/Compile.hs:58:1: error: @@ -648,7 +611,7 @@ | Just (binding, mod_srcspan) <- matchRegExMultipleImports _message , Just c <- contents - = mod_srcspan >>= (\(x, y) -> suggestions c binding x y) + = mod_srcspan >>= (\(x, y) -> suggestions c binding x y) | otherwise = [] where suggestions c binding mod srcspan @@ -659,12 +622,9 @@ importLine <- textInRange range c, Just ident <- lookupExportMap binding mod, Just result <- addBindingToImportList ident importLine - = [("Add " <> renderImport ident <> " to the import list of " <> mod, [TextEdit range result])] + = [("Add " <> renderIdentInfo ident <> " to the import list of " <> mod, [TextEdit range result])] | otherwise = [] - renderImport IdentInfo {parent, rendered} - | Just p <- parent = p <> "(" <> rendered <> ")" - | otherwise = rendered - lookupExportMap binding mod + lookupExportMap binding mod | Just match <- Map.lookup binding (getExportsMap exportsMap) , [(ident, _)] <- filter (\(_,m) -> mod == m) (Set.toList match) = Just ident @@ -936,7 +896,8 @@ suggestNewImport :: ExportsMap -> ParsedModule -> Diagnostic -> [(T.Text, [TextEdit])] suggestNewImport packageExportsMap ParsedModule {pm_parsed_source = L _ HsModule {..}} Diagnostic{_message} | msg <- unifySpaces _message - , Just name <- extractNotInScopeName msg + , Just thingMissing <- extractNotInScopeName msg + , qual <- extractQualifiedModuleName msg , Just insertLine <- case hsmodImports of [] -> case srcSpanStart $ getLoc (head hsmodDecls) of RealSrcLoc s -> Just $ srcLocLine s - 1 @@ -948,15 +909,16 @@ , extendImportSuggestions <- matchRegexUnifySpaces msg "Perhaps you want to add ‘[^’]*’ to the import list in the import of ‘([^’]*)’" = [(imp, [TextEdit (Range insertPos insertPos) (imp <> "\n")]) - | imp <- sort $ constructNewImportSuggestions packageExportsMap name extendImportSuggestions + | imp <- sort $ constructNewImportSuggestions packageExportsMap (qual, thingMissing) extendImportSuggestions ] suggestNewImport _ _ _ = [] constructNewImportSuggestions - :: ExportsMap -> NotInScope -> Maybe [T.Text] -> [T.Text] -constructNewImportSuggestions exportsMap thingMissing notTheseModules = nubOrd + :: ExportsMap -> (Maybe T.Text, NotInScope) -> Maybe [T.Text] -> [T.Text] +constructNewImportSuggestions exportsMap (qual, thingMissing) notTheseModules = nubOrd [ suggestion - | (identInfo, m) <- maybe [] Set.toList $ Map.lookup name (getExportsMap exportsMap) + | Just name <- [T.stripPrefix (maybe "" (<> ".") qual) $ notInScope thingMissing] + , (identInfo, m) <- maybe [] Set.toList $ Map.lookup name (getExportsMap exportsMap) , canUseIdent thingMissing identInfo , m `notElem` fromMaybe [] notTheseModules , suggestion <- renderNewImport identInfo m @@ -967,16 +929,9 @@ , asQ <- if q == m then "" else " as " <> q = ["import qualified " <> m <> asQ] | otherwise - = ["import " <> m <> " (" <> importWhat identInfo <> ")" + = ["import " <> m <> " (" <> renderIdentInfo identInfo <> ")" ,"import " <> m ] - (qual, name) = case T.splitOn "." (notInScope thingMissing) of - [n] -> (Nothing, n) - segments -> (Just (T.intercalate "." $ init segments), last segments) - importWhat IdentInfo {parent, rendered} - | Just p <- parent = p <> "(" <> rendered <> ")" - | otherwise = rendered - canUseIdent :: NotInScope -> IdentInfo -> Bool canUseIdent NotInScopeDataConstructor{} = isDatacon canUseIdent _ = const True @@ -1009,6 +964,13 @@ | otherwise = Nothing +extractQualifiedModuleName :: T.Text -> Maybe T.Text +extractQualifiedModuleName x + | Just [m] <- matchRegexUnifySpaces x "module named [^‘]*‘([^’]*)’" + = Just m + | otherwise + = Nothing + ------------------------------------------------------------------------------------------------- @@ -1208,3 +1170,8 @@ _ -> Nothing imps <- regExImports imports return (binding, imps) + +renderIdentInfo :: IdentInfo -> T.Text +renderIdentInfo IdentInfo {parent, rendered} + | Just p <- parent = p <> "(" <> rendered <> ")" + | otherwise = rendered diff --git a/src/Development/IDE/Plugin/Completions/Logic.hs b/src/Development/IDE/Plugin/Completions/Logic.hs --- a/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/src/Development/IDE/Plugin/Completions/Logic.hs @@ -29,7 +29,6 @@ import Packages #if MIN_GHC_API_VERSION(8,10,0) import Predicate (isDictTy) -import GHC.Platform import Pair import Coercion #endif @@ -288,10 +287,6 @@ let dflags = hsc_dflags packageState curModName = moduleName curMod - importMap = Map.fromList [ - (getLoc imp, imp) - | imp <- limports ] - iDeclToModName :: ImportDecl name -> ModuleName iDeclToModName = unLoc . ideclName @@ -320,8 +315,7 @@ (, mempty) <$> toCompItem curMod curModName n Nothing getComplsForOne (GRE n _ False prov) = flip foldMapM (map is_decl prov) $ \spec -> do - let originalImportDecl = Map.lookup (is_dloc spec) importMap - compItem <- toCompItem curMod (is_mod spec) n originalImportDecl + compItem <- toCompItem curMod (is_mod spec) n Nothing let unqual | is_qual spec = [] | otherwise = compItem @@ -560,8 +554,10 @@ result | "import " `T.isPrefixOf` fullLine = filtImportCompls + -- we leave this condition here to avoid duplications and return empty list + -- since HLS implements this completion (#haskell-language-server/pull/662) | "{-# language" `T.isPrefixOf` T.toLower fullLine - = filtOptsCompls languagesAndExts + = [] | "{-# options_ghc" `T.isPrefixOf` T.toLower fullLine = filtOptsCompls (map (T.pack . stripLeading '-') $ flagsForCompletion False) | "{-# " `T.isPrefixOf` fullLine @@ -573,14 +569,6 @@ ++ filtKeywordCompls return result - --- The supported languages and extensions -languagesAndExts :: [T.Text] -#if MIN_GHC_API_VERSION(8,10,0) -languagesAndExts = map T.pack $ GHC.supportedLanguagesAndExtensions ( PlatformMini ArchUnknown OSUnknown ) -#else -languagesAndExts = map T.pack GHC.supportedLanguagesAndExtensions -#endif -- --------------------------------------------------------------------- -- helper functions for pragmas diff --git a/src/Development/IDE/Plugin/Test.hs b/src/Development/IDE/Plugin/Test.hs --- a/src/Development/IDE/Plugin/Test.hs +++ b/src/Development/IDE/Plugin/Test.hs @@ -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 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 @@ 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) diff --git a/test/exe/Main.hs b/test/exe/Main.hs --- a/test/exe/Main.hs +++ b/test/exe/Main.hs @@ -58,7 +58,8 @@ 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 @@ -323,8 +324,11 @@ , "import {-# SOURCE #-} ModuleB" ] let contentB = T.unlines - [ "module ModuleB where" + [ "{-# OPTIONS -Wmissing-signatures#-}" + , "module ModuleB where" , "import ModuleA" + -- introduce an artificial diagnostic + , "foo = ()" ] let contentBboot = T.unlines [ "module ModuleB where" @@ -332,7 +336,7 @@ _ <- createDoc "ModuleA.hs" "haskell" contentA _ <- createDoc "ModuleB.hs" "haskell" contentB _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot - expectDiagnostics [] + expectDiagnostics [("ModuleB.hs", [(DsWarning, (3,0), "Top-level binding")])] , testSessionWait "correct reference used with hs-boot" $ do let contentB = T.unlines [ "module ModuleB where" @@ -347,7 +351,8 @@ [ "module ModuleA where" ] let contentC = T.unlines - [ "module ModuleC where" + [ "{-# OPTIONS -Wmissing-signatures #-}" + , "module ModuleC where" , "import ModuleA" -- this reference will fail if it gets incorrectly -- resolved to the hs-boot file @@ -357,7 +362,7 @@ _ <- createDoc "ModuleA.hs" "haskell" contentA _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot _ <- createDoc "ModuleC.hs" "haskell" contentC - expectDiagnostics [] + expectDiagnostics [("ModuleC.hs", [(DsWarning, (3,0), "Top-level binding")])] , testSessionWait "redundant import" $ do let contentA = T.unlines ["module ModuleA where"] let contentB = T.unlines @@ -375,13 +380,15 @@ , testSessionWait "redundant import even without warning" $ do let contentA = T.unlines ["module ModuleA where"] let contentB = T.unlines - [ "{-# OPTIONS_GHC -Wno-unused-imports #-}" + [ "{-# 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 [] + expectDiagnostics [("ModuleB.hs", [(DsWarning, (3,0), "Top-level binding")])] , testSessionWait "package imports" $ do let thisDataListContent = T.unlines [ "module Data.List where" @@ -538,8 +545,104 @@ [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")]) ] expectNoMoreDiagnostics 2 + + , testSessionWait "deduplicate missing module diagnostics" $ do + let fooContent = T.unlines [ "module Foo() where" , "import MissingModule" ] + doc <- createDoc "Foo.hs" "haskell" fooContent + expectDiagnostics [("Foo.hs", [(DsError, (1,7), "Could not find module 'MissingModule'")])] + + changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module Foo() where" ] + expectDiagnostics [] + + 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" [ renameActionTests @@ -547,7 +650,6 @@ , removeImportTests , extendImportTests , suggestImportTests - , addExtensionTests , fixConstructorImportTests , importRenameActionTests , fillTypedHoleTests @@ -1038,7 +1140,7 @@ , "import ModuleA (A(Constructor))" , "b :: A" , "b = Constructor" - ]) + ]) , testSession "extend single line import with mixed constructors" $ template [("ModuleA.hs", T.unlines [ "module ModuleA where" @@ -1203,6 +1305,7 @@ , test True [] "f :: Text" ["f = undefined"] "import Data.Text (Text)" , test True [] "f = [] & id" [] "import Data.Function ((&))" , test True [] "f = (&) [] id" [] "import Data.Function ((&))" + , test True [] "f = (.|.)" [] "import Data.Bits (Bits((.|.)))" ] ] where @@ -1230,63 +1333,6 @@ else liftIO $ [_title | CACodeAction CodeAction{_title} <- actions, _title == newImp ] @?= [] - -addExtensionTests :: TestTree -addExtensionTests = testGroup "add language extension actions" - [ testSession "add NamedFieldPuns language extension" $ template - (T.unlines - [ "module Module where" - , "" - , "data A = A { getA :: Bool }" - , "" - , "f :: A -> Bool" - , "f A { getA } = getA" - ]) - (Range (Position 0 0) (Position 0 0)) - "Add NamedFieldPuns extension" - (T.unlines - [ "{-# LANGUAGE NamedFieldPuns #-}" - , "module Module where" - , "" - , "data A = A { getA :: Bool }" - , "" - , "f :: A -> Bool" - , "f A { getA } = getA" - ]) - , testSession "add RecordWildCards language extension" $ template - (T.unlines - [ "module Module where" - , "" - , "data A = A { getA :: Bool }" - , "" - , "f :: A -> Bool" - , "f A { .. } = getA" - ]) - (Range (Position 0 0) (Position 0 0)) - "Add RecordWildCards extension" - (T.unlines - [ "{-# LANGUAGE RecordWildCards #-}" - , "module Module where" - , "" - , "data A = A { getA :: Bool }" - , "" - , "f :: A -> Bool" - , "f A { .. } = getA" - ]) - ] - where - template initialContent range expectedAction expectedContents = do - doc <- createDoc "Module.hs" "haskell" initialContent - _ <- waitForDiagnostics - CACodeAction action@CodeAction { _title = actionTitle } : _ - <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$> - getCodeActions doc range - liftIO $ expectedAction @=? actionTitle - executeCodeAction action - contentAfterAction <- documentContents doc - liftIO $ expectedContents @=? contentAfterAction - - insertNewDefinitionTests :: TestTree insertNewDefinitionTests = testGroup "insert new definition actions" [ testSession "insert new function definition" $ do @@ -2906,34 +2952,6 @@ [ ("permutations", CiFunction, "permutations ${1:[a]}", False, False, Nothing) ], completionTest - "show imports not in list - simple" - ["{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", "import Control.Monad (msum)", "f = joi"] - (Position 3 6) - [("join", CiFunction, "join ${1:m (m a)}", False, False, - Just (List [TextEdit {_range = Range {_start = Position {_line = 2, _character = 26}, _end = Position {_line = 2, _character = 26}}, _newText = "join, "}]))], - completionTest - "show imports not in list - multi-line" - ["{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", "import Control.Monad (\n msum)", "f = joi"] - (Position 4 6) - [("join", CiFunction, "join ${1:m (m a)}", False, False, - Just (List [TextEdit {_range = Range {_start = Position {_line = 3, _character = 8}, _end = Position {_line = 3, _character = 8}}, _newText = "join, "}]))], - completionTest - "show imports not in list - names with _" - ["{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", "import qualified Control.Monad as M (msum)", "f = M.mapM_"] - (Position 3 11) - [("mapM_", CiFunction, "mapM_ ${1:a -> m b} ${2:t a}", False, False, - Just (List [TextEdit {_range = Range {_start = Position {_line = 2, _character = 41}, _end = Position {_line = 2, _character = 41}}, _newText = "mapM_, "}]))], - completionTest - "show imports not in list - initial empty list" - ["{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", "import qualified Control.Monad as M ()", "f = M.joi"] - (Position 3 10) - [("join", CiFunction, "join ${1:m (m a)}", False, False, - Just (List [TextEdit {_range = Range {_start = Position {_line = 2, _character = 37}, _end = Position {_line = 2, _character = 37}}, _newText = "join, "}]))], - completionTest "dont show hidden items" [ "{-# LANGUAGE NoImplicitPrelude #-}", "module A where", @@ -2942,17 +2960,57 @@ ] (Position 3 6) [], - completionTest - "record snippet on import" - ["module A where", "import Text.Printf (FormatParse(FormatParse))", "FormatParse"] - (Position 2 10) - [("FormatParse", CiStruct, "FormatParse ", False, False, - Just (List [TextEdit {_range = Range {_start = Position {_line = 1, _character = 44}, _end = Position {_line = 1, _character = 44}}, _newText = "FormatParse, "}])), - ("FormatParse", CiConstructor, "FormatParse ${1:String} ${2:Char} ${3:String}", False, False, - Just (List [TextEdit {_range = Range {_start = Position {_line = 1, _character = 44}, _end = Position {_line = 1, _character = 44}}, _newText = "FormatParse, "}])), - ("FormatParse", CiSnippet, "FormatParse {fpModifiers=${1:_fpModifiers}, fpChar=${2:_fpChar}, fpRest=${3:_fpRest}}", False, False, - Just (List [TextEdit {_range = Range {_start = Position {_line = 1, _character = 44}, _end = Position {_line = 1, _character = 44}}, _newText = "FormatParse, "}])) + expectFailBecause "Auto import completion snippets were disabled in v0.6.0.2" $ + testGroup "auto import snippets" + [ completionTest + "show imports not in list - simple" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad (msum)", "f = joi"] + (Position 3 6) + [("join", CiFunction, "join ${1:m (m a)}", False, False, + Just (List [TextEdit {_range = Range {_start = Position {_line = 2, _character = 26}, _end = Position {_line = 2, _character = 26}}, _newText = "join, "}]))] + , completionTest + "show imports not in list - multi-line" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import Control.Monad (\n msum)", "f = joi"] + (Position 4 6) + [("join", CiFunction, "join ${1:m (m a)}", False, False, + Just (List [TextEdit {_range = Range {_start = Position {_line = 3, _character = 8}, _end = Position {_line = 3, _character = 8}}, _newText = "join, "}]))] + , completionTest + "show imports not in list - names with _" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import qualified Control.Monad as M (msum)", "f = M.mapM_"] + (Position 3 11) + [("mapM_", CiFunction, "mapM_ ${1:a -> m b} ${2:t a}", False, False, + Just (List [TextEdit {_range = Range {_start = Position {_line = 2, _character = 41}, _end = Position {_line = 2, _character = 41}}, _newText = "mapM_, "}]))] + , completionTest + "show imports not in list - initial empty list" + ["{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", "import qualified Control.Monad as M ()", "f = M.joi"] + (Position 3 10) + [("join", CiFunction, "join ${1:m (m a)}", False, False, + Just (List [TextEdit {_range = Range {_start = Position {_line = 2, _character = 37}, _end = Position {_line = 2, _character = 37}}, _newText = "join, "}]))] + , completionTest + "record snippet on import" + ["module A where", "import Text.Printf (FormatParse(FormatParse))", "FormatParse"] + (Position 2 10) + [("FormatParse", CiStruct, "FormatParse ", False, False, + Just (List [TextEdit {_range = Range {_start = Position {_line = 1, _character = 44}, _end = Position {_line = 1, _character = 44}}, _newText = "FormatParse, "}])), + ("FormatParse", CiConstructor, "FormatParse ${1:String} ${2:Char} ${3:String}", False, False, + Just (List [TextEdit {_range = Range {_start = Position {_line = 1, _character = 44}, _end = Position {_line = 1, _character = 44}}, _newText = "FormatParse, "}])), + ("FormatParse", CiSnippet, "FormatParse {fpModifiers=${1:_fpModifiers}, fpChar=${2:_fpChar}, fpRest=${3:_fpRest}}", False, False, + Just (List [TextEdit {_range = Range {_start = Position {_line = 1, _character = 44}, _end = Position {_line = 1, _character = 44}}, _newText = "FormatParse, "}])) + ] + ], + -- 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) + [] ] otherCompletionTests :: [TestTree] @@ -3682,7 +3740,7 @@ 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 @@ -3795,11 +3853,11 @@ 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 @@ -3810,7 +3868,8 @@ -- 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 diff --git a/test/src/Development/IDE/Test.hs b/test/src/Development/IDE/Test.hs --- a/test/src/Development/IDE/Test.hs +++ b/test/src/Development/IDE/Test.hs @@ -11,9 +11,11 @@ , expectDiagnostics , expectDiagnosticsWithTags , expectNoMoreDiagnostics + , expectCurrentDiagnostics + , checkDiagnosticsForDoc , canonicalizeUri , standardizeQuotes - ) where + ,flushMessages) where import Control.Applicative.Combinators import Control.Lens hiding (List) @@ -78,45 +80,92 @@ 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. +-- +-- Rather than trying to assert the absence of diagnostics, introduce an +-- expected diagnostic (e.g. a redundant import) and assert the singleton diagnostic. expectDiagnostics :: [(FilePath, [(DiagnosticSeverity, Cursor, T.Text)])] -> Session () expectDiagnostics = expectDiagnosticsWithTags . map (second (map (\(ds, c, t) -> (ds, c, t, Nothing)))) -expectDiagnosticsWithTags :: [(FilePath, [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)])] -> Session () +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 - 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' + +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' 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))