From d2566d829cd95e2a52ea0ba19eb6cb857367805d Mon Sep 17 00:00:00 2001 From: fendor Date: Tue, 26 Feb 2019 14:27:07 +0100 Subject: [PATCH 01/17] Add ReqTypeDefinition to reactor --- src/Haskell/Ide/Engine/Transport/LspStdio.hs | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/src/Haskell/Ide/Engine/Transport/LspStdio.hs b/src/Haskell/Ide/Engine/Transport/LspStdio.hs index 498a967c9..904d70dc0 100644 --- a/src/Haskell/Ide/Engine/Transport/LspStdio.hs +++ b/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 DefinitionRequest:" ++ 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.findDef 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 From f52db27a491f4850f49d9e0d9ffebac5116ffd94 Mon Sep 17 00:00:00 2001 From: fendor Date: Tue, 26 Feb 2019 15:45:16 +0100 Subject: [PATCH 02/17] Fix log message --- src/Haskell/Ide/Engine/Transport/LspStdio.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Haskell/Ide/Engine/Transport/LspStdio.hs b/src/Haskell/Ide/Engine/Transport/LspStdio.hs index 904d70dc0..dbec87208 100644 --- a/src/Haskell/Ide/Engine/Transport/LspStdio.hs +++ b/src/Haskell/Ide/Engine/Transport/LspStdio.hs @@ -707,7 +707,7 @@ reactor inp diagIn = do makeRequest hreq ReqTypeDefinition req -> do - liftIO $ U.logs $ "reactor:got DefinitionRequest:" ++ show req + liftIO $ U.logs $ "reactor:got DefinitionTypeRequest:" ++ show req let params = req ^. J.params doc = params ^. J.textDocument . J.uri pos = params ^. J.position From 54bd2b909c88e1d22c87b6135b27222a0495a0f8 Mon Sep 17 00:00:00 2001 From: fendor Date: Fri, 29 Mar 2019 15:54:15 +0100 Subject: [PATCH 03/17] 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 --- haskell-ide-engine.cabal | 1 + src/Haskell/Ide/Engine/Support/HieExtras.hs | 97 ++++++++++++++++++++ src/Haskell/Ide/Engine/Transport/LspStdio.hs | 2 +- test/testdata/gototest/src/Lib.hs | 33 ++++++- test/testdata/gototest/src/Lib2.hs | 3 + test/unit/HaRePluginSpec.hs | 72 ++++++++++++++- 6 files changed, 201 insertions(+), 7 deletions(-) diff --git a/haskell-ide-engine.cabal b/haskell-ide-engine.cabal index 0416cea1f..915b2ef0f 100644 --- a/haskell-ide-engine.cabal +++ b/haskell-ide-engine.cabal @@ -87,6 +87,7 @@ library , safe , sorted-list >= 0.2.1.0 , stm + , syb , tagsoup , text , transformers diff --git a/src/Haskell/Ide/Engine/Support/HieExtras.hs b/src/Haskell/Ide/Engine/Support/HieExtras.hs index b8926b2f3..646495b5e 100644 --- a/src/Haskell/Ide/Engine/Support/HieExtras.hs +++ b/src/Haskell/Ide/Engine/Support/HieExtras.hs @@ -12,6 +12,7 @@ module Haskell.Ide.Engine.Support.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]) diff --git a/src/Haskell/Ide/Engine/Transport/LspStdio.hs b/src/Haskell/Ide/Engine/Transport/LspStdio.hs index dbec87208..d87d58b9f 100644 --- a/src/Haskell/Ide/Engine/Transport/LspStdio.hs +++ b/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 diff --git a/test/testdata/gototest/src/Lib.hs b/test/testdata/gototest/src/Lib.hs index d36ff2714..b74f5b1c2 100644 --- a/test/testdata/gototest/src/Lib.hs +++ b/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 \ No newline at end of file diff --git a/test/testdata/gototest/src/Lib2.hs b/test/testdata/gototest/src/Lib2.hs index a51362195..c0ef7d46b 100644 --- a/test/testdata/gototest/src/Lib2.hs +++ b/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 \ No newline at end of file diff --git a/test/unit/HaRePluginSpec.hs b/test/unit/HaRePluginSpec.hs index 7067fee5b..1fecfff13 100644 --- a/test/unit/HaRePluginSpec.hs +++ b/test/unit/HaRePluginSpec.hs @@ -21,8 +21,8 @@ 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) #-} @@ -30,7 +30,10 @@ import Test.Hspec -- --------------------------------------------------------------------- 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))) + ] -- --------------------------------- From 7b80721999be5f96a9b785b5840bcdc1bb777f18 Mon Sep 17 00:00:00 2001 From: fendor Date: Mon, 1 Apr 2019 13:17:44 +0200 Subject: [PATCH 04/17] Find sum type values --- src/Haskell/Ide/Engine/Support/HieExtras.hs | 84 +++++++-------------- test/unit/HaRePluginSpec.hs | 2 +- 2 files changed, 27 insertions(+), 59 deletions(-) diff --git a/src/Haskell/Ide/Engine/Support/HieExtras.hs b/src/Haskell/Ide/Engine/Support/HieExtras.hs index 646495b5e..4d541fca0 100644 --- a/src/Haskell/Ide/Engine/Support/HieExtras.hs +++ b/src/Haskell/Ide/Engine/Support/HieExtras.hs @@ -540,7 +540,7 @@ getModule df n = do -- --------------------------------------------------------------------- -- TODO: there has to be a simpler way, using the appropriate GHC internals -findIdForName :: GHC.TypecheckedModule -> GHC.Name -> IdeM (Maybe GHC.Id) +findIdForName :: TypecheckedModule -> Name -> IdeM (Maybe Id) findIdForName tm n = do let t = GHC.tm_typechecked_source tm let r = SYB.something (SYB.mkQ Nothing worker) t @@ -550,17 +550,16 @@ findIdForName tm n = do -- --------------------------------------------------------------------- -getTypeForName' :: GHC.TypecheckedModule -> GHC.Name -> IdeM (Maybe GHC.Type) +getTypeForName' :: TypecheckedModule -> Name -> IdeM (Maybe Type) getTypeForName' tm n = do mId <- findIdForName tm n case mId of - Nothing -> return Nothing + Nothing -> getTypeForName n 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" +findTypeDef uri pos = pluginGetFile "findTypeDef: " uri $ \file -> ifCachedModuleAndData file (IdeResultOk []) @@ -569,7 +568,6 @@ findTypeDef uri pos = pluginGetFile "findTypeDef: " uri $ \file -> do 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 @@ -577,18 +575,15 @@ findTypeDef uri pos = pluginGetFile "findTypeDef: " uri $ \file -> do Just (_, n) -> do mayType <- lift $ getTypeForName' tm n case mayType of - Nothing -> do - liftIO $ putStrLn "No Type found :/" + Nothing -> return $ IdeResultOk [] Just t -> case tyConAppTyCon_maybe t of - Nothing -> do - liftIO $ putStrLn "Not a typeCon :(" + Nothing -> 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 @@ -610,30 +605,6 @@ findTypeDef uri pos = pluginGetFile "findTypeDef: " uri $ \file -> do ) ) ) - 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]) @@ -667,30 +638,27 @@ findDef uri pos = pluginGetFile "findDef: " uri $ \file -> (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) +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 = diff --git a/test/unit/HaRePluginSpec.hs b/test/unit/HaRePluginSpec.hs index 1fecfff13..b8bb722fd 100644 --- a/test/unit/HaRePluginSpec.hs +++ b/test/unit/HaRePluginSpec.hs @@ -242,7 +242,7 @@ hareSpec = do lreq = setTypecheckedModule u req = liftToGhc $ TestDeferM $ findTypeDef u (toPos (24, 7)) r <- dispatchRequestPGoto $ lreq >> req - r `shouldBe` IdeResultOk [] + r `shouldBe` IdeResultOk [(Range (toPos (18, 1)) (toPos (18, 26)))] it "can not find non-local definition of type def" $ do let u = filePathToUri $ cwd "test/testdata/gototest/src/Lib.hs" lreq = setTypecheckedModule u From 3c2b82d7c2f822c0041c90890d6e1419007bc7ef Mon Sep 17 00:00:00 2001 From: fendor Date: Mon, 1 Apr 2019 15:49:31 +0200 Subject: [PATCH 05/17] Revert changes to the test spec --- test/unit/HaRePluginSpec.hs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/test/unit/HaRePluginSpec.hs b/test/unit/HaRePluginSpec.hs index b8bb722fd..87c667a1d 100644 --- a/test/unit/HaRePluginSpec.hs +++ b/test/unit/HaRePluginSpec.hs @@ -21,8 +21,8 @@ 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) #-} @@ -30,10 +30,7 @@ import Test.Hspec.Runner -- --------------------------------------------------------------------- main :: IO () -main = do - setupStackFiles - config <- getHspecFormattedConfig "unit" - hspecWith config spec +main = hspec spec spec :: Spec spec = do @@ -242,7 +239,11 @@ hareSpec = do lreq = setTypecheckedModule u req = liftToGhc $ TestDeferM $ findTypeDef u (toPos (24, 7)) r <- dispatchRequestPGoto $ lreq >> req - r `shouldBe` IdeResultOk [(Range (toPos (18, 1)) (toPos (18, 26)))] + r `shouldBe` IdeResultOk + [ Location + (filePathToUri $ cwd "test/testdata/gototest/src/Lib.hs") + (Range (toPos (18, 1)) (toPos (18, 26))) + ] it "can not find non-local definition of type def" $ do let u = filePathToUri $ cwd "test/testdata/gototest/src/Lib.hs" lreq = setTypecheckedModule u From 3cbd9e2594c3dfcdfd141b5312f475249f418e43 Mon Sep 17 00:00:00 2001 From: fendor Date: Mon, 1 Apr 2019 17:55:44 +0200 Subject: [PATCH 06/17] Add documentation and use MaybeT --- src/Haskell/Ide/Engine/Support/HieExtras.hs | 107 +++++++++++++------- 1 file changed, 69 insertions(+), 38 deletions(-) diff --git a/src/Haskell/Ide/Engine/Support/HieExtras.hs b/src/Haskell/Ide/Engine/Support/HieExtras.hs index 4d541fca0..ce2918d9a 100644 --- a/src/Haskell/Ide/Engine/Support/HieExtras.hs +++ b/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(..) @@ -29,6 +30,7 @@ import Control.Lens.Prism ( _Just ) import Control.Lens.Setter ((%~)) import Control.Lens.Traversal (traverseOf) import Control.Monad.Reader +import Control.Monad.Trans.Maybe import Data.Aeson import qualified Data.Aeson.Types as J import Data.Char @@ -478,6 +480,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 @@ -540,6 +545,12 @@ getModule df n = do -- --------------------------------------------------------------------- -- TODO: there has to be a simpler way, using the appropriate GHC internals +-- |Find the Id for a given Name. +-- Requires an already TypecheckedModule. +-- A TypecheckedModule can be obtained by using the functions +-- @ifCachedModuleAndData@ or @withCachedModuleAndData@. +-- +-- Function is copied from @HaRe/src/Language/Haskell/Refact/Utils/TypeUtils.hs:2954@. findIdForName :: TypecheckedModule -> Name -> IdeM (Maybe Id) findIdForName tm n = do let t = GHC.tm_typechecked_source tm @@ -550,6 +561,14 @@ findIdForName tm n = do -- --------------------------------------------------------------------- +-- | Get the type for a name. +-- Requires an already TypecheckedModule. +-- A TypecheckedModule can be obtained by using the functions +-- @ifCachedModuleAndData@ or @withCachedModuleAndData@. +-- +-- Returns the type of a variable or a sum type constructor. +-- +-- Function is taken from @HaRe/src/Language/Haskell/Refact/Utils/TypeUtils.hs:2966@. getTypeForName' :: TypecheckedModule -> Name -> IdeM (Maybe Type) getTypeForName' tm n = do mId <- findIdForName tm n @@ -557,12 +576,15 @@ getTypeForName' tm n = do Nothing -> getTypeForName n Just i -> return $ Just (varType i) --- | Return the type definition +-- | Return the type definition of the symbol at the given position. +-- Works for Datatypes, Newtypes and Type Definitions. +-- The latter is only possible, if the type that is defined is defined in the project. +-- Sum Types can also be searched. findTypeDef :: Uri -> Position -> IdeDeferM (IdeResult [Location]) findTypeDef uri pos = pluginGetFile "findTypeDef: " uri $ \file -> - ifCachedModuleAndData - file - (IdeResultOk []) + ifCachedModuleAndData -- Dont wait on this function if the module is not cached. + file + (IdeResultOk []) -- Default result (\tm info NMD{} -> do let rfm = revMap info lm = locMap info @@ -570,40 +592,49 @@ findTypeDef uri pos = pluginGetFile "findTypeDef: " uri $ \file -> oldPos = newPosToOld info pos 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 -> - return $ IdeResultOk [] - Just t -> case tyConAppTyCon_maybe t of - Nothing -> - return $ IdeResultOk [] - Just tyCon -> - case nameSrcSpan (getName tyCon) 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 "findTypeDef: name srcspan not found/valid" - pure - (IdeResultFail - (IdeError PluginError - ("hare:findTypeDef" <> ": \"" <> x <> "\"") - Null - ) - ) + _ -> do + let + -- | 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. + getSrcSpanFromPosition :: Maybe Position -> MaybeT IdeDeferM SrcSpan + getSrcSpanFromPosition oldPosition = do + (_, n) <- MaybeT $ return $ symbolFromTypecheckedModule lm =<< oldPosition + t <- MaybeT $ lift $ getTypeForName' tm n + tyCon <- MaybeT $ return $ tyConAppTyCon_maybe t + case nameSrcSpan (getName tyCon) of + UnhelpfulSpan _ -> fail "Unhelpful Span" -- this message is never shown + realSpan -> return realSpan + + runMaybeT (getSrcSpanFromPosition oldPos) >>= \case + Nothing -> return $ IdeResultOk [] + Just realSpan -> do + -- Since we found a real SrcSpan, we now translate it + -- to the position in the file + 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 + -- SrcSpan does not have a file location! + debugm "findTypeDef: name srcspan not found/valid" + pure + (IdeResultFail + (IdeError PluginError + ("hare:findTypeDef" <> ": \"" <> x <> "\"") + Null + ) + ) ) -- | Return the definition From e57858c614fb9df9e439bbfb5545666d5f75fbfa Mon Sep 17 00:00:00 2001 From: fendor Date: Mon, 1 Apr 2019 20:21:38 +0200 Subject: [PATCH 07/17] Prefer ExcepT over MaybeT Also add documentation and extract functions --- src/Haskell/Ide/Engine/Support/HieExtras.hs | 100 ++++++++++---------- test/unit/HaRePluginSpec.hs | 2 +- 2 files changed, 50 insertions(+), 52 deletions(-) diff --git a/src/Haskell/Ide/Engine/Support/HieExtras.hs b/src/Haskell/Ide/Engine/Support/HieExtras.hs index ce2918d9a..1268cac73 100644 --- a/src/Haskell/Ide/Engine/Support/HieExtras.hs +++ b/src/Haskell/Ide/Engine/Support/HieExtras.hs @@ -30,11 +30,11 @@ import Control.Lens.Prism ( _Just ) import Control.Lens.Setter ((%~)) import Control.Lens.Traversal (traverseOf) import Control.Monad.Reader -import Control.Monad.Trans.Maybe +import Control.Monad.Except import Data.Aeson import qualified Data.Aeson.Types as J import Data.Char -import qualified Data.Generics as SYB +import qualified Data.Generics as SYB import Data.IORef import qualified Data.List as List import qualified Data.Map as Map @@ -600,41 +600,29 @@ findTypeDef uri pos = pluginGetFile "findTypeDef: " uri $ \file -> -- -- Otherwise, searches for the Type of the given position -- and retrieves its SrcSpan. - getSrcSpanFromPosition :: Maybe Position -> MaybeT IdeDeferM SrcSpan - getSrcSpanFromPosition oldPosition = do - (_, n) <- MaybeT $ return $ symbolFromTypecheckedModule lm =<< oldPosition - t <- MaybeT $ lift $ getTypeForName' tm n - tyCon <- MaybeT $ return $ tyConAppTyCon_maybe t + getSrcSpanFromPosition :: Maybe Position -> ExceptT () IdeDeferM SrcSpan + getSrcSpanFromPosition maybeOldPosition = do + oldPosition <- liftMaybe maybeOldPosition + (_, n) <- liftMaybe $ symbolFromTypecheckedModule lm oldPosition + t <- liftMaybeM (lift $ getTypeForName' tm n) + tyCon <- liftMaybe $ tyConAppTyCon_maybe t case nameSrcSpan (getName tyCon) of - UnhelpfulSpan _ -> fail "Unhelpful Span" -- this message is never shown + UnhelpfulSpan _ -> throwError () realSpan -> return realSpan - - runMaybeT (getSrcSpanFromPosition oldPos) >>= \case - Nothing -> return $ IdeResultOk [] - Just realSpan -> do - -- Since we found a real SrcSpan, we now translate it - -- to the position in the file - 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 - -- SrcSpan does not have a file location! - debugm "findTypeDef: name srcspan not found/valid" - pure - (IdeResultFail - (IdeError PluginError - ("hare:findTypeDef" <> ": \"" <> x <> "\"") - Null - ) - ) + + liftMaybe :: Monad m => Maybe a -> ExceptT () m a + liftMaybe val = liftEither $ case val of + Nothing -> Left () + Just s -> Right s + + liftMaybeM :: Monad m => m (Maybe a) -> ExceptT () m a + liftMaybeM mval = do + val <- lift mval + liftMaybe val + + runExceptT (getSrcSpanFromPosition oldPos) >>= \case + Left () -> return $ IdeResultOk [] + Right realSpan -> lift $ srcSpanToFileLocation "hare:findTypeDef" rfm realSpan ) -- | Return the definition @@ -653,23 +641,33 @@ 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))) + 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 diff --git a/test/unit/HaRePluginSpec.hs b/test/unit/HaRePluginSpec.hs index 87c667a1d..2f4f1fcd5 100644 --- a/test/unit/HaRePluginSpec.hs +++ b/test/unit/HaRePluginSpec.hs @@ -30,7 +30,7 @@ import Test.Hspec -- --------------------------------------------------------------------- main :: IO () -main = hspec spec +main = hspec spec spec :: Spec spec = do From c0d8abd4a5437369f4401f168b3b4e076a014bad Mon Sep 17 00:00:00 2001 From: fendor Date: Mon, 1 Apr 2019 21:19:20 +0200 Subject: [PATCH 08/17] Add extra-dep for stack-8.2.1.yaml --- stack-8.2.1.yaml | 1 + 1 file changed, 1 insertion(+) diff --git a/stack-8.2.1.yaml b/stack-8.2.1.yaml index 7bc04083d..b22cc93b0 100644 --- a/stack-8.2.1.yaml +++ b/stack-8.2.1.yaml @@ -25,6 +25,7 @@ extra-deps: - hsimport-0.8.6 - lsp-test-0.5.0.2 - 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 From 3b234f1504e03f68491291cde9daf8a41ad36182 Mon Sep 17 00:00:00 2001 From: fendor Date: Mon, 1 Apr 2019 21:19:51 +0200 Subject: [PATCH 09/17] Add tests for parameterized data types --- src/Haskell/Ide/Engine/Support/HieExtras.hs | 3 +++ test/testdata/gototest/src/Lib.hs | 7 ++++++- test/unit/HaRePluginSpec.hs | 10 ++++++++++ 3 files changed, 19 insertions(+), 1 deletion(-) diff --git a/src/Haskell/Ide/Engine/Support/HieExtras.hs b/src/Haskell/Ide/Engine/Support/HieExtras.hs index 1268cac73..e415bca7e 100644 --- a/src/Haskell/Ide/Engine/Support/HieExtras.hs +++ b/src/Haskell/Ide/Engine/Support/HieExtras.hs @@ -182,6 +182,9 @@ mkPragmaCompl label insertText = safeTyThingId :: TyThing -> Maybe Id safeTyThingId (AnId i) = Just i safeTyThingId (AConLike (RealDataCon dc)) = Just $ dataConWrapId dc +safeTyThingId (ATyCon tyCon) = case GHC.tyConTyVars tyCon of + [] -> Nothing + (a:_) -> Just a safeTyThingId _ = Nothing -- Associates a module's qualifier with its members diff --git a/test/testdata/gototest/src/Lib.hs b/test/testdata/gototest/src/Lib.hs index b74f5b1c2..4575b32d8 100644 --- a/test/testdata/gototest/src/Lib.hs +++ b/test/testdata/gototest/src/Lib.hs @@ -32,4 +32,9 @@ myIntId myInt = myInt type TypEnu = Enu typEnuId :: TypEnu -> TypEnu -typEnuId enu = enu \ No newline at end of file +typEnuId enu = enu + +data Parameter a = Parameter a + +parameterId :: Parameter a -> Parameter a +parameterId pid = pid \ No newline at end of file diff --git a/test/unit/HaRePluginSpec.hs b/test/unit/HaRePluginSpec.hs index 2f4f1fcd5..6a4824355 100644 --- a/test/unit/HaRePluginSpec.hs +++ b/test/unit/HaRePluginSpec.hs @@ -270,6 +270,16 @@ hareSpec = do (filePathToUri $ cwd "test/testdata/gototest/src/Lib.hs") (Range (toPos (8, 1)) (toPos (8, 29))) ] + it "find definition of parameterized data type" $ do + let u = filePathToUri $ cwd "test/testdata/gototest/src/Lib.hs" + lreq = setTypecheckedModule u + req = liftToGhc $ TestDeferM $ findTypeDef u (toPos (40, 19)) + r <- dispatchRequestPGoto $ lreq >> req + r `shouldBe` IdeResultOk + [ Location + (filePathToUri $ cwd "test/testdata/gototest/src/Lib.hs") + (Range (toPos (37, 1)) (toPos (37, 31))) + ] -- --------------------------------- From 925c9963960fec8ed97eacc345b5a39349d7c632 Mon Sep 17 00:00:00 2001 From: fendor Date: Wed, 3 Apr 2019 12:13:34 +0200 Subject: [PATCH 10/17] Simplify findTypeDef by utilising typeMap Undo changes that are not related to this feature --- haskell-ide-engine.cabal | 1 - src/Haskell/Ide/Engine/Support/HieExtras.hs | 86 +++++++-------------- 2 files changed, 26 insertions(+), 61 deletions(-) diff --git a/haskell-ide-engine.cabal b/haskell-ide-engine.cabal index 915b2ef0f..0416cea1f 100644 --- a/haskell-ide-engine.cabal +++ b/haskell-ide-engine.cabal @@ -87,7 +87,6 @@ library , safe , sorted-list >= 0.2.1.0 , stm - , syb , tagsoup , text , transformers diff --git a/src/Haskell/Ide/Engine/Support/HieExtras.hs b/src/Haskell/Ide/Engine/Support/HieExtras.hs index e415bca7e..4d316d0d3 100644 --- a/src/Haskell/Ide/Engine/Support/HieExtras.hs +++ b/src/Haskell/Ide/Engine/Support/HieExtras.hs @@ -34,7 +34,6 @@ import Control.Monad.Except 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 @@ -182,9 +181,6 @@ mkPragmaCompl label insertText = safeTyThingId :: TyThing -> Maybe Id safeTyThingId (AnId i) = Just i safeTyThingId (AConLike (RealDataCon dc)) = Just $ dataConWrapId dc -safeTyThingId (ATyCon tyCon) = case GHC.tyConTyVars tyCon of - [] -> Nothing - (a:_) -> Just a safeTyThingId _ = Nothing -- Associates a module's qualifier with its members @@ -547,55 +543,25 @@ getModule df n = do return (pkg, T.pack $ moduleNameString $ moduleName m) -- --------------------------------------------------------------------- --- TODO: there has to be a simpler way, using the appropriate GHC internals --- |Find the Id for a given Name. --- Requires an already TypecheckedModule. --- A TypecheckedModule can be obtained by using the functions --- @ifCachedModuleAndData@ or @withCachedModuleAndData@. --- --- Function is copied from @HaRe/src/Language/Haskell/Refact/Utils/TypeUtils.hs:2954@. -findIdForName :: TypecheckedModule -> Name -> IdeM (Maybe 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 - --- --------------------------------------------------------------------- - --- | Get the type for a name. --- Requires an already TypecheckedModule. --- A TypecheckedModule can be obtained by using the functions --- @ifCachedModuleAndData@ or @withCachedModuleAndData@. --- --- Returns the type of a variable or a sum type constructor. --- --- Function is taken from @HaRe/src/Language/Haskell/Refact/Utils/TypeUtils.hs:2966@. -getTypeForName' :: TypecheckedModule -> Name -> IdeM (Maybe Type) -getTypeForName' tm n = do - mId <- findIdForName tm n - case mId of - Nothing -> getTypeForName n - Just i -> return $ Just (varType i) -- | Return the type definition of the symbol at the given position. --- Works for Datatypes, Newtypes and Type Definitions. --- The latter is only possible, if the type that is defined is defined in the project. +-- 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 -> - ifCachedModuleAndData -- Dont wait on this function if the module is not cached. - file + withCachedInfo + file (IdeResultOk []) -- Default result - (\tm info NMD{} -> do + (\info -> do let rfm = revMap info - lm = locMap info mm = moduleMap info + tmap = typeMap info oldPos = newPosToOld info pos + case (\x -> Just $ getArtifactsAtPos x mm) =<< oldPos of Just ((_, mn) : _) -> gotoModule rfm mn - _ -> do + _ -> do let -- | Get SrcSpan of the name at the given position. -- If the old position is Nothing, e.g. there is no cached info about it, @@ -603,29 +569,29 @@ findTypeDef uri pos = pluginGetFile "findTypeDef: " uri $ \file -> -- -- Otherwise, searches for the Type of the given position -- and retrieves its SrcSpan. - getSrcSpanFromPosition :: Maybe Position -> ExceptT () IdeDeferM SrcSpan - getSrcSpanFromPosition maybeOldPosition = do + getTypeSrcSpanFromPosition + :: Maybe Position -> ExceptT () IdeDeferM SrcSpan + getTypeSrcSpanFromPosition maybeOldPosition = do oldPosition <- liftMaybe maybeOldPosition - (_, n) <- liftMaybe $ symbolFromTypecheckedModule lm oldPosition - t <- liftMaybeM (lift $ getTypeForName' tm n) - tyCon <- liftMaybe $ tyConAppTyCon_maybe t - case nameSrcSpan (getName tyCon) of - UnhelpfulSpan _ -> throwError () - realSpan -> return realSpan - + 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 + liftMaybe val = liftEither $ case val of Nothing -> Left () - Just s -> Right s - - liftMaybeM :: Monad m => m (Maybe a) -> ExceptT () m a - liftMaybeM mval = do - val <- lift mval - liftMaybe val + Just s -> Right s - runExceptT (getSrcSpanFromPosition oldPos) >>= \case + runExceptT (getTypeSrcSpanFromPosition oldPos) >>= \case Left () -> return $ IdeResultOk [] - Right realSpan -> lift $ srcSpanToFileLocation "hare:findTypeDef" rfm realSpan + Right realSpan -> + lift $ srcSpanToFileLocation "hare:findTypeDef" rfm realSpan ) -- | Return the definition From acf23822f5a1ffb68bd7b1fbcf763fb7c3ce4161 Mon Sep 17 00:00:00 2001 From: fendor Date: Wed, 3 Apr 2019 14:24:34 +0200 Subject: [PATCH 11/17] Remove module lookup, since it can never be a module --- src/Haskell/Ide/Engine/Support/HieExtras.hs | 63 ++++++++++----------- 1 file changed, 29 insertions(+), 34 deletions(-) diff --git a/src/Haskell/Ide/Engine/Support/HieExtras.hs b/src/Haskell/Ide/Engine/Support/HieExtras.hs index 4d316d0d3..c4807f126 100644 --- a/src/Haskell/Ide/Engine/Support/HieExtras.hs +++ b/src/Haskell/Ide/Engine/Support/HieExtras.hs @@ -555,43 +555,38 @@ findTypeDef uri pos = pluginGetFile "findTypeDef: " uri $ \file -> (IdeResultOk []) -- Default result (\info -> do let rfm = revMap info - mm = moduleMap info tmap = typeMap info oldPos = newPosToOld info pos - case (\x -> Just $ getArtifactsAtPos x mm) =<< oldPos of - Just ((_, mn) : _) -> gotoModule rfm mn - _ -> do - let - -- | 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 + -- | 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 From e9763283ce5f0eaed141f28489c6ce836f79f93b Mon Sep 17 00:00:00 2001 From: fendor Date: Sun, 7 Apr 2019 11:37:38 +0200 Subject: [PATCH 12/17] Custom lsp-test to access findTypeDefinition --- .gitmodules | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/.gitmodules b/.gitmodules index 9a1155a22..385d45952 100644 --- a/.gitmodules +++ b/.gitmodules @@ -37,3 +37,7 @@ url = https://github.com/ennocramer/floskell # url = https://github.com/alanz/floskell +[submodule "submodules/lsp-test"] + path = submodules/lsp-test + url = https://github.com/bubba/lsp-test + # url = https://github.com/alanz/floskell From 7b58d49a223297138e7615e504f9a1c2db9c3b2a Mon Sep 17 00:00:00 2001 From: fendor Date: Sun, 7 Apr 2019 12:29:23 +0200 Subject: [PATCH 13/17] Add Functional tests --- test/functional/TypeDefinitionSpec.hs | 99 +++++++++++++++++++++++++++ 1 file changed, 99 insertions(+) create mode 100644 test/functional/TypeDefinitionSpec.hs diff --git a/test/functional/TypeDefinitionSpec.hs b/test/functional/TypeDefinitionSpec.hs new file mode 100644 index 000000000..5cb0f5408 --- /dev/null +++ b/test/functional/TypeDefinitionSpec.hs @@ -0,0 +1,99 @@ +module TypeDefinitionSpec where + +import Control.Monad.IO.Class +import Language.Haskell.LSP.Test +import Language.Haskell.LSP.Types +import Haskell.Ide.Engine.PluginUtils +import System.Directory +import Test.Hspec +import TestUtils + +spec :: Spec +spec = describe "type definitions" $ do + it "finds local definition of record variable" + $ runSession hieCommand fullCaps "test/testdata/gototest" + $ do + doc <- openDoc "src/Lib.hs" "haskell" + defs <- getTypeDefinitions doc (toPos (11, 23)) + liftIO $ do + fp <- canonicalizePath "test/testdata/gototest/src/Lib.hs" + defs + `shouldBe` [ Location (filePathToUri fp) + (Range (toPos (8, 1)) (toPos (8, 29))) + ] + it "finds local definition of newtype variable" + $ runSession hieCommand fullCaps "test/testdata/gototest" + $ do + doc <- openDoc "src/Lib.hs" "haskell" + defs <- getTypeDefinitions doc (toPos (16, 21)) + liftIO $ do + fp <- canonicalizePath "test/testdata/gototest/src/Lib.hs" + defs + `shouldBe` [ Location (filePathToUri fp) + (Range (toPos (13, 1)) (toPos (13, 30))) + ] + it "finds local definition of sum type variable" + $ runSession hieCommand fullCaps "test/testdata/gototest" + $ do + doc <- openDoc "src/Lib.hs" "haskell" + defs <- getTypeDefinitions doc (toPos (21, 13)) + liftIO $ do + fp <- canonicalizePath "test/testdata/gototest/src/Lib.hs" + defs + `shouldBe` [ Location (filePathToUri fp) + (Range (toPos (18, 1)) (toPos (18, 26))) + ] + it "finds local definition of sum type contructor" + $ runSession hieCommand fullCaps "test/testdata/gototest" + $ do + doc <- openDoc "src/Lib.hs" "haskell" + defs <- getTypeDefinitions doc (toPos (24, 7)) + liftIO $ do + fp <- canonicalizePath "test/testdata/gototest/src/Lib.hs" + defs + `shouldBe` [ Location (filePathToUri fp) + (Range (toPos (18, 1)) (toPos (18, 26))) + ] + it "can not find non-local definition of type def" + $ runSession hieCommand fullCaps "test/testdata/gototest" + $ do + doc <- openDoc "src/Lib.hs" "haskell" + defs <- getTypeDefinitions doc (toPos (30, 17)) + liftIO $ defs `shouldBe` [] + + it "find local definition of type def" + $ runSession hieCommand fullCaps "test/testdata/gototest" + $ do + doc <- openDoc "src/Lib2.hs" "haskell" + otherDoc <- openDoc "src/Lib.hs" "haskell" + closeDoc otherDoc + defs <- getTypeDefinitions doc (toPos (35, 16)) + liftIO $ do + fp <- canonicalizePath "test/testdata/gototest/src/Lib.hs" + defs + `shouldBe` [ Location (filePathToUri fp) + (Range (toPos (18, 1)) (toPos (18, 26))) + ] + + it "find type-definition of type def in component" + $ runSession hieCommand fullCaps "test/testdata/gototest" + $ do + doc <- openDoc "src/Lib.hs" "haskell" + defs <- getTypeDefinitions doc (toPos (13, 20)) + liftIO $ do + fp <- canonicalizePath "test/testdata/gototest/src/Lib.hs" + defs + `shouldBe` [ Location (filePathToUri fp) + (Range (toPos (8, 1)) (toPos (8, 29))) + ] + it "find definition of parameterized data type" + $ runSession hieCommand fullCaps "test/testdata/gototest" + $ do + doc <- openDoc "src/Lib.hs" "haskell" + defs <- getTypeDefinitions doc (toPos (40, 19)) + liftIO $ do + fp <- canonicalizePath "test/testdata/gototest/src/Lib.hs" + defs + `shouldBe` [ Location (filePathToUri fp) + (Range (toPos (37, 1)) (toPos (37, 31))) + ] From 625c61ceafb7b795e8f7aba7b397f27750d6304c Mon Sep 17 00:00:00 2001 From: fendor Date: Sun, 7 Apr 2019 21:20:33 +0200 Subject: [PATCH 14/17] Bump lsp-test version to 0.5.1.0 and haskell-lsp --- stack-8.2.1.yaml | 4 ++-- stack-8.2.2.yaml | 4 ++-- stack-8.4.2.yaml | 4 ++-- stack-8.4.3.yaml | 4 ++-- stack-8.4.4.yaml | 4 ++-- stack-8.6.1.yaml | 4 ++-- stack-8.6.2.yaml | 2 ++ stack-8.6.3.yaml | 2 ++ stack-8.6.4.yaml | 1 + stack.yaml | 1 + 10 files changed, 18 insertions(+), 12 deletions(-) diff --git a/stack-8.2.1.yaml b/stack-8.2.1.yaml index b22cc93b0..8a4d2377c 100644 --- a/stack-8.2.1.yaml +++ b/stack-8.2.1.yaml @@ -19,11 +19,11 @@ 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 diff --git a/stack-8.2.2.yaml b/stack-8.2.2.yaml index c8b9522c6..de309f9a5 100644 --- a/stack-8.2.2.yaml +++ b/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 diff --git a/stack-8.4.2.yaml b/stack-8.4.2.yaml index a8271094e..ebf88652c 100644 --- a/stack-8.4.2.yaml +++ b/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 diff --git a/stack-8.4.3.yaml b/stack-8.4.3.yaml index 693a96f44..37d1afc45 100644 --- a/stack-8.4.3.yaml +++ b/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 diff --git a/stack-8.4.4.yaml b/stack-8.4.4.yaml index 37feb5a9d..cb41a4926 100644 --- a/stack-8.4.4.yaml +++ b/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 diff --git a/stack-8.6.1.yaml b/stack-8.6.1.yaml index 699868d27..9fca2af6f 100644 --- a/stack-8.6.1.yaml +++ b/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 diff --git a/stack-8.6.2.yaml b/stack-8.6.2.yaml index a9ab46edf..1f8fac53f 100644 --- a/stack-8.6.2.yaml +++ b/stack-8.6.2.yaml @@ -16,9 +16,11 @@ extra-deps: - constrained-dynamic-0.1.0.0 - haddock-api-2.21.0 - haskell-src-exts-1.21.0 +- haskell-lsp-0.8.1.0 - hlint-2.1.15 - hoogle-5.0.17.5 - hsimport-0.8.8 +- lsp-test-0.5.1.0 - monad-dijkstra-0.1.1.2 - monad-memo-0.4.1 - multistate-0.8.0.1 diff --git a/stack-8.6.3.yaml b/stack-8.6.3.yaml index 0e1d3170d..2b1faaea4 100644 --- a/stack-8.6.3.yaml +++ b/stack-8.6.3.yaml @@ -16,9 +16,11 @@ extra-deps: - constrained-dynamic-0.1.0.0 - haddock-api-2.21.0 - haskell-src-exts-1.21.0 +- haskell-lsp-0.8.1.0 - hlint-2.1.15 - hoogle-5.0.17.5 - hsimport-0.8.8 +- lsp-test-0.5.1.0 - monad-dijkstra-0.1.1.2 - monad-memo-0.4.1 - multistate-0.8.0.1 diff --git a/stack-8.6.4.yaml b/stack-8.6.4.yaml index 403cbeadc..1573197c9 100644 --- a/stack-8.6.4.yaml +++ b/stack-8.6.4.yaml @@ -19,6 +19,7 @@ extra-deps: - hlint-2.1.15 - hsimport-0.8.8 - hoogle-5.0.17.6 +- lsp-test-0.5.1.0 - monad-dijkstra-0.1.1.2@rev:1 - monad-memo-0.4.1 - multistate-0.8.0.1 diff --git a/stack.yaml b/stack.yaml index 728414e8d..dc9d50e4e 100644 --- a/stack.yaml +++ b/stack.yaml @@ -20,6 +20,7 @@ extra-deps: - haddock-api-2.22.0 - hlint-2.1.15 - hsimport-0.8.8 +- lsp-test-0.5.1.0 - monad-dijkstra-0.1.1.2@rev:1 - monad-memo-0.4.1 - multistate-0.8.0.1 From 8e57671ac64869eb8026922b6a905f7337c3be0e Mon Sep 17 00:00:00 2001 From: fendor Date: Sun, 7 Apr 2019 22:57:38 +0200 Subject: [PATCH 15/17] Add func-test file --- haskell-ide-engine.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/haskell-ide-engine.cabal b/haskell-ide-engine.cabal index 0416cea1f..e116c9c72 100644 --- a/haskell-ide-engine.cabal +++ b/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 From cbfd9a1bcff207ec3f66728dae31ea826de624a2 Mon Sep 17 00:00:00 2001 From: fendor Date: Sun, 7 Apr 2019 23:35:29 +0200 Subject: [PATCH 16/17] Fix tests --- test/functional/TypeDefinitionSpec.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/test/functional/TypeDefinitionSpec.hs b/test/functional/TypeDefinitionSpec.hs index 5cb0f5408..03c389658 100644 --- a/test/functional/TypeDefinitionSpec.hs +++ b/test/functional/TypeDefinitionSpec.hs @@ -64,9 +64,7 @@ spec = describe "type definitions" $ do it "find local definition of type def" $ runSession hieCommand fullCaps "test/testdata/gototest" $ do - doc <- openDoc "src/Lib2.hs" "haskell" - otherDoc <- openDoc "src/Lib.hs" "haskell" - closeDoc otherDoc + doc <- openDoc "src/Lib.hs" "haskell" defs <- getTypeDefinitions doc (toPos (35, 16)) liftIO $ do fp <- canonicalizePath "test/testdata/gototest/src/Lib.hs" @@ -78,7 +76,9 @@ spec = describe "type definitions" $ do it "find type-definition of type def in component" $ runSession hieCommand fullCaps "test/testdata/gototest" $ do - doc <- openDoc "src/Lib.hs" "haskell" + doc <- openDoc "src/Lib2.hs" "haskell" + otherDoc <- openDoc "src/Lib.hs" "haskell" + closeDoc otherDoc defs <- getTypeDefinitions doc (toPos (13, 20)) liftIO $ do fp <- canonicalizePath "test/testdata/gototest/src/Lib.hs" From 6c59170de3c3062404881ac1b88265733e3518bb Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Mon, 8 Apr 2019 09:54:09 +0100 Subject: [PATCH 17/17] Remove unused lsp-test submodule --- .gitmodules | 5 ----- 1 file changed, 5 deletions(-) diff --git a/.gitmodules b/.gitmodules index 385d45952..96fb9f937 100644 --- a/.gitmodules +++ b/.gitmodules @@ -36,8 +36,3 @@ path = submodules/floskell url = https://github.com/ennocramer/floskell # url = https://github.com/alanz/floskell - -[submodule "submodules/lsp-test"] - path = submodules/lsp-test - url = https://github.com/bubba/lsp-test - # url = https://github.com/alanz/floskell