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

ghcide/src/Development/IDE/Plugin/Completions/Logic.hs

@@ -11,6 +11,7 @@ module Development.IDE.Plugin.Completions.Logic (
 , getCompletions
 , fromIdentInfo
 , getCompletionPrefix
+, getCompletionPrefixFromRope
 ) where
 
 import           Control.Applicative
@@ -897,7 +898,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

haskell-language-server.cabal

@@ -241,6 +241,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
 
 

hls-test-utils/hls-test-utils.cabal

@@ -49,6 +49,7 @@ library
     , lsp
     , lsp-test                ^>=0.17
     , lsp-types               ^>=2.2
+    , neat-interpolation
     , safe-exceptions
     , tasty
     , tasty-expected-failure
@@ -57,6 +58,7 @@ library
     , tasty-rerun
     , temporary
     , text
+    , text-rope
 
   ghc-options:
     -Wall

hls-test-utils/src/Test/Hls.hs

@@ -34,6 +34,8 @@ module Test.Hls
     runSessionWithServer,
     runSessionWithServerInTmpDir,
     runSessionWithTestConfig,
+    -- * Running parameterised tests for a set of test configurations
+    parameterisedCursorTest,
     -- * Helpful re-exports
     PluginDescriptor,
     IdeState,
@@ -87,7 +89,6 @@ import           Development.IDE                    (IdeState,
                                                      LoggingColumn (ThreadIdColumn),
                                                      defaultLayoutOptions,
                                                      layoutPretty, renderStrict)
