Cabal plugin outline view

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

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 =

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)

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
+  }

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
             ]
 

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
+    }

plugins/hls-cabal-plugin/test/testdata/outline-cabal/field.cabal

@@ -0,0 +1 @@
+homepage:

plugins/hls-cabal-plugin/test/testdata/outline-cabal/fieldline.cabal

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

plugins/hls-cabal-plugin/test/testdata/outline-cabal/section.cabal

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

plugins/hls-cabal-plugin/test/testdata/outline-cabal/sectionarg.cabal

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

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": {

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",

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": {

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",

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": {

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",