diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 24f7c9b8ba..4beffcc5de 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -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 diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs index 3f9eac0fd4..a28cdd1436 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs +++ b/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 @@ -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 = diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/CabalFields.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/CabalFields.hs index 02daa72826..84ec3ec345 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/CabalFields.hs +++ b/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 diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Types.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Types.hs index ab53ce658b..2655fbcaa6 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/Types.hs +++ b/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) diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Outline.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Outline.hs new file mode 100644 index 0000000000..40f348f88c --- /dev/null +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Outline.hs @@ -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 + } diff --git a/plugins/hls-cabal-plugin/test/Main.hs b/plugins/hls-cabal-plugin/test/Main.hs index 734c3a3ca4..f39792fad7 100644 --- a/plugins/hls-cabal-plugin/test/Main.hs +++ b/plugins/hls-cabal-plugin/test/Main.hs @@ -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 ] diff --git a/plugins/hls-cabal-plugin/test/Outline.hs b/plugins/hls-cabal-plugin/test/Outline.hs new file mode 100644 index 0000000000..cb7279e387 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/Outline.hs @@ -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 + } diff --git a/plugins/hls-cabal-plugin/test/testdata/outline-cabal/field.cabal b/plugins/hls-cabal-plugin/test/testdata/outline-cabal/field.cabal new file mode 100644 index 0000000000..c3e3d80df2 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/outline-cabal/field.cabal @@ -0,0 +1 @@ +homepage: \ No newline at end of file diff --git a/plugins/hls-cabal-plugin/test/testdata/outline-cabal/fieldline.cabal b/plugins/hls-cabal-plugin/test/testdata/outline-cabal/fieldline.cabal new file mode 100644 index 0000000000..998369e5f1 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/outline-cabal/fieldline.cabal @@ -0,0 +1 @@ +cabal-version: 3.0 diff --git a/plugins/hls-cabal-plugin/test/testdata/outline-cabal/section.cabal b/plugins/hls-cabal-plugin/test/testdata/outline-cabal/section.cabal new file mode 100644 index 0000000000..8a140c7517 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/outline-cabal/section.cabal @@ -0,0 +1,2 @@ + build-depends: + base >=4.16 && <5 \ No newline at end of file diff --git a/plugins/hls-cabal-plugin/test/testdata/outline-cabal/sectionarg.cabal b/plugins/hls-cabal-plugin/test/testdata/outline-cabal/sectionarg.cabal new file mode 100644 index 0000000000..060d067377 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/outline-cabal/sectionarg.cabal @@ -0,0 +1,2 @@ + if os(windows) + build-depends: Win32 \ No newline at end of file diff --git a/test/testdata/schema/ghc94/default-config.golden.json b/test/testdata/schema/ghc94/default-config.golden.json index 2612bdba87..5f881ff00e 100644 --- a/test/testdata/schema/ghc94/default-config.golden.json +++ b/test/testdata/schema/ghc94/default-config.golden.json @@ -11,7 +11,8 @@ "cabal": { "codeActionsOn": true, "completionOn": true, - "diagnosticsOn": true + "diagnosticsOn": true, + "symbolsOn": true }, "cabal-fmt": { "config": { diff --git a/test/testdata/schema/ghc94/vscode-extension-schema.golden.json b/test/testdata/schema/ghc94/vscode-extension-schema.golden.json index 03371d21e7..5da4a27dd6 100644 --- a/test/testdata/schema/ghc94/vscode-extension-schema.golden.json +++ b/test/testdata/schema/ghc94/vscode-extension-schema.golden.json @@ -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", diff --git a/test/testdata/schema/ghc96/default-config.golden.json b/test/testdata/schema/ghc96/default-config.golden.json index 2612bdba87..5f881ff00e 100644 --- a/test/testdata/schema/ghc96/default-config.golden.json +++ b/test/testdata/schema/ghc96/default-config.golden.json @@ -11,7 +11,8 @@ "cabal": { "codeActionsOn": true, "completionOn": true, - "diagnosticsOn": true + "diagnosticsOn": true, + "symbolsOn": true }, "cabal-fmt": { "config": { diff --git a/test/testdata/schema/ghc96/vscode-extension-schema.golden.json b/test/testdata/schema/ghc96/vscode-extension-schema.golden.json index 03371d21e7..5da4a27dd6 100644 --- a/test/testdata/schema/ghc96/vscode-extension-schema.golden.json +++ b/test/testdata/schema/ghc96/vscode-extension-schema.golden.json @@ -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", diff --git a/test/testdata/schema/ghc98/default-config.golden.json b/test/testdata/schema/ghc98/default-config.golden.json index 2612bdba87..5f881ff00e 100644 --- a/test/testdata/schema/ghc98/default-config.golden.json +++ b/test/testdata/schema/ghc98/default-config.golden.json @@ -11,7 +11,8 @@ "cabal": { "codeActionsOn": true, "completionOn": true, - "diagnosticsOn": true + "diagnosticsOn": true, + "symbolsOn": true }, "cabal-fmt": { "config": { diff --git a/test/testdata/schema/ghc98/vscode-extension-schema.golden.json b/test/testdata/schema/ghc98/vscode-extension-schema.golden.json index 03371d21e7..5da4a27dd6 100644 --- a/test/testdata/schema/ghc98/vscode-extension-schema.golden.json +++ b/test/testdata/schema/ghc98/vscode-extension-schema.golden.json @@ -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",