-import qualified Development.IDE.LSP.Notifications  as Notifications
 import           Development.IDE.Main               hiding (Log)
 import qualified Development.IDE.Main               as IDEMain
 import           Development.IDE.Plugin.Test        (TestRequest (GetBuildKeysBuilt, WaitForIdeRule, WaitForShakeQueue),
@@ -105,7 +106,6 @@ import           Ide.Logger                         (Pretty (pretty),
                                                      makeDefaultStderrRecorder,
                                                      (<+>))
 import qualified Ide.Logger                         as Logger
-import           Ide.Plugin.Properties              ((&))
 import           Ide.PluginUtils                    (idePluginsToPluginDesc,
                                                      pluginDescToIdePlugins)
 import           Ide.Types
@@ -136,6 +136,7 @@ import           Test.Tasty.ExpectedFailure
 import           Test.Tasty.Golden
 import           Test.Tasty.HUnit
 import           Test.Tasty.Ingredients.Rerun
+import Development.IDE.Plugin.Completions.Types (PosPrefixInfo)
 
 data Log
   = LogIDEMain IDEMain.Log
@@ -328,6 +329,56 @@ goldenWithDocInTmpDir languageKind config plugin title tree path desc ext act =
     act doc
     documentContents doc
 
+-- | A parameterised test is similar to a normal test case but allows to run
+-- the same test case multiple times with different inputs.
+-- A 'parameterisedCursorTest' allows to define a test case based on an input file
+-- that specifies one or many cursor positions via the identification value '^'.
+--
+-- For example:
+--
+-- @
+--  parameterisedCursorTest "Cursor Test" [trimming|
+--       foo = 2
+--        ^
+--       bar = 3
+--       baz = foo + bar
+--         ^
+--       |]
+--       ["foo", "baz"]
+--       (\input cursor -> findFunctionNameUnderCursor input cursor)
+-- @
+--
+-- Assuming a fitting implementation for 'findFunctionNameUnderCursor'.
+--
+-- This test definition will run the test case 'findFunctionNameUnderCursor' for
+-- each cursor position, each in its own isolated 'testCase'.
+-- Cursor positions are identified via the character '^', which points to the
+-- above line as the actual cursor position.
+-- Lines containing '^' characters, are removed from the final text, that is
+-- passed to the testing function.
+--
+-- TODO: Many Haskell and Cabal source may contain '^' characters for good reasons.
+-- We likely need a way to change the character for certain test cases in the future.
+--
+-- The quasi quoter 'trimming' is very helpful to define such tests, as it additionally
+-- allows to interpolate haskell values and functions. We reexport this quasi quoter
+-- for easier usage.
+parameterisedCursorTest :: (Show a, Eq a) => String -> T.Text -> [a] -> (T.Text -> PosPrefixInfo -> IO a) -> TestTree
+parameterisedCursorTest title content expectations act
+  | lenPrefs /= lenExpected = error $ "parameterisedCursorTest: Expected " <> show lenExpected <> " cursors but found: " <> show lenPrefs
+  | otherwise = testGroup title $
+      map singleTest testCaseSpec
+  where
+    lenPrefs = length prefInfos
+    lenExpected = length expectations
+    (cleanText, prefInfos) = extractCursorPositions content
+
+    testCaseSpec = zip [1 ::Int ..] (zip expectations prefInfos)
+
+    singleTest (n, (expected, info)) = testCase (title <> " " <> show n) $ do
+      actual <- act cleanText info
+      assertEqual (mkParameterisedLabel info) expected actual
+
 -- ------------------------------------------------------------
 -- Helper function for initialising plugins under test
 -- ------------------------------------------------------------
@@ -429,6 +480,7 @@ initializeTestRecorder envVars = do
 -- ------------------------------------------------------------
 -- Run an HLS server testing a specific plugin
 -- ------------------------------------------------------------
+
 runSessionWithServerInTmpDir :: Pretty b => Config -> PluginTestDescriptor b -> VirtualFileTree -> Session a -> IO a
 runSessionWithServerInTmpDir config plugin tree act =
     runSessionWithTestConfig def

hls-test-utils/src/Test/Hls/Util.hs

@@ -42,37 +42,48 @@ module Test.Hls.Util
     , withCurrentDirectoryInTmp
     , withCurrentDirectoryInTmp'
     , withCanonicalTempDir
+    -- * Extract positions from input file.
+    , extractCursorPositions
+    , mkParameterisedLabel
+    , 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 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.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                         (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
@@ -327,3 +338,119 @@ 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.
+-- ----------------------------------------------------------------------------
+
+-- | Pretty labelling for tests that use the parameterised test helpers.
+mkParameterisedLabel :: PosPrefixInfo -> String
+mkParameterisedLabel posPrefixInfo = unlines
+    [ "Full Line:       \"" <> T.unpack (fullLine posPrefixInfo) <> "\""
+    , "Cursor Column:   \"" <> replicate (fromIntegral $ cursorPos posPrefixInfo ^. L.character) ' ' ++ "^" <> "\""
+    , "Prefix Text:     \"" <> T.unpack (prefixText posPrefixInfo) <> "\""
+    ]
+
+-- | Given a in-memory representation of a file, where a user can specify the
+-- current cursor position using a '^' in the next line.
+--
+-- This function allows to generate multiple tests for a single input file, without
+-- the hassle of calculating by hand where there cursor is supposed to be.
+--
+-- Example (line number has been added for readability):
+--
+-- @
+--   0: foo = 2
+--   1:  ^
+--   2: bar =
+--   3:      ^
+-- @
+--
+-- This example input file contains two cursor positions (y, x), at
+--
+-- * (1, 1), and
+-- * (3, 5).
+--
+-- 'extractCursorPositions' will search for '^' characters, and determine there are
+-- two cursor positions in the text.
+-- First, it will normalise the text to:
+--
+-- @
+--   0: foo = 2
+--   1: bar =
+-- @
+--
+-- stripping away the '^' characters. Then, the actual cursor positions are:
+--
+-- * (0, 1) and
+-- * (2, 5).
+--
+extractCursorPositions :: T.Text -> (T.Text, [PosPrefixInfo])
+extractCursorPositions t =
+    let
+        textLines = T.lines t
+        foldState = List.foldl' go emptyFoldState textLines
+        finalText = foldStateToText foldState
+        reconstructCompletionPrefix pos = getCompletionPrefixFromRope pos (Rope.fromText finalText)
+        cursorPositions = reverse . fmap reconstructCompletionPrefix $ foldStatePositions foldState
+    in
+        (finalText, cursorPositions)
+
+    where
+        go foldState l = case T.indices "^" l of
+            [] -> addTextLine foldState l
+            xs -> List.foldl' addTextCursor foldState xs
+
+-- | 'FoldState' is an implementation detail used to parse some file contents,
+-- extracting the cursor positions identified by '^' and producing a cleaned
+-- representation of the file contents.
+data FoldState = FoldState
+    { foldStateRows      :: !Int
+    -- ^ The row index of the cleaned file contents.
+    --
+    -- For example, the file contents
+    --
+    -- @
+    --   0: foo
+    --   1: ^
+    --   2: bar
+    -- @
+    -- will report that 'bar' is actually occurring in line '1', as '^' is
+    -- a cursor position.
+    -- Lines containing cursor positions are removed.
+    , foldStatePositions :: ![Position]
+    -- ^ List of cursors positions found in the file contents.
+    --
+    -- List is stored in reverse for efficient 'cons'ing
+    , foldStateFinalText :: ![T.Text]
+    -- ^ Final file contents with all lines containing cursor positions removed.
+    --
+    -- List is stored in reverse for efficient 'cons'ing
+    }
+
+emptyFoldState :: FoldState
+emptyFoldState = FoldState
+    { foldStateRows = 0
+    , foldStatePositions = []
+    , foldStateFinalText = []
+    }
+
+-- | Produce the final file contents, without any lines containing cursor positions.
+foldStateToText :: FoldState -> T.Text
+foldStateToText state = T.unlines $ reverse $ foldStateFinalText state
+
+-- | We found a '^' at some location! Add it to the list of known cursor positions.
+--
+-- If the row index is '0', we throw an error, as there can't be a cursor position above the first line.
+addTextCursor :: FoldState -> Int -> FoldState
+addTextCursor state col
+    | foldStateRows state <= 0 = error $ "addTextCursor: Invalid '^' found at: " <> show (col, foldStateRows state)
+    | otherwise = 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
+    }