Merge branch 'haskell:master' into cabal-add-codeaction

Author: VenInf

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

@@ -29,6 +29,7 @@ import           Development.IDE.Graph
 import           Control.Concurrent.STM.Stats             (atomically,
                                                            modifyTVar')
 import           Data.Aeson                               (toJSON)
+import qualified Data.Aeson                               as Aeson
 import qualified Data.ByteString                          as BS
 import           Data.Maybe                               (catMaybes)
 import           Development.IDE.Core.ProgressReporting

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

@@ -73,7 +73,8 @@ module Development.IDE.Core.Shake(
     garbageCollectDirtyKeysOlderThan,
     Log(..),
     VFSModified(..), getClientConfigAction,
-    ThreadQueue(..)
+    ThreadQueue(..),
+    runWithSignal
     ) where
 
 import           Control.Concurrent.Async
@@ -123,6 +124,10 @@ import           Development.IDE.Core.FileUtils         (getModTime)
 import           Development.IDE.Core.PositionMapping
 import           Development.IDE.Core.ProgressReporting
 import           Development.IDE.Core.RuleTypes
+import           Development.IDE.Types.Options          as Options
+import qualified Language.LSP.Protocol.Message          as LSP
+import qualified Language.LSP.Server                    as LSP
+
 import           Development.IDE.Core.Tracing
 import           Development.IDE.Core.WorkerThread
 import           Development.IDE.GHC.Compat             (NameCache,
@@ -147,11 +152,11 @@ import qualified Development.IDE.Types.Exports          as ExportsMap
 import           Development.IDE.Types.KnownTargets
 import           Development.IDE.Types.Location
 import           Development.IDE.Types.Monitoring       (Monitoring (..))
-import           Development.IDE.Types.Options
 import           Development.IDE.Types.Shake
 import qualified Focus
 import           GHC.Fingerprint
 import           GHC.Stack                              (HasCallStack)
+import           GHC.TypeLits                           (KnownSymbol)
 import           HieDb.Types
 import           Ide.Logger                             hiding (Priority)
 import qualified Ide.Logger                             as Logger
@@ -165,7 +170,6 @@ import qualified Language.LSP.Protocol.Lens             as L
 import           Language.LSP.Protocol.Message
 import           Language.LSP.Protocol.Types
 import qualified Language.LSP.Protocol.Types            as LSP
-import qualified Language.LSP.Server                    as LSP
 import           Language.LSP.VFS                       hiding (start)
 import qualified "list-t" ListT
 import           OpenTelemetry.Eventlog                 hiding (addEvent)
@@ -1350,29 +1354,28 @@ updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnosti
         let uri' = filePathToUri' fp
         let delay = if null newDiags then 0.1 else 0
         registerEvent debouncer delay uri' $ withTrace ("report diagnostics " <> fromString (fromNormalizedFilePath fp)) $ \tag -> do
-             join $ mask_ $ do
-                 lastPublish <- atomicallyNamed "diagnostics - publish" $ STM.focus (Focus.lookupWithDefault [] <* Focus.insert newDiags) uri' publishedDiagnostics
-                 let action = when (lastPublish /= newDiags) $ case lspEnv of
+            join $ mask_ $ do
+                lastPublish <- atomicallyNamed "diagnostics - publish" $ STM.focus (Focus.lookupWithDefault [] <* Focus.insert newDiags) uri' publishedDiagnostics
+                let action = when (lastPublish /= newDiags) $ case lspEnv of
                         Nothing -> -- Print an LSP event.
                             logWith recorder Info $ LogDiagsDiffButNoLspEnv (map (fp, ShowDiag,) newDiags)
                         Just env -> LSP.runLspT env $ do
                             liftIO $ tag "count" (show $ Prelude.length newDiags)
                             liftIO $ tag "key" (show k)
                             LSP.sendNotification SMethod_TextDocumentPublishDiagnostics $
                                 LSP.PublishDiagnosticsParams (fromNormalizedUri uri') (fmap fromIntegral ver) newDiags
-                 return action
+                return action
     where
         diagsFromRule :: Diagnostic -> Diagnostic
         diagsFromRule c@Diagnostic{_range}
             | coerce ideTesting = c & L.relatedInformation ?~
-                         [
-                        DiagnosticRelatedInformation
+                        [ DiagnosticRelatedInformation
                             (Location
                                 (filePathToUri $ fromNormalizedFilePath fp)
                                 _range
                             )
                             (T.pack $ show k)
-                            ]
+                        ]
             | otherwise = c
 
 
@@ -1444,3 +1447,19 @@ updatePositionMappingHelper ver changes mappingForUri = snd $
         EM.mapAccumRWithKey (\acc _k (delta, _) -> let new = addOldDelta delta acc in (new, (delta, acc)))
             zeroMapping
             (EM.insert ver (mkDelta changes, zeroMapping) mappingForUri)
+
+-- | sends a signal whenever shake session is run/restarted
+-- being used in cabal and hlint plugin tests to know when its time
+-- to look for file diagnostics
+kickSignal :: KnownSymbol s => Bool -> Maybe (LSP.LanguageContextEnv c) -> [NormalizedFilePath] -> Proxy s -> Action ()
+kickSignal testing lspEnv files msg = when testing $ liftIO $ mRunLspT lspEnv $
+  LSP.sendNotification (LSP.SMethod_CustomMethod msg) $
+  toJSON $ map fromNormalizedFilePath files
+
+-- | Add kick start/done signal to rule
+runWithSignal :: (KnownSymbol s0, KnownSymbol s1, IdeRule k v) => Proxy s0 -> Proxy s1 -> [NormalizedFilePath] -> k -> Action ()
+runWithSignal msgStart msgEnd files rule = do
+  ShakeExtras{ideTesting = Options.IdeTesting testing, lspEnv} <- getShakeExtras
+  kickSignal testing lspEnv files msgStart
+  void $ uses rule files
+  kickSignal testing lspEnv files msgEnd

haskell-language-server.cabal

@@ -246,6 +246,7 @@ library hls-cabal-plugin
     Ide.Plugin.Cabal.LicenseSuggest
     Ide.Plugin.Cabal.CabalAdd
     Ide.Plugin.Cabal.Orphans
+    Ide.Plugin.Cabal.Outline
     Ide.Plugin.Cabal.Parse
 
 
@@ -289,6 +290,7 @@ test-suite hls-cabal-plugin-tests
     Completer
     Context
     Utils
+    Outline
   build-depends:
     , base
     , bytestring
@@ -722,7 +724,6 @@ library hls-hlint-plugin
     , hlint                 >= 3.5 && < 3.9
     , hls-plugin-api        == 2.9.0.1
     , lens
-    , lsp
     , mtl
     , refact
     , regex-tdfa
@@ -733,6 +734,8 @@ library hls-hlint-plugin
     , unordered-containers
     , ghc-lib-parser-ex
     , apply-refact
+    --
+    , lsp-types
 
   if flag(ghc-lib)
     cpp-options:   -DGHC_LIB

hls-test-utils/src/Test/Hls.hs

@@ -61,14 +61,17 @@ module Test.Hls
     WithPriority(..),
     Recorder,
     Priority(..),
-    TestConfig(..),
+    captureKickDiagnostics,
+    kick,
+    TestConfig(..)
     )
 where
 
 import           Control.Applicative.Combinators
 import           Control.Concurrent.Async                 (async, cancel, wait)
 import           Control.Concurrent.Extra
 import           Control.Exception.Safe
+import           Control.Lens                             ((^.))
 import           Control.Lens.Extras                      (is)
 import           Control.Monad                            (guard, unless, void)
 import           Control.Monad.Extra                      (forM)
@@ -80,7 +83,7 @@ import qualified Data.Aeson                               as A
 import           Data.ByteString.Lazy                     (ByteString)
 import           Data.Default                             (Default, def)
 import qualified Data.Map                                 as M
-import           Data.Maybe                               (fromMaybe)
+import           Data.Maybe                               (fromMaybe, mapMaybe)
 import           Data.Proxy                               (Proxy (Proxy))
 import qualified Data.Text                                as T
 import qualified Data.Text.Lazy                           as TL
@@ -114,6 +117,7 @@ import           Ide.PluginUtils                          (idePluginsToPluginDes
                                                            pluginDescToIdePlugins)
 import           Ide.Types
 import           Language.LSP.Protocol.Capabilities
+import qualified Language.LSP.Protocol.Lens               as L
 import           Language.LSP.Protocol.Message
 import qualified Language.LSP.Protocol.Message            as LSP
 import           Language.LSP.Protocol.Types              hiding (Null)
@@ -231,14 +235,14 @@ goldenWithTestConfig
   :: Pretty b
   => TestConfig b
   -> TestName
-  -> FilePath
+  -> VirtualFileTree
   -> FilePath
   -> FilePath
   -> FilePath
   -> (TextDocumentIdentifier -> Session ())
   -> TestTree
-goldenWithTestConfig config title testDataDir path desc ext act =
-  goldenGitDiff title (testDataDir </> path <.> desc <.> ext)
+goldenWithTestConfig config title tree path desc ext act =
+  goldenGitDiff title (vftOriginalRoot tree </> path <.> desc <.> ext)
   $ runSessionWithTestConfig config $ const
   $ TL.encodeUtf8 . TL.fromStrict
   <$> do
@@ -869,6 +873,17 @@ setHlsConfig config = do
   -- requests!
   skipManyTill anyMessage (void configurationRequest)
 
+captureKickDiagnostics :: Session () -> Session () -> Session [Diagnostic]
+captureKickDiagnostics start done = do
+    _ <- skipManyTill anyMessage start
+    messages <- manyTill anyMessage done
+    pure $ concat $ mapMaybe diagnostics messages
+    where
+        diagnostics :: FromServerMessage' a -> Maybe [Diagnostic]
+        diagnostics = \msg -> case msg of
+            FromServerMess SMethod_TextDocumentPublishDiagnostics diags -> Just (diags ^. L.params . L.diagnostics)
+            _ -> Nothing
+
 waitForKickDone :: Session ()
 waitForKickDone = void $ skipManyTill anyMessage nonTrivialKickDone
 
@@ -881,9 +896,11 @@ nonTrivialKickDone = kick (Proxy @"kick/done") >>= guard . not . null
 nonTrivialKickStart :: Session ()
 nonTrivialKickStart = kick (Proxy @"kick/start") >>= guard . not . null
 
+
 kick :: KnownSymbol k => Proxy k -> Session [FilePath]
 kick proxyMsg = do
   NotMess TNotificationMessage{_params} <- customNotification proxyMsg
   case fromJSON _params of
     Success x -> return x
     other     -> error $ "Failed to parse kick/done details: " <> show other
+

plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs

@@ -41,6 +41,7 @@ import qualified Ide.Plugin.Cabal.Diagnostics                as Diagnostics
 import qualified Ide.Plugin.Cabal.FieldSuggest               as FieldSuggest
 import qualified Ide.Plugin.Cabal.LicenseSuggest             as LicenseSuggest
 import           Ide.Plugin.Cabal.Orphans                    ()
+import           Ide.Plugin.Cabal.Outline
 import qualified Ide.Plugin.Cabal.Parse                      as Parse
 import           Ide.Types
 import qualified Language.LSP.Protocol.Lens                  as JL
@@ -111,6 +112,7 @@ descriptor recorder plId =
         mconcat
           [ mkPluginHandler LSP.SMethod_TextDocumentCodeAction licenseSuggestCodeAction
           , mkPluginHandler LSP.SMethod_TextDocumentCompletion $ completion recorder
+          , mkPluginHandler LSP.SMethod_TextDocumentDocumentSymbol moduleOutline
           , mkPluginHandler LSP.SMethod_TextDocumentCodeAction $ fieldSuggestCodeAction recorder
           ]
     , pluginNotificationHandlers =
@@ -250,7 +252,7 @@ function invocation.
 kick :: Action ()
 kick = do
   files <- HashMap.keys <$> getCabalFilesOfInterestUntracked
-  void $ uses Types.ParseCabalFile files
+  Shake.runWithSignal (Proxy @"kick/start/cabal") (Proxy @"kick/done/cabal") files Types.ParseCabalFile
 
 -- ----------------------------------------------------------------
 -- Code Actions

plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/CabalFields.hs

@@ -1,4 +1,4 @@
-module Ide.Plugin.Cabal.Completion.CabalFields (findStanzaForColumn, findFieldSection, getOptionalSectionName, getAnnotation, getFieldName) where
+module Ide.Plugin.Cabal.Completion.CabalFields (findStanzaForColumn, findFieldSection, getOptionalSectionName, getAnnotation, getFieldName, onelineSectionArgs) where
 
 import           Data.List.NonEmpty                (NonEmpty)
 import qualified Data.List.NonEmpty                as NE
@@ -66,3 +66,19 @@ getOptionalSectionName (x:xs) = case x of
     Syntax.SecArgName _ name -> Just (T.decodeUtf8 name)
     _                        -> getOptionalSectionName xs
 
+
+-- | Makes a single text line out of multiple
+--   @SectionArg@s. Allows to display conditions,
+--   flags, etc in one line, which is easier to read.
+--
+--   For example, @flag@ @(@ @pedantic@ @)@ will be joined in
+--   one line, instead of four @SectionArg@s separately.
+onelineSectionArgs :: [Syntax.SectionArg Syntax.Position] -> T.Text
+onelineSectionArgs sectionArgs = joinedName
+  where
+    joinedName = T.unwords $ map getName sectionArgs
+
+    getName :: Syntax.SectionArg Syntax.Position -> T.Text
+    getName (Syntax.SecArgName _ identifier)  = T.decodeUtf8 identifier
+    getName (Syntax.SecArgStr _ quotedString) = T.decodeUtf8 quotedString
+    getName (Syntax.SecArgOther _ string)     = T.decodeUtf8 string

plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Types.hs

@@ -180,3 +180,10 @@ lspPositionToCabalPosition :: Position -> Syntax.Position
 lspPositionToCabalPosition pos = Syntax.Position
   (fromIntegral (pos ^. JL.line) + 1)
   (fromIntegral (pos ^. JL.character) + 1)
+
+-- | Convert an 'Syntax.Position' to a LSP 'Position'.
+--
+-- Cabal Positions start their indexing at 1 while LSP starts at 0.
+-- This helper makes sure, the translation is done properly.
+cabalPositionToLSPPosition :: Syntax.Position -> Position
+cabalPositionToLSPPosition (Syntax.Position start end) = Position (toEnum start -1) (toEnum end -1)