Refactor context search to use readFields

Instead of custom parsing of the cabal file, we use `readFields` to parse
the cabal file, as accurately as cabal supports. This allows us to
additionally benefit from future improvements to the cabal lexer.

Then, we traverse the fields and find the most likely location of the
cursor in the cabal file.
Based on these results, we can then establish the context accurately.

Author: fendor

Diff for: ghcide/src/Development/IDE/Plugin/Completions/Logic.hs

@@ -12,6 +12,7 @@ module Development.IDE.Plugin.Completions.Logic (
 , getCompletions
 , fromIdentInfo
 , getCompletionPrefix
+, getCompletionPrefixFromRope
 ) where
 
 import           Control.Applicative
@@ -898,7 +899,10 @@ mergeListsBy cmp all_lists = merge_lists all_lists
 
 -- |From the given cursor position, gets the prefix module or record for autocompletion
 getCompletionPrefix :: Position -> VFS.VirtualFile -> PosPrefixInfo
-getCompletionPrefix pos@(Position l c) (VFS.VirtualFile _ _ ropetext) =
+getCompletionPrefix pos (VFS.VirtualFile _ _ ropetext) = getCompletionPrefixFromRope pos ropetext
+
+getCompletionPrefixFromRope :: Position -> Rope.Rope -> PosPrefixInfo
+getCompletionPrefixFromRope pos@(Position l c) ropetext =
       fromMaybe (PosPrefixInfo "" "" "" pos) $ do -- Maybe monad
         let headMaybe = listToMaybe
             lastMaybe = headMaybe . reverse

Diff for: haskell-language-server.cabal

@@ -238,6 +238,7 @@ library hls-cabal-plugin
     Ide.Plugin.Cabal.Completion.Data
     Ide.Plugin.Cabal.Completion.Types
     Ide.Plugin.Cabal.LicenseSuggest
+    Ide.Plugin.Cabal.Orphans
     Ide.Plugin.Cabal.Parse
 
 

Diff for: hls-test-utils/hls-test-utils.cabal

@@ -46,6 +46,7 @@ library
     , lens
     , lsp-test                ^>=0.17
     , lsp-types               ^>=2.1
+    , neat-interpolation
     , safe-exceptions
     , tasty
     , tasty-expected-failure
@@ -54,6 +55,7 @@ library
     , tasty-rerun
     , temporary
     , text
+    , text-rope
     , row-types
   ghc-options:      -Wall -Wunused-packages
 

Diff for: hls-test-utils/src/Test/Hls/Util.hs

@@ -45,38 +45,50 @@ module Test.Hls.Util
     , withCurrentDirectoryInTmp
     , withCurrentDirectoryInTmp'
     , withCanonicalTempDir
+    -- * Extract positions from input file.
+    , extractCursorPositions
+    , trimming
   )
 where
 
-import           Control.Applicative.Combinators (skipManyTill, (<|>))
-import           Control.Exception               (catch, throwIO)
-import           Control.Lens                    (_Just, (&), (.~), (?~), (^.))
+import           Control.Applicative.Combinators          (skipManyTill, (<|>))
+import           Control.Exception                        (catch, throwIO)
+import           Control.Lens                             (_Just, (&), (.~),
+                                                           (?~), (^.))
 import           Control.Monad
 import           Control.Monad.IO.Class
-import qualified Data.Aeson                      as A
-import           Data.Bool                       (bool)
+import qualified Data.Aeson                               as A
+import           Data.Bool                                (bool)
 import           Data.Default
-import           Data.List.Extra                 (find)
+import           Data.List.Extra                          (find)
 import           Data.Proxy
 import           Data.Row
-import qualified Data.Set                        as Set
-import qualified Data.Text                       as T
-import           Development.IDE                 (GhcVersion (..), ghcVersion)
-import qualified Language.LSP.Protocol.Lens      as L
+import qualified Data.Set                                 as Set
+import qualified Data.Text                                as T
+import           Development.IDE                          (GhcVersion (..),
+                                                           ghcVersion)
+import qualified Language.LSP.Protocol.Lens               as L
 import           Language.LSP.Protocol.Message
 import           Language.LSP.Protocol.Types
