Implement TypeDefinitionRequest

Works for variables, not for explicit constructors.
However, for explicit constructors, findDef works.

Implement tests for `data`, `newtype` and `type`.

For type defs, the original type definition will be found.
May be improved.

If the data type definition is not in scope, empty result will be sent.

Also add new dependency, hopefully this can be removed again

Author: fendor

haskell-ide-engine.cabal

@@ -87,6 +87,7 @@ library
                      , safe
                      , sorted-list >= 0.2.1.0
                      , stm
+                     , syb
                      , tagsoup
                      , text
                      , transformers

src/Haskell/Ide/Engine/Plugin/HieExtras.hs

@@ -12,6 +12,7 @@ module Haskell.Ide.Engine.Plugin.HieExtras
   , getReferencesInDoc
   , getModule
   , findDef
+  , findTypeDef
   , showName
   , safeTyThingId
   , PosPrefixInfo(..)
@@ -31,6 +32,7 @@ import           Control.Monad.Reader
 import           Data.Aeson
 import qualified Data.Aeson.Types                             as J
 import           Data.Char
+import qualified Data.Generics as SYB
 import           Data.IORef
 import qualified Data.List                                    as List
 import qualified Data.Map                                     as Map
@@ -537,6 +539,101 @@ getModule df n = do
   return (pkg, T.pack $ moduleNameString $ moduleName m)
 
 -- ---------------------------------------------------------------------
+-- TODO: there has to be a simpler way, using the appropriate GHC internals
+findIdForName :: GHC.TypecheckedModule -> GHC.Name -> IdeM (Maybe GHC.Id)
+findIdForName tm n = do
+  let t = GHC.tm_typechecked_source tm
+  let r = SYB.something (SYB.mkQ Nothing worker) t
+      worker (i :: GHC.Id) | nameUnique n == varUnique i = Just i
+      worker _ = Nothing
+  return r
+
+-- ---------------------------------------------------------------------
+
+getTypeForName' :: GHC.TypecheckedModule -> GHC.Name -> IdeM (Maybe GHC.Type)
+getTypeForName' tm n = do
+  mId <- findIdForName tm n
+  case mId of
+    Nothing -> return Nothing
+    Just i  -> return $ Just (varType i)
+
+-- | Return the type definition
+findTypeDef :: Uri -> Position -> IdeDeferM (IdeResult [Location])
+findTypeDef uri pos = pluginGetFile "findTypeDef: " uri $ \file -> do
+  liftIO $ putStrLn "pluginGetFile"
+  ifCachedModuleAndData
+    file
+    (IdeResultOk [])
+    (\tm info NMD{} -> do
+      let rfm    = revMap info
+          lm     = locMap info
+          mm     = moduleMap info
+          oldPos = newPosToOld info pos
+      liftIO $ putStrLn "withCachedModuleAndData"
+      case (\x -> Just $ getArtifactsAtPos x mm) =<< oldPos of
+        Just ((_, mn) : _) -> gotoModule rfm mn
+        _                  -> case symbolFromTypecheckedModule lm =<< oldPos of
+          Nothing     -> return $ IdeResultOk []
+          Just (_, n) -> do
+            mayType <- lift $ getTypeForName' tm n
+            case mayType of 
+              Nothing -> do
+                liftIO $ putStrLn "No Type found :/"
+                return $ IdeResultOk []
+              Just t -> case tyConAppTyCon_maybe t of 
+                Nothing  -> do 
+                  liftIO $ putStrLn "Not a typeCon :("
+                  return $ IdeResultOk []
+                Just tyCon -> 
+                  case nameSrcSpan (getName tyCon) of
+                    UnhelpfulSpan _ -> return $ IdeResultOk []
+                    realSpan        -> do
+                      liftIO $ putStrLn "Found real span"
+                      res <- srcSpan2Loc rfm realSpan
+                      case res of
+                        Right l@(J.Location luri range) -> case uriToFilePath luri of
+                          Nothing -> return $ IdeResultOk [l]
+                          Just fp ->
+                            ifCachedModule fp (IdeResultOk [l])
+                              $ \(_ :: ParsedModule) info' ->
+                                  case oldRangeToNew info' range of
+                                    Just r ->
+                                      return $ IdeResultOk [J.Location luri r]
+                                    Nothing -> return $ IdeResultOk [l]
+                        Left x -> do
+                          debugm "findTypeDef: name srcspan not found/valid"
+                          pure
+                            (IdeResultFail
+                              (IdeError PluginError
+                                        ("hare:findTypeDef" <> ": \"" <> x <> "\"")
+                                        Null
+                              )
+                            )
+    )
+ where
+  gotoModule
+    :: (FilePath -> FilePath) -> ModuleName -> IdeDeferM (IdeResult [Location])
+  gotoModule rfm mn = do
+
+    hscEnvRef <- ghcSession <$> readMTS
+    mHscEnv   <- liftIO $ traverse readIORef hscEnvRef
+
+    case mHscEnv of
+      Just env -> do
+        fr <- liftIO $ do
+          -- Flush cache or else we get temporary files
+          flushFinderCaches env
+          findImportedModule env mn Nothing
+        case fr of
+          Found (ModLocation (Just src) _ _) _ -> do
+            fp <- reverseMapFile rfm src
+
+            let r   = Range (Position 0 0) (Position 0 0)
+                loc = Location (filePathToUri fp) r
+            return (IdeResultOk [loc])
+          _ -> return (IdeResultOk [])
+      Nothing -> return $ IdeResultFail
+        (IdeError PluginError "Couldn't get hscEnv when finding import" Null)
 
 -- | Return the definition
 findDef :: Uri -> Position -> IdeDeferM (IdeResult [Location])

