add tests for cabal goto-definition

Author: ChristophHochrainer

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 qualified Language.LSP.Protocol.Types     as LSP
 import           Outline                         (outlineTests)
 import           System.FilePath
 import           Test.Hls
@@ -36,6 +37,7 @@ main = do
             , contextTests
             , outlineTests
             , codeActionTests
+            , gotoDefinitionTests
             ]
 
 -- ------------------------------------------------------------------------
@@ -227,3 +229,56 @@ codeActionTests = testGroup "Code Actions"
         InR action@CodeAction{_title} <- codeActions
         guard (_title == "Replace with " <> license)
         pure action
+
+-- ----------------------------------------------------------------------------
+-- Goto Definition Tests
+-- ----------------------------------------------------------------------------
+
+gotoDefinitionTests :: TestTree
+gotoDefinitionTests = testGroup "Goto Definition"
+    [ positiveTest "middle of identifier"            (mkP 27 16) (mkR  6 0  7 22)
+    , positiveTest "left of identifier"              (mkP 30 12) (mkR 10 0 17 40)
+    , positiveTest "right of identifier"             (mkP 33 22) (mkR 20 0 23 34)
+    , positiveTest "left of '-' in identifier"       (mkP 36 20) (mkR  6 0  7 22)
+    , positiveTest "right of '-' in identifier"      (mkP 39 19) (mkR 10 0 17 40)
+    , positiveTest "identifier in identifier list"   (mkP 42 16) (mkR 20 0 23 34)
+    , positiveTest "left of ',' right of identifier" (mkP 45 33) (mkR 10 0 17 40)
+    , positiveTest "right of ',' left of identifier" (mkP 48 34) (mkR  6 0  7 22)
+
+    , negativeTest "right of ',' left of space"      (mkP 51 23)
+    , negativeTest "right of ':' left of space"      (mkP 54 11)
+    , negativeTest "not a definition"                (mkP 57 8)
+    , negativeTest "empty space"                     (mkP 59 7)
+    ]
+    where
+        mkP :: UInt -> UInt -> Position
+        mkP x1 y1 = Position x1 y1
+
+        mkR :: UInt -> UInt -> UInt -> UInt -> Range
+        mkR x1 y1 x2 y2 = Range (mkP x1 y1) (mkP x2 y2)
+
+        getDefinition :: Show b => (Definition |? b) -> Range
+        getDefinition (InL (Definition (InL loc))) = loc^.L.range
+        getDefinition unk = error $ "Unexpected pattern '" ++ show unk ++ "' , expected '(InL (Definition (InL loc))'"
+
+        -- A positive tests checks if the provided range is equal
+        -- to the expected range from the definition in the test file.
+        -- The test emulates a goto-definition request of an actual definition.
+        positiveTest :: TestName -> Position -> Range -> TestTree
+        positiveTest testName cursorPos expectedRange =
+            runCabalTestCaseSession testName "goto-definition" $ do
+                doc <- openDoc "simple-with-common.cabal" "cabal"
+                definitions <- getDefinitions doc cursorPos
+                let locationRange = getDefinition definitions
+                liftIO $ locationRange @?= expectedRange
+
+        -- A negative tests checks if the request failed and
+        -- the provided result is empty, i.e. `InR $ InR Null`.
+        -- The test emulates a goto-definition request of anything but an
+        -- actual definition.
+        negativeTest :: TestName -> Position -> TestTree
+        negativeTest testName cursorPos =
+            runCabalTestCaseSession testName "goto-definition" $ do
+                doc <- openDoc "simple-with-common.cabal" "cabal"
+                empty <- getDefinitions doc cursorPos
+                liftIO $ empty @?= (InR $ InR LSP.Null)

plugins/hls-cabal-plugin/test/testdata/goto-definition/simple-with-common.cabal

@@ -0,0 +1,62 @@
+cabal-version:      3.0
+name:               simple-cabal
+version:            0.1.0.0
+license:            MIT
+
+-- Range : (6, 0) - (7, 22)
+common warnings-0
+    ghc-options: -Wall
+
+-- Range : (10, 0) - (17, 40)
+common warnings-1
+    ghc-options: -Wall
+                        -Wredundant-constraints
+                 -Wunused-packages
+
+     -Wno-name-shadowing
+
+     -Wno-unticked-promoted-constructors
+
+-- Range : (20, 0) - (23, 34)
+common warnings-2
+    ghc-options: -Wall
+                 -Wredundant-constraints
+                 -Wunused-packages
+
+library
+
+    import: warnings-0
+--              ^ Position: (27, 16), middle of identifier
+
+    import: warnings-1
+--          ^ Position: (30, 12), left of identifier
+    
+    import: warnings-2
+--                   ^ Position: (33, 22), right of identifier
+
+    import: warnings-0
+--                  ^ Position: (36, 20), left of '-' in identifier
+
+    import: warnings-1
+--                  ^ Position: (39, 19), right of "-" in identifier
+
+    import: warnings-2,warnings-1,warnings-0
+--              ^ Position: (42, 16), identifier in identifier list
+
+    import: warnings-2,warnings-1,warnings-0
+--                               ^ Position: (45, 33), left of ',' right of identifier
+
+    import: warnings-2,warnings-1,warnings-0
+--                               ^ Position: (48, 34), right of ',' left of identifier
+
+    import: warnings-2, warnings-1,warnings-0
+--                    ^ Position: (51, 37), right of ',' left of space
+
+    import: warnings-0
+--        ^ Position: (54, 11), right of ':' left of space
+
+    import: warnings-0
+--     ^ Position: (57, 8), not a definition
+
+          -- EOL
+--     ^ Position: (59, 7), empty space