-import qualified Language.LSP.Test               as Test
+import qualified Language.LSP.Test                        as Test
 import           System.Directory
 import           System.FilePath
-import           System.Info.Extra               (isMac, isWindows)
+import           System.Info.Extra                        (isMac, isWindows)
 import qualified System.IO.Extra
 import           System.IO.Temp
-import           System.Time.Extra               (Seconds, sleep)
-import           Test.Tasty                      (TestTree)
-import           Test.Tasty.ExpectedFailure      (expectFailBecause,
-                                                  ignoreTestBecause)
-import           Test.Tasty.HUnit                (Assertion, assertFailure,
-                                                  (@?=))
+import           System.Time.Extra                        (Seconds, sleep)
+import           Test.Tasty                               (TestTree)
+import           Test.Tasty.ExpectedFailure               (expectFailBecause,
+                                                           ignoreTestBecause)
+import           Test.Tasty.HUnit                         (Assertion,
+                                                           assertFailure, (@?=))
+
+import qualified Data.List                                as List
+import qualified Data.Text.Internal.Search                as T
+import qualified Data.Text.Utf16.Rope.Mixed               as Rope
+import           Development.IDE.Plugin.Completions.Logic (getCompletionPrefixFromRope)
+import           Development.IDE.Plugin.Completions.Types (PosPrefixInfo)
+import           NeatInterpolation                        (trimming)
 
 noLiteralCaps :: ClientCapabilities
 noLiteralCaps = def & L.textDocument ?~ textDocumentCaps
@@ -348,3 +360,49 @@ withCanonicalTempDir :: (FilePath -> IO a) -> IO a
 withCanonicalTempDir f = System.IO.Extra.withTempDir $ \dir -> do
   dir' <- canonicalizePath dir
   f dir'
+
+-- ----------------------------------------------------------------------------
+-- Extract Position data from the source file itself.
+-- ----------------------------------------------------------------------------
+
+data FoldState = FoldState
+    { foldStateRows      :: !Int
+    , foldStatePositions :: ![Position]
+    , foldStateFinalText :: ![T.Text]
+    }
+
+emptyFoldState :: FoldState
+emptyFoldState = FoldState
+    { foldStateRows = 0
+    , foldStatePositions = []
+    , foldStateFinalText = []
+    }
+
+foldStateToText :: FoldState -> T.Text
+foldStateToText state = T.unlines $ reverse $ foldStateFinalText state
+
+addTextCursor :: FoldState -> Int -> FoldState
+addTextCursor state col = state
+    { foldStatePositions = Position (fromIntegral (foldStateRows state) - 1) (fromIntegral col) : foldStatePositions state
+    }
+
+addTextLine :: FoldState -> T.Text -> FoldState
+addTextLine state l = state
+    { foldStateFinalText = l : foldStateFinalText state
+    , foldStateRows = foldStateRows state + 1
+    }
+
+extractCursorPositions :: T.Text -> (T.Text, [PosPrefixInfo])
+extractCursorPositions t =
+    let
+        textLines = T.lines t
+        foldState = List.foldl' go emptyFoldState textLines
+        finalText = foldStateToText foldState
+    in
+        (finalText, fmap (\pos -> getCompletionPrefixFromRope pos (Rope.fromText finalText)) $ foldStatePositions foldState)
+
+    where
+        go foldState l = case T.indices "^" l of
+            [] -> addTextLine foldState l
+            xs -> List.foldl' addTextCursor foldState xs
+

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

@@ -12,7 +12,7 @@ import           Control.DeepSeq
 import           Control.Lens                                ((^.))
 import           Control.Monad.Extra
 import           Control.Monad.IO.Class
-import           Control.Monad.Trans.Class                   (lift)
+import           Control.Monad.Trans.Class
 import           Control.Monad.Trans.Maybe                   (runMaybeT)
 import qualified Data.ByteString                             as BS
 import           Data.Hashable
@@ -27,12 +27,17 @@ import qualified Development.IDE.Core.Shake                  as Shake
 import           Development.IDE.Graph                       (alwaysRerun)
 import qualified Development.IDE.Plugin.Completions.Logic    as Ghcide
 import qualified Development.IDE.Plugin.Completions.Types    as Ghcide
