ghcide 0.6.0.1 → 0.6.0.2

raw patch · 17 files changed

+457/−322 lines, 17 filesdep +case-insensitivePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: case-insensitive

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• bench/lib/Experiments.hs +7/−1
• exe/Arguments.hs +2/−0
• exe/Main.hs +11/−1
• ghcide.cabal +3/−2
• src/Development/IDE.hs +0/−1
• src/Development/IDE/Core/FileStore.hs +0/−10
• src/Development/IDE/Core/RuleTypes.hs +52/−0
• src/Development/IDE/Core/Rules.hs +25/−13
• src/Development/IDE/Core/Service.hs +1/−1
• src/Development/IDE/Core/Shake.hs +32/−75
• src/Development/IDE/Core/Tracing.hs +7/−3
• src/Development/IDE/Plugin/CodeAction.hs +24/−57
• src/Development/IDE/Plugin/Completions/Logic.hs +4/−16
• src/Development/IDE/Plugin/Test.hs +37/−3
• test/exe/Main.hs +168/−109
• test/src/Development/IDE/Test.hs +79/−30

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

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

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

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

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

@@ -28,7 +28,6 @@     ShakeExtras,     IdeRule,     define, defineEarlyCutoff,-    GetModificationTime(GetModificationTime),     use, useNoFile, uses, useWithStale, useWithStaleFast, useWithStaleFast',     FastResult(..),     use_, useNoFile_, uses_, useWithStale_,

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

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

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

@@ -13,7 +13,7 @@     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 @@     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) ->

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

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

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

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

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

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