Add completion functionality for cabal keywords

Author: Jana Chadt

plugins/hls-cabal-plugin/hls-cabal-plugin.cabal

@@ -45,6 +45,7 @@ library
     -- This is a lot of work for almost zero benefit, so we just allow more versions here
     -- and we eventually completely drop support for building HLS with stack.
     , Cabal                 ^>=3.2 || ^>=3.4 || ^>=3.6 || ^>= 3.8 || ^>= 3.10
+    , containers
     , deepseq
     , directory
     , extra                 >=1.7.4
@@ -57,6 +58,7 @@ library
     , regex-tdfa            ^>=1.3.1
     , stm
     , text
+    , text-rope
     , unordered-containers  >=0.2.10.0
 
   hs-source-dirs:   src

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

@@ -20,24 +20,33 @@ import qualified Data.ByteString                 as BS
 import           Data.Hashable
 import           Data.HashMap.Strict             (HashMap)
 import qualified Data.HashMap.Strict             as HashMap
+import qualified Data.List                       as List
 import qualified Data.List.NonEmpty              as NE
+import           Data.Map                        (Map)
+import qualified Data.Map                        as Map
+import qualified Data.Text                       as T
 import qualified Data.Text.Encoding              as Encoding
+import qualified Data.Text.Utf16.Rope            as Rope
 import           Data.Typeable
 import           Development.IDE                 as D
 import           Development.IDE.Core.Shake      (restartShakeSession)
 import qualified Development.IDE.Core.Shake      as Shake
 import           Development.IDE.Graph           (alwaysRerun)
+import           Distribution.Compat.Lens        ((^.))
 import           GHC.Generics
 import qualified Ide.Plugin.Cabal.Diagnostics    as Diagnostics
 import qualified Ide.Plugin.Cabal.LicenseSuggest as LicenseSuggest
 import qualified Ide.Plugin.Cabal.Parse          as Parse
 import           Ide.Plugin.Config               (Config)
 import           Ide.Types
-import           Language.LSP.Server             (LspM)
+import qualified Language.LSP.Server             as LSP
 import           Language.LSP.Types
+import qualified Language.LSP.Types              as J
 import qualified Language.LSP.Types              as LSP
+import qualified Language.LSP.Types.Lens         as JL
+import           Language.LSP.VFS                (VirtualFile)
 import qualified Language.LSP.VFS                as VFS
-
+import qualified Text.Fuzzy.Parallel             as Fuzzy
 data Log
   = LogModificationTime NormalizedFilePath FileVersion
   | LogShake Shake.Log
