diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index e89f22ad8a..748db2b405 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -242,6 +242,7 @@ library hls-cabal-plugin Ide.Plugin.Cabal.Completion.Completions Ide.Plugin.Cabal.Completion.Data Ide.Plugin.Cabal.Completion.Types + Ide.Plugin.Cabal.Definition Ide.Plugin.Cabal.FieldSuggest Ide.Plugin.Cabal.LicenseSuggest Ide.Plugin.Cabal.CabalAdd @@ -287,11 +288,12 @@ test-suite hls-cabal-plugin-tests hs-source-dirs: plugins/hls-cabal-plugin/test main-is: Main.hs other-modules: + CabalAdd Completer Context - Utils + Definition Outline - CabalAdd + Utils build-depends: , base , bytestring diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs index 03e8fbfdff..8973f4401d 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs @@ -17,14 +17,12 @@ import qualified Data.ByteString as BS import Data.Hashable import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap -import Data.List (find) import qualified Data.List.NonEmpty as NE import qualified Data.Maybe as Maybe import qualified Data.Text as T import qualified Data.Text.Encoding as Encoding import Data.Typeable import Development.IDE as D -import Development.IDE.Core.PluginUtils import Development.IDE.Core.Shake (restartShakeSession) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Graph (Key, alwaysRerun) @@ -33,20 +31,19 @@ import Development.IDE.Types.Shake (toKey) import qualified Distribution.Fields as Syntax import qualified Distribution.Parsec.Position as Syntax import GHC.Generics -import Ide.Plugin.Cabal.Completion.CabalFields as CabalFields 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 (ParseCabalCommonSections (ParseCabalCommonSections), ParseCabalFields (..), ParseCabalFile (..)) import qualified Ide.Plugin.Cabal.Completion.Types as Types +import Ide.Plugin.Cabal.Definition (gotoDefinition) import qualified Ide.Plugin.Cabal.Diagnostics as Diagnostics import qualified Ide.Plugin.Cabal.FieldSuggest as FieldSuggest 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.Plugin.Error import Ide.Types import qualified Language.LSP.Protocol.Lens as JL import qualified Language.LSP.Protocol.Message as LSP @@ -305,32 +302,6 @@ fieldSuggestCodeAction recorder ide _ (CodeActionParams _ _ (TextDocumentIdentif let completionTexts = fmap (^. JL.label) completions pure $ FieldSuggest.fieldErrorAction uri fieldName completionTexts _range --- | CodeActions for going to definitions. --- --- Provides a CodeAction for going to a definition when clicking on an identifier. --- The definition is found by traversing the sections and comparing their name to --- the clicked identifier. --- --- TODO: Support more definitions than sections. -gotoDefinition :: PluginMethodHandler IdeState LSP.Method_TextDocumentDefinition -gotoDefinition ideState _ msgParam = do - nfp <- getNormalizedFilePathE uri - cabalFields <- runActionE "cabal-plugin.commonSections" ideState $ useE ParseCabalFields nfp - case CabalFields.findTextWord cursor cabalFields of - Nothing -> - pure $ InR $ InR Null - Just cursorText -> do - commonSections <- runActionE "cabal-plugin.commonSections" ideState $ useE ParseCabalCommonSections nfp - case find (isSectionArgName cursorText) commonSections of - Nothing -> - pure $ InR $ InR Null - Just commonSection -> do - pure $ InL $ Definition $ InL $ Location uri $ CabalFields.getFieldLSPRange commonSection - where - cursor = Types.lspPositionToCabalPosition (msgParam ^. JL.position) - uri = msgParam ^. JL.textDocument . JL.uri - isSectionArgName name (Syntax.Section _ sectionArgName _) = name == CabalFields.onelineSectionArgs sectionArgName - isSectionArgName _ _ = False cabalAddCodeAction :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction cabalAddCodeAction state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) _ CodeActionContext{_diagnostics=diags}) = do diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/CabalFields.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/CabalFields.hs index 81b316463b..b8cb7ce0d6 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/CabalFields.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Completion/CabalFields.hs @@ -1,25 +1,29 @@ module Ide.Plugin.Cabal.Completion.CabalFields - ( findStanzaForColumn, - findFieldSection, - findTextWord, - findFieldLine, - getOptionalSectionName, - getAnnotation, - getFieldName, - onelineSectionArgs, - getFieldEndPosition, - getSectionArgEndPosition, - getNameEndPosition, - getFieldLineEndPosition, - getFieldLSPRange - ) where + ( findStanzaForColumn + , getModulesNames + , getFieldLSPRange + , findFieldSection + , findTextWord + , findFieldLine + , getOptionalSectionName + , getAnnotation + , getFieldName + , onelineSectionArgs + , getFieldEndPosition + , getSectionArgEndPosition + , getNameEndPosition + , getFieldLineEndPosition + ) + where import qualified Data.ByteString as BS import Data.List (find) +import Data.List.Extra (groupSort) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE import qualified Data.Text as T import qualified Data.Text.Encoding as T +import Data.Tuple (swap) import qualified Distribution.Fields as Syntax import qualified Distribution.Parsec.Position as Syntax import Ide.Plugin.Cabal.Completion.Types @@ -138,6 +142,9 @@ getFieldName :: Syntax.Field ann -> FieldName getFieldName (Syntax.Field (Syntax.Name _ fn) _) = T.decodeUtf8 fn getFieldName (Syntax.Section (Syntax.Name _ fn) _ _) = T.decodeUtf8 fn +getFieldLineName :: Syntax.FieldLine ann -> FieldName +getFieldLineName (Syntax.FieldLine _ fn) = T.decodeUtf8 fn + -- | Returns the name of a section if it has a name. -- -- This assumes that the given section args belong to named stanza @@ -148,6 +155,107 @@ getOptionalSectionName (x:xs) = case x of Syntax.SecArgName _ name -> Just (T.decodeUtf8 name) _ -> getOptionalSectionName xs +type BuildTargetName = T.Text +type ModuleName = T.Text + +-- | Given a cabal AST returns pairs of all respective target names +-- and the module name bound to them. If a target is a main library gives +-- @Nothing@, otherwise @Just target-name@ +-- +-- Examples of input cabal files and the outputs: +-- +-- * Target is a main library module: +-- +-- > library +-- > exposed-modules: +-- > MyLib +-- +-- * @getModulesNames@ output: +-- +-- > [([Nothing], "MyLib")] +-- +-- * Same module names in different targets: +-- +-- > test-suite first-target +-- > other-modules: +-- > Config +-- > test-suite second-target +-- > other-modules: +-- > Config +-- +-- * @getModulesNames@ output: +-- +-- > [([Just "first-target", Just "second-target"], "Config")] +getModulesNames :: [Syntax.Field any] -> [([Maybe BuildTargetName], ModuleName)] +getModulesNames fields = map swap $ groupSort rawModuleTargetPairs + where + rawModuleTargetPairs = concatMap getSectionModuleNames sections + sections = getSectionsWithModules fields + + getSectionModuleNames :: Syntax.Field any -> [(ModuleName, Maybe BuildTargetName)] + getSectionModuleNames (Syntax.Section _ secArgs fields) = map (, getArgsName secArgs) $ concatMap getFieldModuleNames fields + getSectionModuleNames _ = [] + + getArgsName [Syntax.SecArgName _ name] = Just $ T.decodeUtf8 name + getArgsName _ = Nothing -- Can be only a main library, that has no name + -- since it's impossible to have multiple names for a build target + + getFieldModuleNames field@(Syntax.Field _ modules) = if getFieldName field == T.pack "exposed-modules" || + getFieldName field == T.pack "other-modules" + then map getFieldLineName modules + else [] + getFieldModuleNames _ = [] + +-- | Trims a given cabal AST leaving only targets and their +-- @exposed-modules@ and @other-modules@ sections. +-- +-- For example: +-- +-- * Given a cabal file like this: +-- +-- > library +-- > import: extra +-- > hs-source-dirs: source/directory +-- > ... +-- > exposed-modules: +-- > Important.Exposed.Module +-- > other-modules: +-- > Important.Other.Module +-- > +-- > test-suite tests +-- > type: type +-- > build-tool-depends: tool +-- > other-modules: +-- > Important.Other.Module +-- +-- * @getSectionsWithModules@ gives output: +-- +-- > library +-- > exposed-modules: +-- > Important.Exposed.Module +-- > other-modules: +-- > Important.Other.Module +-- > test-suite tests +-- > other-modules: +-- > Important.Other.Module +getSectionsWithModules :: [Syntax.Field any] -> [Syntax.Field any] +getSectionsWithModules fields = concatMap go fields + where + go :: Syntax.Field any -> [Syntax.Field any] + go (Syntax.Field _ _) = [] + go section@(Syntax.Section _ _ fields) = concatMap onlySectionsWithModules (section:fields) + + onlySectionsWithModules :: Syntax.Field any -> [Syntax.Field any] + onlySectionsWithModules (Syntax.Field _ _) = [] + onlySectionsWithModules (Syntax.Section name secArgs fields) + | (not . null) newFields = [Syntax.Section name secArgs newFields] + | otherwise = [] + where newFields = filter subfieldHasModule fields + + subfieldHasModule :: Syntax.Field any -> Bool + subfieldHasModule field@(Syntax.Field _ _) = getFieldName field == T.pack "exposed-modules" || + getFieldName field == T.pack "other-modules" + subfieldHasModule (Syntax.Section _ _ _) = False -- | Makes a single text line out of multiple -- @SectionArg@s. Allows to display conditions, @@ -165,7 +273,6 @@ onelineSectionArgs sectionArgs = joinedName getName (Syntax.SecArgStr _ quotedString) = T.decodeUtf8 quotedString getName (Syntax.SecArgOther _ string) = T.decodeUtf8 string - -- | Returns the end position of a provided field getFieldEndPosition :: Syntax.Field Syntax.Position -> Syntax.Position getFieldEndPosition (Syntax.Field name []) = getNameEndPosition name diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Definition.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Definition.hs new file mode 100644 index 0000000000..5f85151199 --- /dev/null +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Definition.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} + +module Ide.Plugin.Cabal.Definition where + +import Control.Lens ((^.)) +import Control.Monad.Extra +import Control.Monad.IO.Class +import Data.List (find) +import qualified Data.Maybe as Maybe +import qualified Data.Text as T +import Development.IDE as D +import Development.IDE.Core.PluginUtils +import qualified Distribution.Fields as Syntax +import Distribution.PackageDescription (Benchmark (..), + BuildInfo (..), + Executable (..), + ForeignLib (..), + GenericPackageDescription, + Library (..), + LibraryName (LMainLibName, LSubLibName), + PackageDescription (..), + TestSuite (..), + library, + unUnqualComponentName) +import Distribution.PackageDescription.Configuration (flattenPackageDescription) +import qualified Distribution.Parsec.Position as Syntax +import Distribution.Utils.Generic (safeHead) +import Distribution.Utils.Path (getSymbolicPath) +import Ide.Plugin.Cabal.Completion.CabalFields as CabalFields +import Ide.Plugin.Cabal.Completion.Types (ParseCabalCommonSections (ParseCabalCommonSections), + ParseCabalFields (..), + ParseCabalFile (..)) +import qualified Ide.Plugin.Cabal.Completion.Types as Types +import Ide.Plugin.Cabal.Orphans () +import Ide.Plugin.Error +import Ide.Types +import qualified Language.LSP.Protocol.Lens as JL +import qualified Language.LSP.Protocol.Message as LSP +import Language.LSP.Protocol.Types +import System.Directory (doesFileExist) +import System.FilePath (joinPath, + takeDirectory, + (<.>), ()) + +-- | Handler for going to definitions. +-- +-- Provides a handler for going to the definition in a cabal file, +-- gathering all possible definitions by calling subfunctions. + +-- TODO: Resolve more cases for go-to definition. +gotoDefinition :: PluginMethodHandler IdeState LSP.Method_TextDocumentDefinition +gotoDefinition ide _ msgParam = do + nfp <- getNormalizedFilePathE uri + cabalFields <- runActionE "cabal-plugin.commonSections" ide $ useE ParseCabalFields nfp + -- Trim the AST tree, so multiple passes in subfunctions won't hurt the performance. + let fieldsOfInterest = maybe cabalFields (:[] ) $ CabalFields.findFieldSection cursor cabalFields + + commonSections <- runActionE "cabal-plugin.commonSections" ide $ useE ParseCabalCommonSections nfp + let mCommonSectionsDef = gotoCommonSectionDefinition uri commonSections cursor fieldsOfInterest + + mModuleDef <- do + mGPD <- liftIO $ runAction "cabal.GPD" ide $ useWithStale ParseCabalFile nfp + case mGPD of + Nothing -> pure Nothing + Just (gpd, _) -> liftIO $ gotoModulesDefinition nfp gpd cursor fieldsOfInterest + + let defs = Maybe.catMaybes [ mCommonSectionsDef + , mModuleDef + ] + -- Take first found definition. + -- We assume, that there can't be multiple definitions, + -- or the most specific definitions come first. + case safeHead defs of + Nothing -> pure $ InR $ InR Null + Just def -> pure $ InL def + where + cursor = Types.lspPositionToCabalPosition (msgParam ^. JL.position) + uri = msgParam ^. JL.textDocument . JL.uri + +-- | Definitions for Sections. +-- +-- Provides a Definition if cursor is pointed at an identifier, +-- otherwise gives Nothing. +-- The definition is found by traversing the sections and comparing their name to +-- the clicked identifier. +gotoCommonSectionDefinition + :: Uri -- ^ Cabal file URI + -> [Syntax.Field Syntax.Position] -- ^ Found common sections + -> Syntax.Position -- ^ Cursor position + -> [Syntax.Field Syntax.Position] -- ^ Trimmed cabal AST on a cursor + -> Maybe Definition +gotoCommonSectionDefinition uri commonSections cursor fieldsOfInterest = do + cursorText <- CabalFields.findTextWord cursor fieldsOfInterest + commonSection <- find (isSectionArgName cursorText) commonSections + Just $ Definition $ InL $ Location uri $ CabalFields.getFieldLSPRange commonSection + where + isSectionArgName name (Syntax.Section _ sectionArgName _) = name == CabalFields.onelineSectionArgs sectionArgName + isSectionArgName _ _ = False + +-- | Definitions for Modules. +-- +-- Provides a Definition if cursor is pointed at a +-- exposed-module or other-module field, otherwise gives Nothing +-- +-- Definition is found by looking for a module name, +-- the cursor is pointing to and looking for it in @BuildInfo@s. +-- Note that since a trimmed ast is provided, a @Definition@ to +-- a module with the same name as the target one, +-- but in another build target can't be given. +-- +-- See resolving @Config@ module in tests. +gotoModulesDefinition + :: NormalizedFilePath -- ^ Normalized FilePath to the cabal file + -> GenericPackageDescription + -> Syntax.Position -- ^ Cursor position + -> [Syntax.Field Syntax.Position] -- ^ Trimmed cabal AST on a cursor + -> IO (Maybe Definition) +gotoModulesDefinition nfp gpd cursor fieldsOfInterest = do + let mCursorText = CabalFields.findTextWord cursor fieldsOfInterest + moduleNames = CabalFields.getModulesNames fieldsOfInterest + mModuleName = find (isModuleName mCursorText) moduleNames + + case mModuleName of + Nothing -> pure Nothing + Just (mBuildTargetNames, moduleName) -> do + let buildInfos = foldMap (lookupBuildTargetPackageDescription + (flattenPackageDescription gpd)) + mBuildTargetNames + sourceDirs = map getSymbolicPath $ concatMap hsSourceDirs buildInfos + potentialPaths = map (\dir -> takeDirectory (fromNormalizedFilePath nfp) dir toHaskellFile moduleName) sourceDirs + allPaths <- liftIO $ filterM doesFileExist potentialPaths + -- Don't provide the range, since there is little benefit for it + let locations = map (\pth -> Location (filePathToUri pth) (mkRange 0 0 0 0)) allPaths + case safeHead locations of -- We assume there could be only one source location + Nothing -> pure Nothing + Just location -> pure $ Just $ Definition $ InL location + where + isModuleName (Just name) (_, moduleName) = name == moduleName + isModuleName _ _ = False + +-- | Gives all `buildInfo`s given a target name. +-- +-- `Maybe buildTargetName` is provided, and if it's +-- Nothing we assume, that it's a main library. +-- Otherwise looks for the provided name. +lookupBuildTargetPackageDescription :: PackageDescription -> Maybe T.Text -> [BuildInfo] +lookupBuildTargetPackageDescription (PackageDescription {..}) Nothing = + case library of + Nothing -> [] -- Target is a main library but no main library was found + Just (Library {libBuildInfo}) -> [libBuildInfo] +lookupBuildTargetPackageDescription (PackageDescription {..}) (Just buildTargetName) = + Maybe.catMaybes $ + map executableNameLookup executables <> + map subLibraryNameLookup subLibraries <> + map foreignLibsNameLookup foreignLibs <> + map testSuiteNameLookup testSuites <> + map benchmarkNameLookup benchmarks + where + executableNameLookup :: Executable -> Maybe BuildInfo + executableNameLookup (Executable {exeName, buildInfo}) = + if T.pack (unUnqualComponentName exeName) == buildTargetName + then Just buildInfo + else Nothing + subLibraryNameLookup :: Library -> Maybe BuildInfo + subLibraryNameLookup (Library {libName, libBuildInfo}) = + case libName of + (LSubLibName name) -> + if T.pack (unUnqualComponentName name) == buildTargetName + then Just libBuildInfo + else Nothing + LMainLibName -> Nothing + foreignLibsNameLookup :: ForeignLib -> Maybe BuildInfo + foreignLibsNameLookup (ForeignLib {foreignLibName, foreignLibBuildInfo}) = + if T.pack (unUnqualComponentName foreignLibName) == buildTargetName + then Just foreignLibBuildInfo + else Nothing + testSuiteNameLookup :: TestSuite -> Maybe BuildInfo + testSuiteNameLookup (TestSuite {testName, testBuildInfo}) = + if T.pack (unUnqualComponentName testName) == buildTargetName + then Just testBuildInfo + else Nothing + benchmarkNameLookup :: Benchmark -> Maybe BuildInfo + benchmarkNameLookup (Benchmark {benchmarkName, benchmarkBuildInfo}) = + if T.pack (unUnqualComponentName benchmarkName) == buildTargetName + then Just benchmarkBuildInfo + else Nothing + +-- | Converts a name of a module to a FilePath. +-- Is needed to guess the relative path to a file +-- using the name of the module. +-- We assume, that correct module naming is guaranteed. +-- +-- Warning: Generally not advised to use, if there are +-- better ways to get the path. +-- +-- Examples: (output is system dependent) +-- >>> toHaskellFile "My.Module.Lib" +-- "My/Module/Lib.hs" +-- >>> toHaskellFile "Main" +-- "Main.hs" +toHaskellFile :: T.Text -> FilePath +toHaskellFile moduleName = joinPath (map T.unpack $ T.splitOn "." moduleName) <.> ".hs" diff --git a/plugins/hls-cabal-plugin/test/Definition.hs b/plugins/hls-cabal-plugin/test/Definition.hs new file mode 100644 index 0000000000..33163c03eb --- /dev/null +++ b/plugins/hls-cabal-plugin/test/Definition.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Definition ( + gotoDefinitionTests, +) where + +import Control.Lens ((^.)) +import Data.List.Extra (isSuffixOf) +import qualified Data.Text as T +import Ide.Plugin.Cabal.Definition (toHaskellFile) +import qualified Language.LSP.Protocol.Lens as L +import qualified Language.LSP.Protocol.Types as LSP +import System.FilePath +import Test.Hls +import Utils + + +gotoDefinitionTests :: TestTree +gotoDefinitionTests = testGroup "Goto Definition" + [ gotoCommonSectionDefinitionTests + , gotoModuleDefinitionTests + ] + +gotoModuleDefinitionTests :: TestTree +gotoModuleDefinitionTests = testGroup "Goto Module Definition" + [ testGoToDefinitionLink "simple cabal test" "simple-cabal" "simple-cabal.cabal" + (Position 8 23) (toTestHaskellPath "" "A") + + , testGoToDefinitionLink "library start of exposed-modules" ("goto-definition" "modules") "module-examples.cabal" + (Position 6 22) (toTestHaskellPath "src" "Library.Lib") + , testGoToDefinitionLink "library middle of exposed-modules" ("goto-definition" "modules") "module-examples.cabal" + (Position 6 29) (toTestHaskellPath "src" "Library.Lib") + , testGoToDefinitionLink "library end of exposed-modules" ("goto-definition" "modules") "module-examples.cabal" + (Position 6 33) (toTestHaskellPath "src" "Library.Lib") + , testGoToDefinitionLink "library start of other-modules" ("goto-definition" "modules") "module-examples.cabal" + (Position 9 22) (toTestHaskellPath "src" "Library.Other.OtherLib") + , testGoToDefinitionLink "library end of other-modules" ("goto-definition" "modules") "module-examples.cabal" + (Position 9 44) (toTestHaskellPath "src" "Library.Other.OtherLib") + + , testGoToDefinitionLink "executable other-modules" ("goto-definition" "modules") "module-examples.cabal" + (Position 22 10) (toTestHaskellPath ("src" "exe") "Config") + + , testGoToDefinitionLink "test-suite other-modules Config" ("goto-definition" "modules") "module-examples.cabal" + (Position 31 10) (toTestHaskellPath ("src" "test") "Config") + , testGoToDefinitionLink "test-suite other-modules Library" ("goto-definition" "modules") "module-examples.cabal" + (Position 34 10) (toTestHaskellPath ("src" "test") "Library") + + , testGoToDefinitionLink "benchmark other-modules Config" ("goto-definition" "modules") "module-examples.cabal" + (Position 45 30) (toTestHaskellPath ("src" "bench") "Config") + + , testGoToDefinitionLinkNoLocation "not existent module" ("goto-definition" "modules") "module-examples.cabal" (Position 48 25) + , testGoToDefinitionLinkNoLocation "behind module" ("goto-definition" "modules") "module-examples.cabal" (Position 9 20) + , testGoToDefinitionLinkNoLocation "after module" ("goto-definition" "modules") "module-examples.cabal" (Position 9 50) + ] + where + toTestHaskellPath :: FilePath -> T.Text -> FilePath + toTestHaskellPath dir moduleName = dir toHaskellFile moduleName + + getUriFromDefinition :: Show b => (Definition |? b) -> Uri + getUriFromDefinition (InL (Definition (InL loc))) = loc^.L.uri + getUriFromDefinition unk = error $ "Unexpected pattern '" ++ show unk ++ "' , expected '(InL (Definition (InL loc))'" + + testGoToDefinitionLink :: TestName -> FilePath -> FilePath -> Position -> FilePath -> TestTree + testGoToDefinitionLink testName testDir cabalFile cursorPos expectedFilePath = + runCabalTestCaseSession testName testDir $ do + doc <- openDoc cabalFile "cabal" + definitions <- getDefinitions doc cursorPos + let uri = getUriFromDefinition definitions + mFilePath = (testDir ) <$> uriToFilePath uri + case mFilePath of + Nothing -> error $ "Not possible to convert Uri " <> show uri <> " to FilePath" + Just filePath -> do + let filePathWithDir = testDir expectedFilePath + isCorrectPath = filePathWithDir `isSuffixOf` filePath + liftIO $ isCorrectPath @? ("Absolute path expected to end on " <> filePathWithDir <> + " but " <> filePath <> " was given.") + + testGoToDefinitionLinkNoLocation :: TestName -> FilePath -> FilePath -> Position -> TestTree + testGoToDefinitionLinkNoLocation testName testDir cabalFile cursorPos = + runCabalTestCaseSession testName testDir $ do + doc <- openDoc cabalFile "cabal" + empty <- getDefinitions doc cursorPos + liftIO $ empty @?= (InR $ InR LSP.Null) + +gotoCommonSectionDefinitionTests :: TestTree +gotoCommonSectionDefinitionTests = testGroup "Goto Common Section Definition" + [ positiveTest "middle of identifier" (Position 27 16) (mkRange 6 0 7 22) + , positiveTest "left of identifier" (Position 30 12) (mkRange 10 0 17 40) + , positiveTest "right of identifier" (Position 33 22) (mkRange 20 0 23 34) + , positiveTest "left of '-' in identifier" (Position 36 20) (mkRange 6 0 7 22) + , positiveTest "right of '-' in identifier" (Position 39 19) (mkRange 10 0 17 40) + , positiveTest "identifier in identifier list" (Position 42 16) (mkRange 20 0 23 34) + , positiveTest "left of ',' right of identifier" (Position 45 33) (mkRange 10 0 17 40) + , positiveTest "right of ',' left of identifier" (Position 48 34) (mkRange 6 0 7 22) + + , negativeTest "right of ',' left of space" (Position 51 23) + , negativeTest "right of ':' left of space" (Position 54 11) + , negativeTest "not a definition" (Position 57 8) + , negativeTest "empty space" (Position 59 7) + ] + where + getRangeFromDefinition :: Show b => (Definition |? b) -> Range + getRangeFromDefinition (InL (Definition (InL loc))) = loc^.L.range + getRangeFromDefinition unk = error $ "Unexpected pattern '" ++ show unk ++ "' , expected '(InL (Definition (InL loc))'" + + -- A positive test 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" "common-section") $ do + doc <- openDoc "simple-with-common.cabal" "cabal" + definitions <- getDefinitions doc cursorPos + let range = getRangeFromDefinition definitions + liftIO $ range @?= expectedRange + + -- A negative test 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" "common-section") $ do + doc <- openDoc "simple-with-common.cabal" "cabal" + empty <- getDefinitions doc cursorPos + liftIO $ empty @?= (InR $ InR LSP.Null) diff --git a/plugins/hls-cabal-plugin/test/Main.hs b/plugins/hls-cabal-plugin/test/Main.hs index 00e39583f4..98017fa9c1 100644 --- a/plugins/hls-cabal-plugin/test/Main.hs +++ b/plugins/hls-cabal-plugin/test/Main.hs @@ -17,10 +17,10 @@ import Data.Either (isRight) import Data.List.Extra (nubOrdOn) import qualified Data.Maybe as Maybe import qualified Data.Text as T +import Definition (gotoDefinitionTests) 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 @@ -230,56 +230,3 @@ 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 test 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 test 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) diff --git a/plugins/hls-cabal-plugin/test/testdata/goto-definition/common-section/simple-with-common.cabal b/plugins/hls-cabal-plugin/test/testdata/goto-definition/common-section/simple-with-common.cabal new file mode 100644 index 0000000000..c71e369b30 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/goto-definition/common-section/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 \ No newline at end of file diff --git a/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/module-examples.cabal b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/module-examples.cabal new file mode 100644 index 0000000000..24c2bb854e --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/module-examples.cabal @@ -0,0 +1,51 @@ +cabal-version: 3.0 +name: module-examples +version: 0.1.0.0 + + +library + exposed-modules: Library.Lib +-- ^ Position: (6, 22) +-- ^ Position: (6, 33) + other-modules: Library.Other.OtherLib +-- ^ Position: (9, 22) +-- ^ Position: (9, 44) + + build-depends: base + hs-source-dirs: src + default-language: Haskell2010 + +executable exec + hs-source-dirs: src/exe + main-is: Main.hs + build-depends: base + other-modules: + Config +-- ^ Position: (22, 8) +-- ^ Position: (22, 14) + +test-suite module-examples-test + type: exitcode-stdio-1.0 + hs-source-dirs: src/test + main-is: Main.hs + other-modules: + Config +-- ^ Position: (31, 8) +-- ^ Position: (31, 14) + Library +-- ^ Position: (34, 8) +-- ^ Position: (34, 15) + build-depends: base + +benchmark benchmark + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: src/bench + build-depends: base + other-modules: + Config +-- ^ Position: (45, 28) +-- ^ Position: (45, 34) + NotExistent +-- ^ Position: (48, 19) +-- ^ Position: (48, 30) diff --git a/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/Library/Lib.hs b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/Library/Lib.hs new file mode 100644 index 0000000000..e2cde3780b --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/Library/Lib.hs @@ -0,0 +1 @@ +module Library.Lib where diff --git a/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/Library/Other/OtherLib.hs b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/Library/Other/OtherLib.hs new file mode 100644 index 0000000000..625be777dc --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/Library/Other/OtherLib.hs @@ -0,0 +1 @@ +module Library.Other.OtherLib where diff --git a/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/bench/Config.hs b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/bench/Config.hs new file mode 100644 index 0000000000..6ea268c214 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/bench/Config.hs @@ -0,0 +1 @@ +module Config where diff --git a/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/bench/Main.hs b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/bench/Main.hs new file mode 100644 index 0000000000..6640b61707 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/bench/Main.hs @@ -0,0 +1,3 @@ +module Main where + +main = undefined \ No newline at end of file diff --git a/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/exe/Config.hs b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/exe/Config.hs new file mode 100644 index 0000000000..3a2489708e --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/exe/Config.hs @@ -0,0 +1 @@ +module Confing where \ No newline at end of file diff --git a/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/exe/Main.hs b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/exe/Main.hs new file mode 100644 index 0000000000..6640b61707 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/exe/Main.hs @@ -0,0 +1,3 @@ +module Main where + +main = undefined \ No newline at end of file diff --git a/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/test/Config.hs b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/test/Config.hs new file mode 100644 index 0000000000..39e39fc16a --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/test/Config.hs @@ -0,0 +1 @@ +module Config where \ No newline at end of file diff --git a/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/test/Library.hs b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/test/Library.hs new file mode 100644 index 0000000000..7899749de8 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/test/Library.hs @@ -0,0 +1 @@ +module Library where \ No newline at end of file diff --git a/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/test/Main.hs b/plugins/hls-cabal-plugin/test/testdata/goto-definition/modules/src/test/Main.hs new file mode 100644 index 0000000000..e69de29bb2