+import qualified Distribution.Fields                         as Syntax
+import qualified Distribution.Parsec.Position                as Syntax
 import           GHC.Generics
 import qualified Ide.Plugin.Cabal.Completion.Completer.Types as CompleterTypes
 import qualified Ide.Plugin.Cabal.Completion.Completions     as Completions
+import           Ide.Plugin.Cabal.Completion.Types           (ParseCabalFields (..),
+                                                              ParseCabalFile (..))
 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 qualified Ide.Plugin.Cabal.Parse                      as Parse
 import           Ide.Types
 import qualified Language.LSP.Protocol.Lens                  as JL
@@ -70,7 +75,7 @@ instance Pretty Log where
       "Set files of interest to:" <+> viaShow files
     LogCompletionContext context position ->
       "Determined completion context:"
-        <+> viaShow context
+        <+> pretty context
         <+> "for cursor position:"
         <+> pretty position
     LogCompletions logs -> pretty logs
@@ -144,30 +149,55 @@ cabalRules recorder plId = do
   -- Make sure we initialise the cabal files-of-interest.
   ofInterestRules recorder
   -- Rule to produce diagnostics for cabal files.
-  define (cmapWithPrio LogShake recorder) $ \Types.GetCabalDiagnostics file -> do
+  define (cmapWithPrio LogShake recorder) $ \ParseCabalFields file -> do
     config <- getPluginConfigAction plId
     if not (plcGlobalOn config && plcDiagnosticsOn config)
-        then pure ([], Nothing)
-        else do
-          -- whenever this key is marked as dirty (e.g., when a user writes stuff to it),
-          -- we rerun this rule because this rule *depends* on GetModificationTime.
-          (t, mCabalSource) <- use_ GetFileContents file
-          log' Debug $ LogModificationTime file t
-          contents <- case mCabalSource of
-            Just sources ->
-              pure $ Encoding.encodeUtf8 sources
-            Nothing -> do
-              liftIO $ BS.readFile $ fromNormalizedFilePath file
-
-          (pWarnings, pm) <- liftIO $ Parse.parseCabalFileContents contents
-          let warningDiags = fmap (Diagnostics.warningDiagnostic file) pWarnings
-          case pm of
-            Left (_cabalVersion, pErrorNE) -> do
-              let errorDiags = NE.toList $ NE.map (Diagnostics.errorDiagnostic file) pErrorNE
-                  allDiags = errorDiags <> warningDiags
-              pure (allDiags, Nothing)
-            Right gpd -> do
-              pure (warningDiags, Just gpd)
+      then pure ([], Nothing)
+      else do
+        -- whenever this key is marked as dirty (e.g., when a user writes stuff to it),
+        -- we rerun this rule because this rule *depends* on GetModificationTime.
+        (t, mCabalSource) <- use_ GetFileContents file
+        log' Debug $ LogModificationTime file t
+        contents <- case mCabalSource of
+          Just sources ->
+            pure $ Encoding.encodeUtf8 sources
+          Nothing -> do
+            liftIO $ BS.readFile $ fromNormalizedFilePath file
+
+        case Parse.readCabalFields file contents of
+          Left _ ->
+            pure ([], Nothing)
+          Right fields ->
+            pure ([], Just fields)
+
+  define (cmapWithPrio LogShake recorder) $ \ParseCabalFile file -> do
+    config <- getPluginConfigAction plId
+    if not (plcGlobalOn config && plcDiagnosticsOn config)
+      then pure ([], Nothing)
+      else do
+        -- whenever this key is marked as dirty (e.g., when a user writes stuff to it),
+        -- we rerun this rule because this rule *depends* on GetModificationTime.
+        (t, mCabalSource) <- use_ GetFileContents file
+        log' Debug $ LogModificationTime file t
+        contents <- case mCabalSource of
+          Just sources ->
+            pure $ Encoding.encodeUtf8 sources
+          Nothing -> do
+            liftIO $ BS.readFile $ fromNormalizedFilePath file
+
+        -- Instead of fully reparsing the sources to get a 'GenericPackageDescription',
+        -- we would much rather re-use the already parsed results of 'ParseCabalFields'.
+        -- Unfortunately, Cabal-syntax doesn't expose the function 'parseGenericPackageDescription''
+        -- which allows us to resume the parsing pipeline with '[Field Position]'.
+        (pWarnings, pm) <- liftIO $ Parse.parseCabalFileContents contents
+        let warningDiags = fmap (Diagnostics.warningDiagnostic file) pWarnings
+        case pm of
+          Left (_cabalVersion, pErrorNE) -> do
+            let errorDiags = NE.toList $ NE.map (Diagnostics.errorDiagnostic file) pErrorNE
+                allDiags = errorDiags <> warningDiags
+            pure (allDiags, Nothing)
+          Right gpd -> do
+            pure (warningDiags, Just gpd)
 
   action $ do
     -- Run the cabal kick. This code always runs when 'shakeRestart' is run.