src/Haskell/Ide/Engine/Transport/LspStdio.hs

@@ -713,7 +713,7 @@ reactor inp diagIn = do
               pos = params ^. J.position
               callback = reactorSend . RspTypeDefinition . Core.makeResponseMessage req
           let hreq = IReq tn (req ^. J.id) callback
-                       $ fmap J.MultiLoc <$> Hie.findDef doc pos
+                       $ fmap J.MultiLoc <$> Hie.findTypeDef doc pos
           makeRequest hreq
 
         ReqFindReferences req -> do

test/testdata/gototest/src/Lib.hs

@@ -1,6 +1,35 @@
 module Lib
-    ( someFunc
-    ) where
+    
+    where
 
 someFunc :: IO ()
 someFunc = putStrLn "someFunc"
+
+data DataType = DataType Int
+
+dataTypeId :: DataType -> DataType
+dataTypeId dataType = dataType
+
+newtype NewType = NewType Int
+
+newTypeId :: NewType -> NewType
+newTypeId newType = newType
+
+data Enu = First | Second
+
+enuId :: Enu -> Enu
+enuId enu = enu
+
+toNum :: Enu -> Int
+toNum First = 1
+toNum Second = 2
+
+type MyInt = Int
+
+myIntId :: MyInt -> MyInt
+myIntId myInt = myInt
+
+type TypEnu = Enu
+
+typEnuId :: TypEnu -> TypEnu
+typEnuId enu = enu

test/testdata/gototest/src/Lib2.hs

@@ -8,3 +8,6 @@ g = do
   where z = 1+2
         y = z+z
         x = y*z
+
+otherId :: DataType -> DataType
+otherId dataType = dataType

test/unit/HaRePluginSpec.hs

