Fix other file goto definition

ghcide/src/Development/IDE/Core/Actions.hs

@@ -13,6 +13,7 @@ module Development.IDE.Core.Actions
 , lookupMod
 ) where
 
+import           Control.Monad.Extra                  (mapMaybeM)
 import           Control.Monad.Reader
 import           Control.Monad.Trans.Maybe
 import qualified Data.HashMap.Strict                  as HM
@@ -31,7 +32,9 @@ import           Development.IDE.Types.HscEnvEq       (hscEnv)
 import           Development.IDE.Types.Location
 import qualified HieDb
 import           Language.LSP.Protocol.Types          (DocumentHighlight (..),
-                                                       SymbolInformation (..))
+                                                       SymbolInformation (..),
+                                                       normalizedFilePathToUri,
+                                                       uriToNormalizedFilePath)
 
 
 -- | Eventually this will lookup/generate URIs for files in dependencies, but not in the
@@ -66,10 +69,36 @@ getAtPoint file pos = runMaybeT $ do
   !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
   MaybeT $ pure $ first (toCurrentRange mapping =<<) <$> AtPoint.atPoint opts hf dkMap env pos'
 
-toCurrentLocations :: PositionMapping -> [Location] -> [Location]
-toCurrentLocations mapping = mapMaybe go
+-- | For each Loacation, determine if we have the PositionMapping
+-- for the correct file. If not, get the correct position mapping
+-- and then apply the position mapping to the location.
+toCurrentLocations
+  :: PositionMapping
+  -> NormalizedFilePath
+  -> [Location]
+  -> IdeAction [Location]
+toCurrentLocations mapping file = mapMaybeM go
   where
-    go (Location uri range) = Location uri <$> toCurrentRange mapping range
+    go :: Location -> IdeAction (Maybe Location)
+    go (Location uri range) =
+      -- The Location we are going to might be in a different
+      -- file than the one we are calling gotoDefinition from.
+      -- So we check that the location file matches the file
+      -- we are in.
+      if nUri == normalizedFilePathToUri file
+      -- The Location matches the file, so use the PositionMapping
+      -- we have.
+      then pure $ Location uri <$> toCurrentRange mapping range
+      -- The Location does not match the file, so get the correct
+      -- PositionMapping and use that instead.
+      else do
+        otherLocationMapping <- fmap (fmap snd) $ runMaybeT $ do
+          otherLocationFile <- MaybeT $ pure $ uriToNormalizedFilePath nUri
+          useE GetHieAst otherLocationFile
+        pure $ Location uri <$> (flip toCurrentRange range =<< otherLocationMapping)
+      where
+        nUri :: NormalizedUri
+        nUri = toNormalizedUri uri
 
 -- | useE is useful to implement functions that aren’t rules but need shortcircuiting
 -- e.g. getDefinition.
@@ -90,15 +119,17 @@ getDefinition file pos = runMaybeT $ do
     (HAR _ hf _ _ _, mapping) <- useE GetHieAst file
     (ImportMap imports, _) <- useE GetImportMap file
     !pos' <- MaybeT (pure $ fromCurrentPosition mapping pos)
-    toCurrentLocations mapping <$> AtPoint.gotoDefinition withHieDb (lookupMod hiedbWriter) opts imports hf pos'
+    locations <- AtPoint.gotoDefinition withHieDb (lookupMod hiedbWriter) opts imports hf pos'
+    MaybeT $ Just <$> toCurrentLocations mapping file locations
 
 getTypeDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location])
 getTypeDefinition file pos = runMaybeT $ do
     ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask
     opts <- liftIO $ getIdeOptionsIO ide
     (hf, mapping) <- useE GetHieAst file
     !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
-    toCurrentLocations mapping <$> AtPoint.gotoTypeDefinition withHieDb (lookupMod hiedbWriter) opts hf pos'
+    locations <- AtPoint.gotoTypeDefinition withHieDb (lookupMod hiedbWriter) opts hf pos'
+    MaybeT $ Just <$> toCurrentLocations mapping file locations
 
 highlightAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe [DocumentHighlight])
 highlightAtPoint file pos = runMaybeT $ do

test/functional/Definition.hs

@@ -7,18 +7,43 @@ import           Test.Hls
 import           Test.Hls.Command
 
 tests :: TestTree
-tests = testGroup "definitions" [
+tests = testGroup "definitions" [symbolTests, moduleTests]
 
-    ignoreTestBecause "Broken: file:///Users/jwindsor/src/haskell-language-server/test/testdata/References.hs" $
-       testCase "goto's symbols" $ runSession hlsCommand fullCaps "test/testdata" $ do
+symbolTests :: TestTree
+symbolTests = testGroup "gotoDefinition on symbols"
+       -- gotoDefinition where the definition is in the same file
+  [    testCase "gotoDefinition in this file" $ runSession hlsCommand fullCaps "test/testdata" $ do
         doc <- openDoc "References.hs" "haskell"
         defs <- getDefinitions doc (Position 7 8)
         let expRange = Range (Position 4 0) (Position 4 3)
         liftIO $ defs @?= InL (Definition (InR [Location (doc ^. uri) expRange]))
 
+        -- gotoDefinition where the definition is in a different file
+  ,    testCase "gotoDefinition in other file" $ runSession hlsCommand fullCaps "test/testdata/definition" $ do
+        doc <- openDoc "Foo.hs" "haskell"
+        defs <- getDefinitions doc (Position 4 11)
+        let expRange = Range (Position 2 0) (Position 2 1)
+        liftIO $ do
+            fp <- canonicalizePath "test/testdata/definition/Bar.hs"
+            defs @?= InL (Definition (InR [Location (filePathToUri fp) expRange]))
+
+        -- gotoDefinition where the definition is in a different file and the
+        -- definition in the other file is on a line number that is greater
+        -- than the number of lines in the file we are requesting from
+  ,    testCase "gotoDefinition in other file past lines in this file" $ runSession hlsCommand fullCaps "test/testdata/definition" $ do
+        doc <- openDoc "Foo.hs" "haskell"
+        defs <- getDefinitions doc (Position 5 13)
+        let expRange = Range (Position 8 0) (Position 8 1)
+        liftIO $ do
+            fp <- canonicalizePath "test/testdata/definition/Bar.hs"
+            defs @?= InL (Definition (InR [Location (filePathToUri fp) expRange]))
+  ]
+
   -- -----------------------------------
 
-  , ignoreTestBecause "Broken: file:///Users/jwindsor/src/haskell-language-server/test/testdata/Bar.hs" $
+moduleTests :: TestTree
+moduleTests = testGroup "gotoDefinition on modules"
+  [ ignoreTestBecause "Broken: file:///Users/jwindsor/src/haskell-language-server/test/testdata/Bar.hs" $
     testCase "goto's imported modules" $ runSession hlsCommand fullCaps "test/testdata/definition" $ do
         doc <- openDoc "Foo.hs" "haskell"
         defs <- getDefinitions doc (Position 2 8)

test/testdata/definition/Bar.hs

@@ -1,3 +1,9 @@
 module Bar where
 
 a = 42
+
+-- These blank lines are here
+-- to ensure that b is defined
+-- on a line number larger than
+-- the number of lines in Foo.hs.
+b = 43

test/testdata/definition/Foo.hs

@@ -1,3 +1,6 @@
 module Foo (module Bar) where
 
 import Bar
+
+fortyTwo = a
+fortyThree = b

test/testdata/definition/hie.yaml

@@ -0,0 +1,5 @@
+cradle:
+  direct:
+    arguments:
+      - "Foo"
+      - "Bar"