haskell/haskell-language-server
1
1
Fork 0
mirror of https://github.com/haskell/haskell-language-server.git synced 2024-09-11 08:45:35 +03:00
Code Issues Projects Releases Wiki Activity

Merge remote-tracking branch 'upstream/master' into inlay-hints-record-wildcards

Browse Source
This commit is contained in:
Jinser Kafka 2024-08-09 17:39:06 +08:00
commit 96a2550e09
No known key found for this signature in database
24 changed files with 447 additions and 92 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
docs/features.md
View File

@ -111,6 +111,7 @@ Completions for language pragmas.
## Formatting
Format your code with various Haskell code formatters.
The default Haskell code formatter is `ormolu`, and the Haskell formatter can be configured via the `formattingProvider` option.
| Formatter | Provided by |
| --------------- | ---------------------------- |
@ -119,12 +120,17 @@ Format your code with various Haskell code formatters.
| Ormolu | `hls-ormolu-plugin` |
| Stylish Haskell | `hls-stylish-haskell-plugin` |
---
Format your cabal files with a cabal code formatter.
The default cabal code formatter is `cabal-gild`, which needs to be available on the `$PATH`,
or the location needs to be explicitly provided.
To change the cabal formatter, edit the `cabalFormattingProvider` option.
| Formatter | Provided by |
|-----------------|------------------------------|
| cabal-fmt | `hls-cabal-fmt-plugin` |
| cabal-gild | `hls-cabal-gild-plugin` |
## Document symbols

1
ghcide/src/Development/IDE/Core/OfInterest.hs
View File

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

39
ghcide/src/Development/IDE/Core/Shake.hs
View File

@ -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,9 +1354,9 @@ 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
@ -1360,19 +1364,18 @@ updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnosti
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

5
haskell-language-server.cabal
View File

@ -245,6 +245,7 @@ library hls-cabal-plugin
Ide.Plugin.Cabal.FieldSuggest
Ide.Plugin.Cabal.LicenseSuggest
Ide.Plugin.Cabal.Orphans
Ide.Plugin.Cabal.Outline
Ide.Plugin.Cabal.Parse
@ -282,6 +283,7 @@ test-suite hls-cabal-plugin-tests
Completer
Context
Utils
Outline
build-depends:
, base
, bytestring
@ -714,7 +716,6 @@ library hls-hlint-plugin
, hlint >= 3.5 && < 3.9
, hls-plugin-api == 2.9.0.1
, lens
, lsp
, mtl
, refact
, regex-tdfa
@ -725,6 +726,8 @@ library hls-hlint-plugin
, unordered-containers
, ghc-lib-parser-ex
, apply-refact
--
, lsp-types
if flag(ghc-lib)
cpp-options: -DGHC_LIB

27
hls-test-utils/src/Test/Hls.hs
View File

@ -61,7 +61,9 @@ module Test.Hls
WithPriority(..),
Recorder,
Priority(..),
TestConfig(..),
captureKickDiagnostics,
kick,
TestConfig(..)
)
where
@ -69,6 +71,7 @@ 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

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

@ -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
@ -90,6 +91,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 =
@ -229,7 +231,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

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

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

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

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

119
plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Outline.hs Normal file
View File