@@ -187,7 +217,7 @@ function invocation.
 kick :: Action ()
 kick = do
   files <- HashMap.keys <$> getCabalFilesOfInterestUntracked
-  void $ uses Types.GetCabalDiagnostics files
+  void $ uses Types.ParseCabalFile files
 
 -- ----------------------------------------------------------------
 -- Code Actions
@@ -278,24 +308,31 @@ completion :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'LSP.M
 completion recorder ide _ complParams = do
   let (TextDocumentIdentifier uri) = complParams ^. JL.textDocument
       position = complParams ^. JL.position
-  contents <- lift $ getVirtualFile $ toNormalizedUri uri
-  case (contents, uriToFilePath' uri) of
-    (Just cnts, Just path) -> do
-      let pref = Ghcide.getCompletionPrefix position cnts
-      let res = result pref path cnts
-      liftIO $ fmap InL res
-    _ -> pure . InR $ InR Null
+  mVf <- lift $ getVirtualFile $ toNormalizedUri uri
+  case (,) <$> mVf <*> uriToFilePath' uri of
+    Just (cnts, path) -> do
+      mFields <- liftIO $ runIdeAction "cabal-plugin.fields" (shakeExtras ide) $ useWithStaleFast ParseCabalFields $ toNormalizedFilePath path
+      case mFields of
+        Nothing ->
+          pure . InR $ InR Null
+        Just (fields, _) -> do
+          let pref = Ghcide.getCompletionPrefix position cnts
+          let res = produceCompletions pref path fields
+          liftIO $ fmap InL res
+    Nothing -> pure . InR $ InR Null
  where
-  result :: Ghcide.PosPrefixInfo -> FilePath -> VFS.VirtualFile -> IO [CompletionItem]
-  result prefix fp cnts = do
-    runMaybeT context >>= \case
+  completerRecorder = cmapWithPrio LogCompletions recorder
+
+  produceCompletions :: Ghcide.PosPrefixInfo -> FilePath -> [Syntax.Field Syntax.Position] -> IO [CompletionItem]
+  produceCompletions prefix fp fields = do
+    runMaybeT (context fields) >>= \case
       Nothing -> pure []
       Just ctx -> do
         logWith recorder Debug $ LogCompletionContext ctx pos
         let completer = Completions.contextToCompleter ctx
         let completerData = CompleterTypes.CompleterData
               { getLatestGPD = do
-                mGPD <- runIdeAction "cabal-plugin.modulesCompleter.gpd" (shakeExtras ide) $ useWithStaleFast Types.GetCabalDiagnostics $ toNormalizedFilePath fp
+                mGPD <- runIdeAction "cabal-plugin.modulesCompleter.gpd" (shakeExtras ide) $ useWithStaleFast ParseCabalFile $ toNormalizedFilePath fp
                 pure $ fmap fst mGPD
               , cabalPrefixInfo = prefInfo
               , stanzaName =
@@ -306,7 +343,6 @@ completion recorder ide _ complParams = do
         completions <- completer completerRecorder completerData
         pure completions
    where
-    completerRecorder = cmapWithPrio LogCompletions recorder
     pos = Ghcide.cursorPos prefix
-    context = Completions.getContext completerRecorder prefInfo (cnts ^. VFS.file_text)
+    context fields = Completions.getContext completerRecorder prefInfo fields
     prefInfo = Completions.getCabalPrefixInfo fp prefix