correct path, indefinite search(?)

haskell · Aug 13, 2024 · 2ff597a · 2ff597a
1 parent a49ecea
commit 2ff597a
Show file tree

Hide file tree

Showing 2 changed files with 28 additions and 18 deletions.
diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs
@@ -65,6 +65,10 @@ import           Distribution.PackageDescription               (Benchmark (..),
                                                                 library,
                                                                 unUnqualComponentName)
 import           Distribution.PackageDescription.Configuration (flattenPackageDescription)
+import Distribution.Utils.Path (getSymbolicPath)
+import System.Directory (doesFileExist)
+import System.FilePath ((</>), takeDirectory)
+import Distribution.Utils.Generic (safeHead)
 
 data Log
   = LogModificationTime NormalizedFilePath FileVersion
@@ -325,23 +329,25 @@ gotoDefinition ideState _ msgParam = do
               let mModuleNames = CabalFields.getModulesNames <$> mCabalFields
                   mModuleName = find (isModuleName cursorText) =<< mModuleNames
               case mModuleName of
-                Nothing   -> traceShowM ("NOT A MODULE")
+                Nothing -> pure $ InR $ InR Null
                 Just (mBuildTargetNames, moduleName) -> do
-                  traceShowM ("IS A MODULE", moduleName, "at", mBuildTargetNames)
                   mGPD <- liftIO $ runAction "cabal.GPD" ideState $ useWithStale ParseCabalFile $ toNormalizedFilePath filePath
                   case mGPD of
-                    Nothing -> traceShowM ("failed to get GPD")
+                    Nothing -> pure $ InR $ InR Null
                     Just (gpd, _) -> do
-                      let debug = map (lookupBuildTargetPackageDescription
-                                                      (flattenPackageDescription gpd))
-                                                      mBuildTargetNames
-                      traceShowM ("debug is", debug)
                       let buildInfos = foldMap (lookupBuildTargetPackageDescription
                                                       (flattenPackageDescription gpd))
                                                       mBuildTargetNames
-                      traceShowM ("buildInfos is", buildInfos)
-                      traceShowM ("Found hsSourceDirs", map hsSourceDirs buildInfos)
-              pure $ InR $ InR Null
+                          sourceDirs = map getSymbolicPath $ concatMap hsSourceDirs buildInfos
+                          potentialPaths = map (\dir -> takeDirectory filePath </> dir </> toHaskellFile moduleName) sourceDirs
+                      traceShowM ("potentialPaths", potentialPaths)
+                      allPaths <- liftIO $ filterM doesFileExist potentialPaths
+                      traceShowM ("allPaths", allPaths)
+                      let locations = map (\pth -> Location (filePathToUri pth) (mkRange 0 0 0 0)) allPaths
+                      traceShowM ("locations", locations)
+                      case safeHead locations of
+                        Nothing -> pure $ InR $ InR Null
+                        Just location -> pure $ InL $ Definition $ InL location
     where
       cursor = Types.lspPositionToCabalPosition (msgParam ^. JL.position)
       uri = msgParam ^. JL.textDocument . JL.uri
@@ -390,6 +396,10 @@ gotoDefinition ideState _ msgParam = do
               if T.pack (unUnqualComponentName benchmarkName) == buildTargetName
               then Just benchmarkBuildInfo
               else Nothing
+
+      toHaskellFile :: T.Text -> FilePath
+      toHaskellFile moduleName = foldl1 (</>) (map T.unpack $ T.splitOn "." moduleName) ++ ".hs"
+
 -- ----------------------------------------------------------------
 -- Cabal file of Interest rules and global variable
 -- ----------------------------------------------------------------

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
@@ -1,18 +1,18 @@
 module Ide.Plugin.Cabal.Completion.CabalFields (findStanzaForColumn, getSectionsWithModules, getModulesNames, findFieldSection, findTextWord, findFieldLine, getOptionalSectionName, getAnnotation, getFieldName, onelineSectionArgs, getFieldEndPosition, getSectionArgEndPosition, getNameEndPosition, getFieldLineEndPosition, getFieldLSPRange) 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
-import qualified Data.ByteString                   as BS
-import           Data.List                         (find)
+import Ide.Plugin.Cabal.Completion.Types
+    ( cabalPositionToLSPPosition, FieldContext(None), StanzaContext )
 import qualified Language.LSP.Protocol.Types       as LSP
-import Data.List.Extra (groupSort)
-import Data.Bifunctor (second)
-import Data.Tuple (swap)
 
 -- ----------------------------------------------------------------
 -- Cabal-syntax utilities I don't really want to write myself
@@ -152,9 +152,9 @@ getModulesNames fields = map swap $ groupSort rawModuleTargetPairs
     getSectionModuleNames (Syntax.Section _ secArgs fields) = map (, getArgsName secArgs) $ concatMap getFieldModuleNames fields
     getSectionModuleNames _ = []
 
-    getArgsName [] = Nothing -- only a main library can have no name
+    getArgsName []                         = Nothing -- only a main library can have no name
     getArgsName [Syntax.SecArgName _ name] = Just $ T.decodeUtf8 name
-    getArgsName _ = Nothing -- impossible to have multiple names for a build target
+    getArgsName _                          = Nothing -- 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"