Cabal plugin outline view

haskell-language-server.cabal

@@ -242,6 +242,7 @@ library hls-cabal-plugin
     Ide.Plugin.Cabal.Completion.Types
     Ide.Plugin.Cabal.LicenseSuggest
     Ide.Plugin.Cabal.Orphans
+    Ide.Plugin.Cabal.Outline
     Ide.Plugin.Cabal.Parse
 
 
@@ -280,6 +281,7 @@ test-suite hls-cabal-plugin-tests
     Completer
     Context
     Utils
+    Outline
   build-depends:
     , base
     , bytestring

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

@@ -38,6 +38,7 @@ import qualified Ide.Plugin.Cabal.Completion.Types           as Types
 import qualified Ide.Plugin.Cabal.Diagnostics                as Diagnostics
 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
@@ -88,6 +89,7 @@ descriptor recorder plId =
         mconcat
           [ mkPluginHandler LSP.SMethod_TextDocumentCodeAction licenseSuggestCodeAction
           , mkPluginHandler LSP.SMethod_TextDocumentCompletion $ completion recorder
+          , mkPluginHandler LSP.SMethod_TextDocumentDocumentSymbol moduleOutline
           ]
     , pluginNotificationHandlers =
         mconcat

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

@@ -171,3 +171,6 @@ lspPositionToCabalPosition :: Position -> Syntax.Position
 lspPositionToCabalPosition pos = Syntax.Position
   (fromIntegral (pos ^. JL.line) + 1)
   (fromIntegral (pos ^. JL.character) + 1)
+
+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,103 @@
+{-# 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),
+                                                    SectionArg (SecArgName, SecArgOther, SecArgStr))
+import           Distribution.Parsec.Position      (Position)
+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 DocumentSumbol object for the
+--   cabal AST, without displaying fieldLines and
+--   displaying Section name and SectionArgs in one line
+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 <> " " <> joinedNameForSectionArgs sectionArgs
+    range = cabalPositionToLSPRange pos `addNameLengthToLSPRange` joinedName
+
+joinedNameForSectionArgs :: [SectionArg Position] -> T.Text
+joinedNameForSectionArgs sectionArgs = joinedName
+  where
+    joinedName = T.unwords $ map getName sectionArgs
+
+    getName :: SectionArg Position -> T.Text
+    getName (SecArgName _ identifier)  = decodeUtf8 identifier
+    getName (SecArgStr _ quotedString) = decodeUtf8 quotedString
+    getName (SecArgOther _ string)     = decodeUtf8 string
+
+-- | 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

@@ -16,6 +16,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
@@ -29,6 +30,7 @@ main = do
             , pluginTests
             , completerTests
             , contextTests
+            , outlineTests
             ]
 
 -- ------------------------------------------------------------------------

plugins/hls-cabal-plugin/test/Outline.hs

@@ -0,0 +1,86 @@
+{-# 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",