@@ -21,16 +21,19 @@ import           Language.Haskell.LSP.Types     ( Location(..)
 import           System.Directory
 import           System.FilePath
 import           TestUtils
-
 import           Test.Hspec
+import Test.Hspec.Runner
 
 -- ---------------------------------------------------------------------
 {-# ANN module ("hlint: ignore Eta reduce" :: String) #-}
 {-# ANN module ("hlint: ignore Redundant do" :: String) #-}
 -- ---------------------------------------------------------------------
 
 main :: IO ()
-main = hspec spec
+main = do
+  setupStackFiles
+  config <- getHspecFormattedConfig "unit"
+  hspecWith config spec
 
 spec :: Spec
 spec = do
@@ -199,12 +202,73 @@ hareSpec = do
           req = liftToGhc $ TestDeferM $ findDef u (toPos (7,11))
       r <- dispatchRequestPGoto $ lreq >> req
       r `shouldBe` IdeResultOk [Location (filePathToUri $ cwd </> "test/testdata/gototest/src/Lib2.hs")
-                                           (Range (toPos (10,9)) (toPos (10,10)))]
+                                            (Range (toPos (10,9)) (toPos (10,10)))]
       let req2 = liftToGhc $ TestDeferM $ findDef u (toPos (10,13))
       r2 <- dispatchRequestPGoto $ lreq >> req2
       r2 `shouldBe` IdeResultOk [Location (filePathToUri $ cwd </> "test/testdata/gototest/src/Lib2.hs")
                                             (Range (toPos (9,9)) (toPos (9,10)))]
-
+    it "finds local definition of record variable" $ do
+      let u    = filePathToUri $ cwd </> "test/testdata/gototest/src/Lib.hs"
+          lreq = setTypecheckedModule u
+          req  = liftToGhc $ TestDeferM $ findTypeDef u (toPos (11, 23))
+      r <- dispatchRequestPGoto $ lreq >> req
+      r `shouldBe` IdeResultOk
+        [ Location
+            (filePathToUri $ cwd </> "test/testdata/gototest/src/Lib.hs")
+            (Range (toPos (8, 1)) (toPos (8, 29)))
+        ]
+    it "finds local definition of newtype variable" $ do
+      let u    = filePathToUri $ cwd </> "test/testdata/gototest/src/Lib.hs"
+          lreq = setTypecheckedModule u
+          req  = liftToGhc $ TestDeferM $ findTypeDef u (toPos (16, 21))
+      r <- dispatchRequestPGoto $ lreq >> req
+      r `shouldBe` IdeResultOk
+        [ Location
+            (filePathToUri $ cwd </> "test/testdata/gototest/src/Lib.hs")
+            (Range (toPos (13, 1)) (toPos (13, 30)))
+        ]
+    it "finds local definition of sum type variable" $ do
+      let u    = filePathToUri $ cwd </> "test/testdata/gototest/src/Lib.hs"
+          lreq = setTypecheckedModule u
+          req  = liftToGhc $ TestDeferM $ findTypeDef u (toPos (21, 13))
+      r <- dispatchRequestPGoto $ lreq >> req
+      r `shouldBe` IdeResultOk
+        [ Location
+            (filePathToUri $ cwd </> "test/testdata/gototest/src/Lib.hs")
+            (Range (toPos (18, 1)) (toPos (18, 26)))
+        ]
+    it "finds local definition of sum type contructor" $ do
+      let u    = filePathToUri $ cwd </> "test/testdata/gototest/src/Lib.hs"
+          lreq = setTypecheckedModule u
+          req  = liftToGhc $ TestDeferM $ findTypeDef u (toPos (24, 7))
+      r <- dispatchRequestPGoto $ lreq >> req
+      r `shouldBe` IdeResultOk []
+    it "can not find non-local definition of type def" $ do
+      let u    = filePathToUri $ cwd </> "test/testdata/gototest/src/Lib.hs"
+          lreq = setTypecheckedModule u
+          req  = liftToGhc $ TestDeferM $ findTypeDef u (toPos (30, 17))
+      r <- dispatchRequestPGoto $ lreq >> req
+      r `shouldBe` IdeResultOk []
+    it "find local definition of type def" $ do
+      let u    = filePathToUri $ cwd </> "test/testdata/gototest/src/Lib.hs"
+          lreq = setTypecheckedModule u
+          req  = liftToGhc $ TestDeferM $ findTypeDef u (toPos (35, 16))
+      r <- dispatchRequestPGoto $ lreq >> req
+      r `shouldBe` IdeResultOk
+        [ Location
+            (filePathToUri $ cwd </> "test/testdata/gototest/src/Lib.hs")
+            (Range (toPos (18, 1)) (toPos (18, 26)))
+        ]
+    it "find type-definition of type def in component" $ do
+      let u    = filePathToUri $ cwd </> "test/testdata/gototest/src/Lib2.hs"
+          lreq = setTypecheckedModule u
+          req  = liftToGhc $ TestDeferM $ findTypeDef u (toPos (13, 20))
+      r <- dispatchRequestPGoto $ lreq >> req
+      r `shouldBe` IdeResultOk
+        [ Location
+            (filePathToUri $ cwd </> "test/testdata/gototest/src/Lib.hs")
+            (Range (toPos (8, 1)) (toPos (8, 29)))
+        ]
 
     -- ---------------------------------