Merge pull request #1107 from fendor/type-definition-request

Add ReqTypeDefinition to reactor

Author: lukel97

.gitmodules

@@ -36,4 +36,3 @@
 	path = submodules/floskell
 	url = https://github.com/ennocramer/floskell
 	# url = https://github.com/alanz/floskell
-

haskell-ide-engine.cabal

@@ -265,6 +265,7 @@ test-suite func-test
                      , ReferencesSpec
                      , RenameSpec
                      , SymbolsSpec
+                     , TypeDefinitionSpec
                      , Utils
   -- This cannot currently be handled by hie (cabal-helper)
   -- build-tool-depends:  haskell-ide-engine:hie

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

@@ -3,6 +3,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE TypeFamilies        #-}
+{-# LANGUAGE LambdaCase          #-}
 module Haskell.Ide.Engine.Support.HieExtras
   ( getDynFlags
   , WithSnippets(..)
@@ -12,6 +13,7 @@ module Haskell.Ide.Engine.Support.HieExtras
   , getReferencesInDoc
   , getModule
   , findDef
+  , findTypeDef
   , showName
   , safeTyThingId
   , PosPrefixInfo(..)
@@ -28,6 +30,7 @@ import           Control.Lens.Prism                           ( _Just )
 import           Control.Lens.Setter ((%~))
 import           Control.Lens.Traversal (traverseOf)
 import           Control.Monad.Reader
+import           Control.Monad.Except
 import           Data.Aeson
 import qualified Data.Aeson.Types                             as J
 import           Data.Char
@@ -476,6 +479,9 @@ getTypeForName n = do
 getSymbolsAtPoint :: Position -> CachedInfo -> [(Range,Name)]
 getSymbolsAtPoint pos info = maybe [] (`getArtifactsAtPos` locMap info) $ newPosToOld info pos
 
+-- |Get a symbol from the given location map at the given location.
+-- Retrieves the name and range of the symbol at the given location 
+-- from the cached location map.
 symbolFromTypecheckedModule
   :: LocMap
   -> Position
@@ -538,6 +544,51 @@ getModule df n = do
 
 -- ---------------------------------------------------------------------
 
+-- | Return the type definition of the symbol at the given position.
+-- Works for Datatypes, Newtypes and Type Definitions, as well as paremterized types.
+-- Type Definitions can only be looked up, if the corresponding type is defined in the project.
+-- Sum Types can also be searched.
+findTypeDef :: Uri -> Position -> IdeDeferM (IdeResult [Location])
+findTypeDef uri pos = pluginGetFile "findTypeDef: " uri $ \file ->
+  withCachedInfo
+    file
+    (IdeResultOk []) -- Default result
+    (\info -> do
+      let rfm    = revMap info
+          tmap   = typeMap info
+          oldPos = newPosToOld info pos
+
+          -- | Get SrcSpan of the name at the given position.
+          -- If the old position is Nothing, e.g. there is no cached info about it,
+          -- Nothing is returned.
+          -- 
+          -- Otherwise, searches for the Type of the given position 
+          -- and retrieves its SrcSpan.
+          getTypeSrcSpanFromPosition
+            :: Maybe Position -> ExceptT () IdeDeferM SrcSpan
+          getTypeSrcSpanFromPosition maybeOldPosition = do
+            oldPosition <- liftMaybe maybeOldPosition
+            let tmapRes = getArtifactsAtPos oldPosition tmap
+            case tmapRes of
+              [] -> throwError ()
+              a  -> do
+                -- take last type since this is always the most accurate one
+                tyCon <- liftMaybe $ tyConAppTyCon_maybe (snd $ last a)
+                case nameSrcSpan (getName tyCon) of
+                  UnhelpfulSpan _ -> throwError ()
+                  realSpan        -> return realSpan
+
+          liftMaybe :: Monad m => Maybe a -> ExceptT () m a
+          liftMaybe val = liftEither $ case val of
+            Nothing -> Left ()
+            Just s  -> Right s
+
+      runExceptT (getTypeSrcSpanFromPosition oldPos) >>= \case
+        Left () -> return $ IdeResultOk []
+        Right realSpan ->
+          lift $ srcSpanToFileLocation "hare:findTypeDef" rfm realSpan
+    )
+
 -- | Return the definition
 findDef :: Uri -> Position -> IdeDeferM (IdeResult [Location])
 findDef uri pos = pluginGetFile "findDef: " uri $ \file ->
@@ -554,46 +605,53 @@ findDef uri pos = pluginGetFile "findDef: " uri $ \file ->
         Just (_, n) ->
           case nameSrcSpan n of
             UnhelpfulSpan _ -> return $ IdeResultOk []
-            realSpan   -> do
-              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 "findDef: name srcspan not found/valid"
-                  pure (IdeResultFail
-                        (IdeError PluginError
-                                  ("hare:findDef" <> ": \"" <> 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)
-
+            realSpan   -> lift $ srcSpanToFileLocation "hare:findDef" rfm realSpan
+  )
+
+-- | Resolve the given SrcSpan to a Location in a file.
+-- Takes the name of the invoking function for error display.
+--
+-- If the SrcSpan can not be resolved, an error will be returned.
+srcSpanToFileLocation :: T.Text -> (FilePath -> FilePath) -> SrcSpan -> IdeM (IdeResult [Location])
+srcSpanToFileLocation invoker rfm srcSpan = do
+  -- Since we found a real SrcSpan, try to map it to real files
+  res <- srcSpan2Loc rfm srcSpan
+  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 (T.unpack invoker <> ": name srcspan not found/valid")
+      pure (IdeResultFail
+            (IdeError PluginError
+                      (invoker <> ": \"" <> x <> "\"")
+                      Null))
+
+-- | Goto given module.
+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)
 -- ---------------------------------------------------------------------
 
 data HarePoint =

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

@@ -706,6 +706,16 @@ reactor inp diagIn = do
                        $ fmap J.MultiLoc <$> Hie.findDef doc pos
           makeRequest hreq
 
+        ReqTypeDefinition req -> do
+          liftIO $ U.logs $ "reactor:got DefinitionTypeRequest:" ++ show req
+          let params = req ^. J.params
+              doc = params ^. J.textDocument . J.uri
+              pos = params ^. J.position
+              callback = reactorSend . RspTypeDefinition . Core.makeResponseMessage req
+          let hreq = IReq tn (req ^. J.id) callback
+                       $ fmap J.MultiLoc <$> Hie.findTypeDef doc pos
+          makeRequest hreq
+
         ReqFindReferences req -> do
           liftIO $ U.logs $ "reactor:got FindReferences:" ++ show req
           -- TODO: implement project-wide references
@@ -971,6 +981,7 @@ hieHandlers rin
   = def { Core.initializedHandler                       = Just $ passHandler rin NotInitialized
         , Core.renameHandler                            = Just $ passHandler rin ReqRename
         , Core.definitionHandler                        = Just $ passHandler rin ReqDefinition
+        , Core.typeDefinitionHandler                    = Just $ passHandler rin ReqTypeDefinition
         , Core.referencesHandler                        = Just $ passHandler rin ReqFindReferences
         , Core.hoverHandler                             = Just $ passHandler rin ReqHover
         , Core.didOpenTextDocumentNotificationHandler   = Just $ passHandler rin NotDidOpenTextDocument

stack-8.2.1.yaml

@@ -19,12 +19,13 @@ extra-deps:
 - ghc-exactprint-0.5.8.2
 - haddock-api-2.18.1
 - haddock-library-1.4.4
-- haskell-lsp-0.8.0.1
+- haskell-lsp-0.8.1.0
 - haskell-lsp-types-0.8.0.1
 - hlint-2.0.11
 - hsimport-0.8.6
-- lsp-test-0.5.0.2
+- lsp-test-0.5.1.0
 - monad-dijkstra-0.1.1.2
+- mtl-2.2.2
 - pretty-show-1.8.2
 - sorted-list-0.2.1.0
 - syz-0.2.0.0

stack-8.2.2.yaml

@@ -20,13 +20,13 @@ extra-deps:
 - ghc-exactprint-0.5.8.2
 - haddock-api-2.18.1
 - haddock-library-1.4.4
-- haskell-lsp-0.8.0.1
+- haskell-lsp-0.8.1.0
 - haskell-lsp-types-0.8.0.1
 - haskell-src-exts-1.21.0
 - hlint-2.1.15
 - hoogle-5.0.17.5
 - hsimport-0.8.8
-- lsp-test-0.5.0.2
+- lsp-test-0.5.1.0
 - monad-dijkstra-0.1.1.2
 - pretty-show-1.8.2
 - sorted-list-0.2.1.0

stack-8.4.2.yaml

@@ -18,13 +18,13 @@ extra-deps:
 - ghc-exactprint-0.5.8.2
 - haddock-api-2.20.0
 - haddock-library-1.6.0
-- haskell-lsp-0.8.0.1
+- haskell-lsp-0.8.1.0
 - haskell-lsp-types-0.8.0.1
 - haskell-src-exts-1.21.0
 - hlint-2.1.15
 - hoogle-5.0.17.5
 - hsimport-0.8.8
-- lsp-test-0.5.0.2
+- lsp-test-0.5.1.0
 - monad-dijkstra-0.1.1.2
 - pretty-show-1.8.2
 - syz-0.2.0.0

stack-8.4.3.yaml

@@ -17,13 +17,13 @@ extra-deps:
 - ghc-exactprint-0.5.8.2
 - haddock-api-2.20.0
 - haddock-library-1.6.0
-- haskell-lsp-0.8.0.1
+- haskell-lsp-0.8.1.0
 - haskell-lsp-types-0.8.0.1
 - haskell-src-exts-1.21.0
 - hlint-2.1.15
 - hoogle-5.0.17.5
 - hsimport-0.8.8
-- lsp-test-0.5.0.2
+- lsp-test-0.5.1.0
 - monad-dijkstra-0.1.1.2
 - pretty-show-1.8.2
 - syz-0.2.0.0

stack-8.4.4.yaml

@@ -17,13 +17,13 @@ extra-deps:
 - ghc-exactprint-0.5.8.2
 - haddock-api-2.20.0
 - haddock-library-1.6.0
-- haskell-lsp-0.8.0.1
+- haskell-lsp-0.8.1.0
 - haskell-lsp-types-0.8.0.1
 - haskell-src-exts-1.21.0
 - hlint-2.1.15
 - hoogle-5.0.17.5
 - hsimport-0.8.8
-- lsp-test-0.5.0.2
+- lsp-test-0.5.1.0
 - monad-dijkstra-0.1.1.2
 - optparse-simple-0.1.0
 - pretty-show-1.9.5

stack-8.6.1.yaml

@@ -19,13 +19,13 @@ extra-deps:
 - czipwith-1.0.1.1
 - data-tree-print-0.1.0.2
 - haddock-api-2.21.0
-- haskell-lsp-0.8.0.1
+- haskell-lsp-0.8.1.0
 - haskell-lsp-types-0.8.0.1
 - haskell-src-exts-1.21.0
 - hlint-2.1.15
 - hoogle-5.0.17.5
 - hsimport-0.8.8
-- lsp-test-0.5.0.2
+- lsp-test-0.5.1.0
 - monad-dijkstra-0.1.1.2
 - monad-memo-0.4.1
 - monoid-subclasses-0.4.6.1