@ -0,0 +1,119 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module Ide.Plugin.Cabal.Outline where
import Control.Monad.IO.Class
import Data.Maybe
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8)
import Development.IDE.Core.Rules
import Development.IDE.Core.Shake (IdeState (shakeExtras),
runIdeAction,
useWithStaleFast)
import Development.IDE.Types.Location (toNormalizedFilePath')
import Distribution.Fields.Field (Field (Field, Section),
Name (Name))
import Distribution.Parsec.Position (Position)
import Ide.Plugin.Cabal.Completion.CabalFields (onelineSectionArgs)
import Ide.Plugin.Cabal.Completion.Types (ParseCabalFields (..),
cabalPositionToLSPPosition)
import Ide.Plugin.Cabal.Orphans ()
import Ide.Types (PluginMethodHandler)
import Language.LSP.Protocol.Message (Method (..))
import Language.LSP.Protocol.Types (DocumentSymbol (..))
import qualified Language.LSP.Protocol.Types as LSP
moduleOutline :: PluginMethodHandler IdeState Method_TextDocumentDocumentSymbol
moduleOutline ideState _ LSP.DocumentSymbolParams {_textDocument = LSP.TextDocumentIdentifier uri} =
case LSP.uriToFilePath uri of
Just (toNormalizedFilePath' -> fp) -> do
mFields <- liftIO $ runIdeAction "cabal-plugin.fields" (shakeExtras ideState) (useWithStaleFast ParseCabalFields fp)
case fmap fst mFields of
Just fieldPositions -> pure $ LSP.InR (LSP.InL allSymbols)
where
allSymbols = mapMaybe documentSymbolForField fieldPositions
Nothing -> pure $ LSP.InL []
Nothing -> pure $ LSP.InL []
-- | Creates a @DocumentSymbol@ object for the
-- cabal AST, without displaying @fieldLines@ and
-- displaying @Section Name@ and @SectionArgs@ in one line.
--
-- @fieldLines@ are leaves of a cabal AST, so they are omitted
-- in the outline. Sections have to be displayed in one line, because
-- the AST representation looks unnatural. See examples:
--
-- * part of a cabal file:
--
-- > if impl(ghc >= 9.8)
-- > ghc-options: -Wall
--
-- * AST representation:
--
-- > if
-- > impl
-- > (
-- > ghc >= 9.8
-- > )
-- >
-- > ghc-options:
-- > -Wall
--
-- * resulting @DocumentSymbol@:
--
-- > if impl(ghc >= 9.8)
-- > ghc-options:
-- >
documentSymbolForField :: Field Position -> Maybe DocumentSymbol
documentSymbolForField (Field (Name pos fieldName) _) =
Just
(defDocumentSymbol range)
{ _name = decodeUtf8 fieldName,
_kind = LSP.SymbolKind_Field,
_children = Nothing
}
where
range = cabalPositionToLSPRange pos `addNameLengthToLSPRange` decodeUtf8 fieldName
documentSymbolForField (Section (Name pos fieldName) sectionArgs fields) =
Just
(defDocumentSymbol range)
{ _name = joinedName,
_kind = LSP.SymbolKind_Object,
_children =
Just
(mapMaybe documentSymbolForField fields)
}
where
joinedName = decodeUtf8 fieldName <> " " <> onelineSectionArgs sectionArgs
range = cabalPositionToLSPRange pos `addNameLengthToLSPRange` joinedName
-- | Creates a single point LSP range
-- using cabal position
cabalPositionToLSPRange :: Position -> LSP.Range
cabalPositionToLSPRange pos = LSP.Range lspPos lspPos
where
lspPos = cabalPositionToLSPPosition pos
addNameLengthToLSPRange :: LSP.Range -> T.Text -> LSP.Range
addNameLengthToLSPRange (LSP.Range pos1 (LSP.Position line char)) name =
LSP.Range
pos1
(LSP.Position line (char + fromIntegral (T.length name)))
defDocumentSymbol :: LSP.Range -> DocumentSymbol
defDocumentSymbol range = DocumentSymbol
{ _detail = Nothing
, _deprecated = Nothing
, _name = ""
, _kind = LSP.SymbolKind_File
, _range = range
, _selectionRange = range
, _children = Nothing
, _tags = Nothing
}

11
plugins/hls-cabal-plugin/test/Main.hs
View File

@ -20,6 +20,7 @@ import qualified Data.Text as Text
import Ide.Plugin.Cabal.LicenseSuggest (licenseErrorSuggestion)
import qualified Ide.Plugin.Cabal.Parse as Lib
import qualified Language.LSP.Protocol.Lens as L
import Outline (outlineTests)
import System.FilePath
import Test.Hls
import Utils
@ -33,6 +34,7 @@ main = do
, pluginTests
, completerTests
, contextTests
, outlineTests
, codeActionTests
]
@ -83,6 +85,7 @@ codeActionUnitTests =
where
maxCompletions = 100
-- ------------------------ ------------------------------------------------
-- Integration Tests
-- ------------------------------------------------------------------------
@ -94,8 +97,8 @@ pluginTests =
[ testGroup
"Diagnostics"
[ runCabalTestCaseSession "Publishes Diagnostics on Error" "" $ do
doc <- openDoc "invalid.cabal" "cabal"
diags <- waitForDiagnosticsFromSource doc "cabal"
_ <- openDoc "invalid.cabal" "cabal"
diags <- cabalCaptureKick
unknownLicenseDiag <- liftIO $ inspectDiagnostic diags ["Unknown SPDX license identifier: 'BSD3'"]
liftIO $ do
length diags @?= 1
@ -103,14 +106,14 @@ pluginTests =
unknownLicenseDiag ^. L.severity @?= Just DiagnosticSeverity_Error
, runCabalTestCaseSession "Clears diagnostics" "" $ do
doc <- openDoc "invalid.cabal" "cabal"
diags <- waitForDiagnosticsFrom doc
diags <- cabalCaptureKick
unknownLicenseDiag <- liftIO $ inspectDiagnostic diags ["Unknown SPDX license identifier: 'BSD3'"]
liftIO $ do
length diags @?= 1
unknownLicenseDiag ^. L.range @?= Range (Position 3 24) (Position 4 0)
unknownLicenseDiag ^. L.severity @?= Just DiagnosticSeverity_Error
_ <- applyEdit doc $ TextEdit (Range (Position 3 20) (Position 4 0)) "BSD-3-Clause\n"
newDiags <- waitForDiagnosticsFrom doc
newDiags <- cabalCaptureKick
liftIO $ newDiags @?= []
, runCabalTestCaseSession "No Diagnostics in .hs files from valid .cabal file" "simple-cabal" $ do
hsDoc <- openDoc "A.hs" "haskell"

103
plugins/hls-cabal-plugin/test/Outline.hs Normal file
View File

@ -0,0 +1,103 @@
{-# LANGUAGE OverloadedStrings #-}
module Outline (
outlineTests,
) where
import Language.LSP.Protocol.Types (DocumentSymbol (..),
Position (..), Range (..))
import qualified Test.Hls as T
import Utils
testSymbols :: (T.HasCallStack) => T.TestName -> FilePath -> [DocumentSymbol] -> T.TestTree
testSymbols testName path expectedSymbols =
runCabalTestCaseSession testName "outline-cabal" $ do
docId <- T.openDoc path "cabal"
symbols <- T.getDocumentSymbols docId
T.liftIO $ symbols T.@?= Right expectedSymbols
outlineTests :: T.TestTree
outlineTests =
T.testGroup
"Cabal Outline Tests"
[ testSymbols
"cabal Field outline test"
"field.cabal"
[fieldDocumentSymbol]
, testSymbols
"cabal FieldLine outline test"
"fieldline.cabal"
[fieldLineDocumentSymbol]
, testSymbols
"cabal Section outline test"
"section.cabal"
[sectionDocumentSymbol]
, testSymbols
"cabal SectionArg outline test"
"sectionarg.cabal"
[sectionArgDocumentSymbol]
]
where
fieldDocumentSymbol :: DocumentSymbol
fieldDocumentSymbol =
( defDocumentSymbol
( Range { _start = Position{_line = 0, _character = 0}
, _end = Position{_line = 0, _character = 8} })
)
{ _name = "homepage"
, _kind = T.SymbolKind_Field
, _children = Nothing
}
fieldLineDocumentSymbol :: DocumentSymbol
fieldLineDocumentSymbol =
( defDocumentSymbol
( Range { _start = Position{_line = 0, _character = 0}
, _end = Position{_line = 0, _character = 13} })
)
{ _name = "cabal-version"
, _kind = T.SymbolKind_Field
, _children = Nothing -- the values of fieldLine are removed from the outline
}
sectionDocumentSymbol :: DocumentSymbol
sectionDocumentSymbol =
( defDocumentSymbol
( Range { _start = Position{_line = 0, _character = 2}
, _end = Position{_line = 0, _character = 15} })
)
{ _name = "build-depends"
, _kind = T.SymbolKind_Field
, _children = Nothing -- the values of fieldLine are removed from the outline
}
sectionArgDocumentSymbol :: DocumentSymbol
sectionArgDocumentSymbol =
( defDocumentSymbol
( Range { _start = Position{_line = 0, _character = 2}
, _end = Position{_line = 0, _character = 19} })
)
{ _name = "if os ( windows )"
, _kind = T.SymbolKind_Object
, _children = Just $ [sectionArgChildrenDocumentSymbol]
}
sectionArgChildrenDocumentSymbol :: DocumentSymbol
sectionArgChildrenDocumentSymbol =
( defDocumentSymbol
( Range { _start = Position{_line = 1, _character = 4}
, _end = Position{_line = 1, _character = 17} })
)
{ _name = "build-depends"
, _kind = T.SymbolKind_Field
, _children = Nothing
}
defDocumentSymbol :: Range -> DocumentSymbol
defDocumentSymbol range =
DocumentSymbol
{ _detail = Nothing
, _deprecated = Nothing
, _name = ""
, _kind = T.SymbolKind_File
, _range = range
, _selectionRange = range
, _children = Nothing
, _tags = Nothing
}

15
plugins/hls-cabal-plugin/test/Utils.hs
View File

@ -1,9 +1,12 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}
module Utils where
import Control.Monad (guard)
import Data.List (sort)
import Data.Proxy (Proxy (Proxy))
import qualified Data.Text as T
import Ide.Plugin.Cabal (descriptor)
import qualified Ide.Plugin.Cabal
@ -52,6 +55,18 @@ runCabalGoldenSession title subdir fp act = goldenWithCabalDoc def cabalPlugin t
testDataDir :: FilePath
testDataDir = "plugins" </> "hls-cabal-plugin" </> "test" </> "testdata"
-- | these functions are used to detect cabal kicks
-- and look at diagnostics for cabal files
-- kicks are run everytime there is a shake session run/restart
cabalKickDone :: Session ()
cabalKickDone = kick (Proxy @"kick/done/cabal") >>= guard . not . null
cabalKickStart :: Session ()
cabalKickStart = kick (Proxy @"kick/start/cabal") >>= guard . not . null
cabalCaptureKick :: Session [Diagnostic]
cabalCaptureKick = captureKickDiagnostics cabalKickStart cabalKickDone
-- | list comparison where the order in the list is irrelevant
(@?==) :: (HasCallStack, Ord a, Show a) => [a] -> [a] -> Assertion
(@?==) l1 l2 = sort l1 @?= sort l2

1
plugins/hls-cabal-plugin/test/testdata/outline-cabal/field.cabal vendored Normal file
View File

@ -0,0 +1 @@
homepage:

1
plugins/hls-cabal-plugin/test/testdata/outline-cabal/fieldline.cabal vendored Normal file
View File

@ -0,0 +1 @@
cabal-version: 3.0

2
plugins/hls-cabal-plugin/test/testdata/outline-cabal/section.cabal vendored Normal file
View File

@ -0,0 +1,2 @@
build-depends:
base >=4.16 && <5

2
plugins/hls-cabal-plugin/test/testdata/outline-cabal/sectionarg.cabal vendored Normal file
View File

@ -0,0 +1,2 @@
if os(windows)
build-depends: Win32

20
plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs
View File

@ -29,7 +29,6 @@ import Control.Concurrent.STM
import Control.DeepSeq
import Control.Exception
import Control.Lens ((?~), (^.))
import Control.Monad
import Control.Monad.Error.Class (MonadError (throwError))
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Trans.Class (MonadTrans (lift))
@ -119,6 +118,7 @@ import System.Environment (setEnv,
#endif
import Development.IDE.Core.PluginUtils as PluginUtils
import Text.Regex.TDFA.Text ()
-- ---------------------------------------------------------------------
data Log
@ -134,7 +134,7 @@ instance Pretty Log where
LogShake log -> pretty log
LogApplying fp res -> "Applying hint(s) for" <+> viaShow fp <> ":" <+> viaShow res
LogGeneratedIdeas fp ideas -> "Generated hlint ideas for for" <+> viaShow fp <> ":" <+> viaShow ideas
LogUsingExtensions fp exts -> "Using extensions for " <+> viaShow fp <> ":" <+> pretty exts
LogUsingExtensions fp exts -> "Using extensions for " <+> viaShow fp <> ":" <> line <> indent 4 (pretty exts)
LogGetIdeas fp -> "Getting hlint ideas for " <+> viaShow fp
LogResolve msg -> pretty msg
@ -183,12 +183,12 @@ instance NFData GetHlintDiagnostics
type instance RuleResult GetHlintDiagnostics = ()
-- | Hlint rules to generate file diagnostics based on hlint hints
-- | This rule is recomputed when:
-- | - A file has been edited via
-- | - `getIdeas` -> `getParsedModule` in any case
-- | - `getIdeas` -> `getFileContents` if the hls ghc does not match the hlint default ghc
-- | - The client settings have changed, to honour the `hlintOn` setting, via `getClientConfigAction`
-- | - The hlint specific settings have changed, via `getHlintSettingsRule`
-- This rule is recomputed when:
-- - A file has been edited via
-- - `getIdeas` -> `getParsedModule` in any case
-- - `getIdeas` -> `getFileContents` if the hls ghc does not match the hlint default ghc
-- - The client settings have changed, to honour the `hlintOn` setting, via `getClientConfigAction`
-- - The hlint specific settings have changed, via `getHlintSettingsRule`
rules :: Recorder (WithPriority Log) -> PluginId -> Rules ()
rules recorder plugin = do
define (cmapWithPrio LogShake recorder) $ \GetHlintDiagnostics file -> do
@ -202,8 +202,8 @@ rules recorder plugin = do
liftIO $ argsSettings flags
action $ do
files <- getFilesOfInterestUntracked
void $ uses GetHlintDiagnostics $ Map.keys files
files <- Map.keys <$> getFilesOfInterestUntracked
Shake.runWithSignal (Proxy @"kick/start/hlint") (Proxy @"kick/done/hlint") files GetHlintDiagnostics
where

129
plugins/hls-hlint-plugin/test/Main.hs
View File

@ -1,3 +1,5 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Main
@ -5,19 +7,21 @@ module Main
) where
import Control.Lens ((^.))
import Control.Monad (when)
import Control.Monad (guard, when)
import Data.Aeson (Value (..), object, (.=))
import Data.Functor (void)
import Data.List (find)
import qualified Data.Map as Map
import Data.Maybe (fromJust, isJust)
import Data.Proxy (Proxy (Proxy))
import qualified Data.Text as T
import Ide.Plugin.Config (Config (..))
import qualified Ide.Plugin.Config as Plugin
import qualified Ide.Plugin.Hlint as HLint
import qualified Language.LSP.Protocol.Lens as L
import System.FilePath ((</>))
import System.FilePath ((<.>), (</>))
import Test.Hls
import Test.Hls.FileSystem
main :: IO ()
main = defaultTestRunner tests
@ -86,7 +90,7 @@ suggestionsTests =
testGroup "hlint suggestions" [
testCase "provides 3.8 code actions including apply all" $ runHlintSession "" $ do
doc <- openDoc "Base.hs" "haskell"
diags@(reduceDiag:_) <- waitForDiagnosticsFromSource doc "hlint"
diags@(reduceDiag:_) <- hlintCaptureKick
liftIO $ do
length diags @?= 2 -- "Eta Reduce" and "Redundant Id"
@ -124,7 +128,7 @@ suggestionsTests =
, testShiftRoot = True} $ const $ do
doc <- openDoc "Base.hs" "haskell"
_ <- waitForDiagnosticsFromSource doc "hlint"
_ <- hlintCaptureKick
cars <- getAllCodeActions doc
etaReduce <- liftIO $ inspectCommand cars ["Eta reduce"]
@ -136,7 +140,7 @@ suggestionsTests =
, testCase ".hlint.yaml fixity rules are applied" $ runHlintSession "fixity" $ do
doc <- openDoc "FixityUse.hs" "haskell"
expectNoMoreDiagnostics 3 doc "hlint"
testNoHlintDiagnostics doc
, testCase "changing document contents updates hlint diagnostics" $ runHlintSession "" $ do
doc <- openDoc "Base.hs" "haskell"
@ -150,7 +154,8 @@ suggestionsTests =
}
changeDoc doc [change]
expectNoMoreDiagnostics 3 doc "hlint"
-- We need to wait until hlint has been rerun and clears the diagnostic
[] <- waitForDiagnosticsFrom doc
let change' = TextDocumentContentChangeEvent $ InL
TextDocumentContentChangePartial
@ -166,7 +171,7 @@ suggestionsTests =
testHlintDiagnostics doc
, knownBrokenForHlintOnGhcLib "hlint doesn't take in account cpp flag as ghc -D argument" $
testCase "[#554] hlint diagnostics works with CPP via language pragma" $ runHlintSession "" $ do
testCase "[#554] hlint diagnostics works with CPP via language pragma" $ runHlintSession "cpp" $ do
doc <- openDoc "CppCond.hs" "haskell"
testHlintDiagnostics doc
@ -186,27 +191,27 @@ suggestionsTests =
testRefactor "LambdaCase.hs" "Redundant bracket"
("{-# LANGUAGE LambdaCase #-}" : expectedLambdaCase)
, expectFailBecause "apply-refact doesn't work with cpp" $
, ignoreTestBecause "apply-refact doesn't work with cpp" $
testCase "apply hints works with CPP via -XCPP argument" $ runHlintSession "cpp" $ do
testRefactor "CppCond.hs" "Redundant bracket"
expectedCPP
, expectFailBecause "apply-refact doesn't work with cpp" $
, ignoreTestBecause "apply-refact doesn't work with cpp" $
testCase "apply hints works with CPP via language pragma" $ runHlintSession "" $ do
testRefactor "CppCond.hs" "Redundant bracket"
("{-# LANGUAGE CPP #-}" : expectedCPP)
, testCase "hlint diagnostics ignore hints honouring .hlint.yaml" $ runHlintSession "ignore" $ do
doc <- openDoc "CamelCase.hs" "haskell"
expectNoMoreDiagnostics 3 doc "hlint"
testNoHlintDiagnostics doc
, testCase "hlint diagnostics ignore hints honouring ANN annotations" $ runHlintSession "" $ do
doc <- openDoc "IgnoreAnn.hs" "haskell"
expectNoMoreDiagnostics 3 doc "hlint"
testNoHlintDiagnostics doc
, testCase "hlint diagnostics ignore hints honouring HLINT annotations" $ runHlintSession "" $ do
doc <- openDoc "IgnoreAnnHlint.hs" "haskell"
expectNoMoreDiagnostics 3 doc "hlint"
testNoHlintDiagnostics doc
, testCase "apply-refact preserve regular comments" $ runHlintSession "" $ do
testRefactor "Comments.hs" "Redundant bracket" expectedComments
@ -216,7 +221,7 @@ suggestionsTests =
, testCase "applyAll is shown only when there is at least one diagnostic in range" $ runHlintSession "" $ do
doc <- openDoc "TwoHints.hs" "haskell"
_ <- waitForDiagnosticsFromSource doc "hlint"
_ <- hlintCaptureKick
firstLine <- map fromAction <$> getCodeActions doc (mkRange 0 0 0 0)
secondLine <- map fromAction <$> getCodeActions doc (mkRange 1 0 1 0)
@ -231,22 +236,20 @@ suggestionsTests =
liftIO $ hasApplyAll multiLine @? "Missing apply all code action"
, testCase "hlint should warn about unused extensions" $ runHlintSession "unusedext" $ do
doc <- openDoc "UnusedExtension.hs" "haskell"
diags@(unusedExt:_) <- waitForDiagnosticsFromSource doc "hlint"
_ <- openDoc "UnusedExtension.hs" "haskell"
diags@(unusedExt:_) <- hlintCaptureKick
liftIO $ do
length diags @?= 1
unusedExt ^. L.code @?= Just (InR "refact:Unused LANGUAGE pragma")
, testCase "[#1279] hlint should not activate extensions like PatternSynonyms" $ runHlintSession "" $ do
, testCase "[#1279] hlint should not activate extensions like PatternSynonyms" $ runHlintSession "" $ do
doc <- openDoc "PatternKeyword.hs" "haskell"
-- hlint will report a parse error if PatternSynonyms is enabled
expectNoMoreDiagnostics 3 doc "hlint"
testNoHlintDiagnostics doc
, testCase "hlint should not warn about redundant irrefutable pattern with LANGUAGE Strict" $ runHlintSession "" $ do
doc <- openDoc "StrictData.hs" "haskell"
expectNoMoreDiagnostics 3 doc "hlint"
testNoHlintDiagnostics doc
]
where
testRefactor file caTitle expected = do
@ -301,9 +304,7 @@ configTests = testGroup "hlint plugin config" [
disableHlint
diags' <- waitForDiagnosticsFrom doc
liftIO $ noHlintDiagnostics diags'
testNoHlintDiagnostics doc
, testCase "adding hlint flags to plugin configuration removes hlint diagnostics" $ runHlintSession "" $ do
setIgnoringConfigurationRequests False
@ -315,9 +316,7 @@ configTests = testGroup "hlint plugin config" [
let config' = hlintConfigWithFlags ["--ignore=Redundant id", "--hint=test-hlint-config.yaml"]
setHlsConfig config'
diags' <- waitForDiagnosticsFrom doc
liftIO $ noHlintDiagnostics diags'
testNoHlintDiagnostics doc
, testCase "adding hlint flags to plugin configuration adds hlint diagnostics" $ runHlintSession "" $ do
setIgnoringConfigurationRequests False
@ -325,12 +324,12 @@ configTests = testGroup "hlint plugin config" [
doc <- openDoc "Generalise.hs" "haskell"
expectNoMoreDiagnostics 3 doc "hlint"
testNoHlintDiagnostics doc
let config' = hlintConfigWithFlags ["--with-group=generalise"]
setHlsConfig config'
diags' <- waitForDiagnosticsFromSource doc "hlint"
diags' <- hlintCaptureKick
d <- liftIO $ inspectDiagnostic diags' ["Use <>"]
liftIO $ do
@ -352,14 +351,39 @@ runHlintSession subdir = failIfSessionTimeout .
}
. const
noHlintDiagnostics :: [Diagnostic] -> Assertion
noHlintDiagnostics diags =
Just "hlint" `notElem` map (^. L.source) diags @? "There are no hlint diagnostics"
hlintKickDone :: Session ()
hlintKickDone = kick (Proxy @"kick/done/hlint") >>= guard . not . null
testHlintDiagnostics :: TextDocumentIdentifier -> Session ()
hlintKickStart :: Session ()
hlintKickStart = kick (Proxy @"kick/start/hlint") >>= guard . not . null
hlintCaptureKick :: Session [Diagnostic]
hlintCaptureKick = captureKickDiagnostics hlintKickStart hlintKickDone
noHlintDiagnostics :: HasCallStack => [Diagnostic] -> Assertion
noHlintDiagnostics diags =
all (not . isHlintDiagnostic) diags @? "There are hlint diagnostics"
isHlintDiagnostic :: Diagnostic -> Bool
isHlintDiagnostic diag =
Just "hlint" == diag ^. L.source
testHlintDiagnostics :: HasCallStack => TextDocumentIdentifier -> Session ()
testHlintDiagnostics doc = do
diags <- waitForDiagnosticsFromSource doc "hlint"
liftIO $ length diags > 0 @? "There are hlint diagnostics"
diags <- captureKickNonEmptyDiagnostics doc
liftIO $ length diags > 0 @? "There are no hlint diagnostics"
captureKickNonEmptyDiagnostics :: HasCallStack => TextDocumentIdentifier -> Session [Diagnostic]
captureKickNonEmptyDiagnostics doc = do
diags <- hlintCaptureKick
if null diags
then captureKickNonEmptyDiagnostics doc
else pure diags
testNoHlintDiagnostics :: HasCallStack => TextDocumentIdentifier -> Session ()
testNoHlintDiagnostics _doc = do
diags <- hlintCaptureKick
liftIO $ noHlintDiagnostics diags
hlintConfigWithFlags :: [T.Text] -> Config
hlintConfigWithFlags flags =
@ -385,7 +409,7 @@ disableHlint = setHlsConfig $ def { Plugin.plugins = Map.fromList [ ("hlint", de
-- Although a given hlint version supports one direct ghc, we could use several versions of hlint
-- each one supporting a different ghc version. It should be a temporary situation though.
knownBrokenForHlintOnGhcLib :: String -> TestTree -> TestTree
knownBrokenForHlintOnGhcLib = expectFailBecause
knownBrokenForHlintOnGhcLib = ignoreTestBecause
-- 1's based
data Point = Point {
@ -408,6 +432,10 @@ makeCodeActionNotFoundAtString :: Point -> String
makeCodeActionNotFoundAtString Point {..} =
"CodeAction not found at line: " <> show line <> ", column: " <> show column
-- ------------------------------------------------------------------------
-- Test runner helpers
-- ------------------------------------------------------------------------
ignoreHintGoldenTest :: TestName -> FilePath -> Point -> T.Text -> TestTree
ignoreHintGoldenTest testCaseName goldenFilename point hintName =
goldenTest testCaseName goldenFilename point (getIgnoreHintText hintName)
@ -418,8 +446,8 @@ applyHintGoldenTest testCaseName goldenFilename point hintName = do
goldenTest :: TestName -> FilePath -> Point -> T.Text -> TestTree
goldenTest testCaseName goldenFilename point hintText =
setupGoldenHlintTest testCaseName goldenFilename $ \document -> do
_ <- waitForDiagnosticsFromSource document "hlint"
setupGoldenHlintTest testCaseName goldenFilename codeActionNoResolveCaps $ \document -> do
_ <- hlintCaptureKick
actions <- getCodeActions document $ pointToRange point
case find ((== Just hintText) . getCodeActionTitle) actions of
Just (InR codeAction) -> do
@ -429,16 +457,15 @@ goldenTest testCaseName goldenFilename point hintText =
_ -> liftIO $ assertFailure $ makeCodeActionNotFoundAtString point
setupGoldenHlintTest :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree
setupGoldenHlintTest testName path =
setupGoldenHlintTest :: TestName -> FilePath -> ClientCapabilities -> (TextDocumentIdentifier -> Session ()) -> TestTree
setupGoldenHlintTest testName path config =
goldenWithTestConfig def
{ testConfigCaps = codeActionNoResolveCaps
{ testConfigCaps = config
, testShiftRoot = True
, testPluginDescriptor = hlintPlugin
, testDirLocation = Left testDir
}
testName testDir path "expected" "hs"
, testDirLocation = Right tree
} testName tree path "expected" "hs"
where tree = mkVirtualFileTree testDir (directProject (path <.> "hs"))
ignoreHintGoldenResolveTest :: TestName -> FilePath -> Point -> T.Text -> TestTree
ignoreHintGoldenResolveTest testCaseName goldenFilename point hintName =
@ -450,19 +477,9 @@ applyHintGoldenResolveTest testCaseName goldenFilename point hintName = do
goldenResolveTest :: TestName -> FilePath -> Point -> T.Text -> TestTree
goldenResolveTest testCaseName goldenFilename point hintText =
setupGoldenHlintResolveTest testCaseName goldenFilename $ \document -> do
_ <- waitForDiagnosticsFromSource document "hlint"
setupGoldenHlintTest testCaseName goldenFilename codeActionResolveCaps $ \document -> do
_ <- hlintCaptureKick
actions <- getAndResolveCodeActions document $ pointToRange point
case find ((== Just hintText) . getCodeActionTitle) actions of
Just (InR codeAction) -> executeCodeAction codeAction
_ -> liftIO $ assertFailure $ makeCodeActionNotFoundAtString point
setupGoldenHlintResolveTest :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree
setupGoldenHlintResolveTest testName path =
goldenWithTestConfig def
{ testConfigCaps = codeActionResolveCaps
, testShiftRoot = True
, testPluginDescriptor = hlintPlugin
, testDirLocation = Left testDir
}
testName testDir path "expected" "hs"

3
test/testdata/schema/ghc94/default-config.golden.json vendored
View File

@ -11,7 +11,8 @@
"cabal": {
"codeActionsOn": true,
"completionOn": true,
"diagnosticsOn": true
"diagnosticsOn": true,
"symbolsOn": true
},
"cabal-fmt": {
"config": {

6
test/testdata/schema/ghc94/vscode-extension-schema.golden.json vendored
View File

@ -35,6 +35,12 @@
"scope": "resource",
"type": "boolean"
},
"haskell.plugin.cabal.symbolsOn": {
"default": true,
"description": "Enables cabal symbols",
"scope": "resource",
"type": "boolean"
},
"haskell.plugin.callHierarchy.globalOn": {
"default": true,
"description": "Enables callHierarchy plugin",

3
test/testdata/schema/ghc96/default-config.golden.json vendored
View File

@ -11,7 +11,8 @@
"cabal": {
"codeActionsOn": true,
"completionOn": true,
"diagnosticsOn": true
"diagnosticsOn": true,
"symbolsOn": true
},
"cabal-fmt": {
"config": {

6
test/testdata/schema/ghc96/vscode-extension-schema.golden.json vendored
View File

@ -35,6 +35,12 @@
"scope": "resource",
"type": "boolean"
},
"haskell.plugin.cabal.symbolsOn": {
"default": true,
"description": "Enables cabal symbols",
"scope": "resource",
"type": "boolean"
},
"haskell.plugin.callHierarchy.globalOn": {
"default": true,
"description": "Enables callHierarchy plugin",

3
test/testdata/schema/ghc98/default-config.golden.json vendored
View File

@ -11,7 +11,8 @@
"cabal": {
"codeActionsOn": true,
"completionOn": true,
"diagnosticsOn": true
"diagnosticsOn": true,
"symbolsOn": true
},
"cabal-fmt": {
"config": {

6
test/testdata/schema/ghc98/vscode-extension-schema.golden.json vendored
View File

@ -35,6 +35,12 @@
"scope": "resource",
"type": "boolean"
},
"haskell.plugin.cabal.symbolsOn": {
"default": true,
"description": "Enables cabal symbols",
"scope": "resource",
"type": "boolean"
},
"haskell.plugin.callHierarchy.globalOn": {
"default": true,
"description": "Enables callHierarchy plugin",