@@ -69,6 +78,7 @@ descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeSta
 descriptor recorder plId = (defaultCabalPluginDescriptor plId)
   { pluginRules = cabalRules recorder
   , pluginHandlers = mkPluginHandler STextDocumentCodeAction licenseSuggestCodeAction
+                      <> mkPluginHandler J.STextDocumentCompletion completion
   , pluginNotificationHandlers = mconcat
   [ mkPluginNotificationHandler LSP.STextDocumentDidOpen $
       \ide vfs _ (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> liftIO $ do
@@ -181,7 +191,7 @@ licenseSuggestCodeAction
   :: IdeState
   -> PluginId
   -> CodeActionParams
-  -> LspM Config (Either ResponseError (ResponseResult 'TextDocumentCodeAction))
+  -> LSP.LspM Config (Either ResponseError (ResponseResult 'TextDocumentCodeAction))
 licenseSuggestCodeAction _ _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List diags}) =
   pure $ Right $ List $ diags >>= (fmap InR . (LicenseSuggest.licenseErrorAction uri))
 
@@ -255,3 +265,206 @@ deleteFileOfInterest recorder state f = do
     log' Debug $ LogFOI files
   where
     log' = logWith recorder
+
+-- ----------------------------------------------------------------
+-- Completion
+-- ----------------------------------------------------------------
+
+completion :: PluginMethodHandler IdeState 'J.TextDocumentCompletion
+completion _ide _ complParams = do
+  let (J.TextDocumentIdentifier uri) = complParams ^. JL.textDocument
+      position = complParams ^. JL.position
+  contents <- LSP.getVirtualFile $ toNormalizedUri uri
+  fmap (Right . J.InL) $ case (contents, uriToFilePath' uri) of
+    (Just cnts, Just _path) -> do
+      pref <- VFS.getCompletionPrefix position cnts
+      return $ result pref cnts
+    _ -> return $ J.List []
+  where
+    result :: Maybe VFS.PosPrefixInfo -> VirtualFile -> J.List CompletionItem
+    result Nothing _ = J.List []
+    result (Just pfix) cnts
+      | (VFS.cursorPos pfix) ^. JL.line == 0 = J.List [buildCompletion cabalVersionKeyword]
+      | Stanza s <- findCurrentLevel (getPreviousLines pfix cnts) =
+          case (Map.lookup s stanzaKeywordMap) of
+            Nothing ->
+              J.List $
+                makeCompletionItems pfix topLevelKeywords
+            Just l -> J.List $ (makeCompletionItems pfix l) ++ (makeCompletionItems pfix $ Map.keys stanzaKeywordMap)
+      | otherwise =
+        J.List $
+          makeCompletionItems pfix topLevelKeywords
+          where
+            topLevelKeywords = cabalKeywords ++ Map.keys stanzaKeywordMap
+
+-- | Takes info about the current cursor position and a set of possible keywords
+--   and creates completion suggestions that fit the current input from the given list
+makeCompletionItems :: VFS.PosPrefixInfo -> [T.Text] -> [CompletionItem]
+makeCompletionItems pfix l =
+  map
+    (buildCompletion . Fuzzy.original)
+    (Fuzzy.simpleFilter 1000 10 (VFS.prefixText pfix) l)
+
+-- | Parse the given set of lines (starting before current cursor position
+--   up to the start of the file) to find the nearest stanza declaration,
+--   if none is found we are in the top level
+findCurrentLevel :: [T.Text] -> Context
+findCurrentLevel [] = TopLevel
+findCurrentLevel (cur : xs)
+  | Just s <- stanza = Stanza s
+  | otherwise = findCurrentLevel xs
+  where
+    stanza = List.find (`T.isPrefixOf` cur) (Map.keys stanzaKeywordMap)
+
+-- | Get all lines before the given cursor position in the given file
+--   and reverse them since we want to traverse starting from our current position
+getPreviousLines :: VFS.PosPrefixInfo -> VirtualFile -> [T.Text]
+getPreviousLines pos cont = reverse $ take (fromIntegral currentLine) allLines
+  where
+    allLines = Rope.lines $ cont ^. VFS.file_text
+    currentLine = (VFS.cursorPos pos) ^. JL.line
+
+
+data Context
+  = TopLevel
+  -- ^ top level context in a cabal file such as 'author'
+  | Stanza T.Text
+  -- ^ nested context in a cabal file, such as 'library', which has nested keywords, specific to the stanza
+  deriving (Eq)
+
+-- | Keyword for cabal version required to be the top line in a cabal file
+cabalVersionKeyword :: T.Text
+cabalVersionKeyword = "cabal-version:"
+
+-- | Top level keywords of a cabal file
+cabalKeywords :: [T.Text]
+cabalKeywords =
+  [
+    "name:",
+    "version:",
+    "build-type:",
+    "license:",
+    "license-file:",
+    "license-files:",
+    "copyright:",
+    "author:",
+    "maintainer:",
+    "stability:",
+    "homepage:",
+    "bug-reports:",
+    "package-url:",
+    "synopsis:",
+    "description:",
+    "category:",
+    "tested-with:",
+    "data-files:",
+    "data-dir:",
+    "data-dir:",
+    "extra-doc-files:",
+    "extra-tmp-files:"
+  ]
+
+-- | Map, containing all stanzas in a cabal file as keys and lists of their possible nested keywords as values
+stanzaKeywordMap :: Map T.Text [T.Text]
+stanzaKeywordMap = Map.fromList [("library", [
+    "exposed-modules:",
+    "virtual-modules:",
+    "exposed:",
+    "visibility:",
+    "reexported-modules:",
+    "signatures:"
+  ])]
+
+
+-- TODO move out toplevel commands i.e. test-suite
+-- cabalTestKeywords :: [T.Text]
+-- cabalTestKeywords =
+--   [
+--     "test-suite",
+--     "type:",
+--     "main-is:",
+--     "test-module:",
+--     "benchmark",
+--     "main-is:",
+--     "foreign-library",
+--     "type:",
+--     "options:",
+--     "mod-def-file:",
+--     "lib-version-info:",
+--     "lib-version-linux:",
+--     "build-depends:",
+--     "other-modules:",
+--     "hs-source-dir:",
+--     "hs-source-dirs:",
+--     "default-extensions:",
+--     "other-extensions:",
+--     "default-language:",
+--     "other-languages:",
+--     "extensions:",
+--     "build-tool-depends:",
+--     "build-tools:",
+--     "buildable:",
+--     "ghc-options:",
+--     "ghc-prof-options:",
+--     "ghc-shared-options:",
+--     "ghcjs-options:",
+--     "ghcjs-prof-options:",
+--     "ghcjs-shared-options:",
+--     "includes:",
+--     "install-includes:",
+--     ("include-dirs:", "directory list"),
+--     ("c-sources:", "filename list"),
+--     ("cxx-sources:", "filename list"),
+--     ("asm-sources:", "filename list"),
+--     ("cmm-sources:", "filename list"),
+--     ("js-sources:", "filename list"),
+--     ("extra-libraries:", "token list"),
+--     ("extra-libraries-static:", "token list"),
+--     ("extra-ghci-libraries:", "token list"),
+--     ("extra-bundled-libraries:", "token list"),
+--     ("extra-lib-dirs:", "directory list")
+--     ("extra-lib-dirs-static:", "directory list"),
+--     ("extra-library-flavours:", "notsure"),
+--     ("extra-dynamic-library-flavours:", "notsure"),
+--     ("cc-options:", "token list"),
+--     ("cpp-options:", "token list"),
+--     ("cxx-options:", "token list"),
+--     ("cmm-options:", "token list"),
+--     ("asm-options:", "token list"),
+--     ("ld-options:", "token list"),
+--     ("hsc2hs-options:", "token list"),
+--     ("pkgconfig-depends:", "package list"),
+--     ("frameworks:", "token list"),
+--     ("extra-framework-dirs:", "directory list"),
+--     ("mixins:", "mixin list")
+--   ]
+
+-- cabalFlagKeywords :: [(T.Text, T.Text)]
+-- cabalFlagKeywords =
+--   [
+--     ("flag", "name"),
+--     ("description:", "freeform"),
+--     ("default:", "boolean"),
+--     ("manual:", "boolean")
+--   ]
+
+-- cabalStanzaKeywords :: [(T.Text, T.Text)]
+-- cabalStanzaKeywords =
+--   [
+--     ("common", "name"),
+--     ("import:", "token-list")
+--   ]
+
+-- cabalSourceRepoKeywords :: [(T.Text, T.Text)]
+-- cabalSourceRepoKeywords =
+--   [
+--     ("source-repository", ""),
+--     ("type:", "token"),
+--     ("location:", "URL")
+--       ]
+
+buildCompletion :: T.Text -> J.CompletionItem
+buildCompletion label =
+  J.CompletionItem label (Just J.CiKeyword) Nothing Nothing
+    Nothing Nothing Nothing Nothing Nothing Nothing Nothing
+    Nothing Nothing Nothing Nothing Nothing Nothing