Refresh hiedb before incoming/outgoing calls

Author: July541

.github/workflows/test.yml

@@ -201,6 +201,6 @@ jobs:
         name: Test hls-refine-imports-plugin test suite
         run: cabal test hls-refine-imports-plugin --test-options="-j1 --rerun-update" || cabal test hls-refine-imports-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-refine-imports-plugin --test-options="-j1 --rerun"
 
-      - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test && matrix.ghc }}
+      - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test}}
         name: Test hls-call-hierarchy-plugin test suite
         run: cabal test hls-call-hierarchy-plugin --test-options="-j1 --rerun-update" || cabal test hls-call-hierarchy-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-call-hierarchy-plugin --test-options="-j1 --rerun"

cabal.project

@@ -88,17 +88,17 @@ allow-newer:
 source-repository-package
   type: git
   location: https://github.com/haskell/lsp.git
-  tag: e96383ab19534128f12acc70a69fbc15d4f298cc
+  tag: ef59c28b41ed4c5775f0ab0c1e985839359cec96
   subdir: lsp-types
 
 source-repository-package
   type: git
   location: https://github.com/haskell/lsp.git
-  tag: e96383ab19534128f12acc70a69fbc15d4f298cc
+  tag: ef59c28b41ed4c5775f0ab0c1e985839359cec96
   subdir: lsp-test
 
 source-repository-package
   type: git
   location: https://github.com/haskell/lsp.git
-  tag: e96383ab19534128f12acc70a69fbc15d4f298cc
+  tag: ef59c28b41ed4c5775f0ab0c1e985839359cec96
   subdir: lsp

plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal

@@ -22,9 +22,11 @@ library
   build-depends:
     , aeson
     , base                         >=4.12 && <5
+    , bytestring
     , containers
     , extra
     , ghc
+    , ghc-api-compat
     , ghcide                       >=1.2  && <1.5
     , hiedb
     , hls-plugin-api               ^>=1.1

plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs

@@ -1,4 +1,4 @@
-module Ide.Plugin.CallHierarchy where
+module Ide.Plugin.CallHierarchy (descriptor) where
 
 import           Development.IDE
 import qualified Ide.Plugin.CallHierarchy.Internal as X

plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs

@@ -5,39 +5,42 @@
 {-# LANGUAGE RecordWildCards     #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving  #-}
+
 module Ide.Plugin.CallHierarchy.Internal (
   prepareCallHierarchy
 , incomingCalls
 , outgoingCalls
 ) where
 
+import           Control.Concurrent
 import           Control.Lens                   ((^.))
 import           Control.Monad.Extra
 import           Control.Monad.IO.Class
 import           Data.Aeson                     as A
+import qualified Data.ByteString                as BS
 import qualified Data.HashMap.Strict            as HM
 import           Data.List                      (groupBy, sortBy)
 import qualified Data.Map                       as M
 import           Data.Maybe
 import qualified Data.Set                       as S
 import qualified Data.Text                      as T
+import qualified Data.Text.Encoding             as T
 import           Data.Tuple.Extra
 import           Development.IDE
+import           Development.IDE.Core.Compile
 import           Development.IDE.Core.Shake
 import           Development.IDE.GHC.Compat
 import           Development.IDE.Spans.AtPoint
-import           Development.IDE.Spans.Common
 import           HieDb                          (Symbol (Symbol))
 import qualified Ide.Plugin.CallHierarchy.Query as Q
 import           Ide.Plugin.CallHierarchy.Types
 import           Ide.Types
 import           Language.LSP.Types
 import qualified Language.LSP.Types.Lens        as L
-import           Maybes
 import           Name
-import           SrcLoc
 import           Text.Read                      (readMaybe)
 
+-- | Render prepare call hierarchy request.
 prepareCallHierarchy :: PluginMethodHandler IdeState TextDocumentPrepareCallHierarchy
 prepareCallHierarchy state pluginId param
   | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri =
@@ -92,11 +95,11 @@ construct nfp (ident, contexts, ssp)
 
   | Just ctx <- declInfo contexts
     = Just $ case ctx of
-        Decl ClassDec span -> mkCallHierarchyItem' ident SkInterface (renderSpan span) ssp
-        Decl ConDec   span -> mkCallHierarchyItem' ident SkConstructor (renderSpan span) ssp
-        Decl DataDec  span -> mkCallHierarchyItem' ident SkStruct (renderSpan span) ssp
-        Decl FamDec   span -> mkCallHierarchyItem' ident SkFunction (renderSpan span) ssp
-        Decl InstDec  span -> mkCallHierarchyItem' ident SkInterface (renderSpan span) ssp
+        Decl ClassDec span -> mkCallHierarchyItem' ident SkInterface     (renderSpan span) ssp
+        Decl ConDec   span -> mkCallHierarchyItem' ident SkConstructor   (renderSpan span) ssp
+        Decl DataDec  span -> mkCallHierarchyItem' ident SkStruct        (renderSpan span) ssp
+        Decl FamDec   span -> mkCallHierarchyItem' ident SkFunction      (renderSpan span) ssp
+        Decl InstDec  span -> mkCallHierarchyItem' ident SkInterface     (renderSpan span) ssp
         Decl SynDec   span -> mkCallHierarchyItem' ident SkTypeParameter (renderSpan span) ssp
         _ -> mkCallHierarchyItem' ident skUnknown ssp ssp
 
@@ -125,7 +128,7 @@ construct nfp (ident, contexts, ssp)
 mkCallHierarchyItem :: NormalizedFilePath -> Identifier -> SymbolKind -> Span -> Span -> CallHierarchyItem
 mkCallHierarchyItem nfp ident kind span selSpan =
   CallHierarchyItem
-    (T.pack $ identifierName ident)
+    (T.pack $ optimize $ identifierName ident)
     kind
     Nothing
     (Just $ T.pack $ identifierToDetail ident)
@@ -144,12 +147,16 @@ mkCallHierarchyItem nfp ident kind span selSpan =
       Left modName -> moduleNameString modName
       Right name   -> occNameString $ nameOccName name
 
+    optimize :: String -> String
+    optimize name -- optimize display for DuplicateRecordFields
+        | "$sel:" == take 5 name = drop 5 name
+        | otherwise = name
+
 mkSymbol :: Identifier -> Maybe Symbol
 mkSymbol = \case
   Left _     -> Nothing
   Right name -> Just $ Symbol (occName name) (nameModule name)
 
-
 ----------------------------------------------------------------------
 -------------- Incoming calls and outgoing calls ---------------------
 ----------------------------------------------------------------------
@@ -158,11 +165,12 @@ deriving instance Ord SymbolKind
 deriving instance Ord SymbolTag
 deriving instance Ord CallHierarchyItem
 
+-- | Render incoming calls request.
 incomingCalls :: PluginMethodHandler IdeState CallHierarchyIncomingCalls
 incomingCalls state pluginId param = do
   liftIO $ runAction "CallHierarchy.incomingCalls" state $
       queryCalls (param ^. L.item) Q.incomingCalls mkCallHierarchyIncomingCall
-        foiIncomingCalls mergeIncomingCalls >>=
+        mergeIncomingCalls >>=
     \case
       Just x  -> pure $ Right $ Just $ List x
       Nothing -> pure $ Left $ responseError "CallHierarchy: IncomingCalls internal error"
@@ -178,11 +186,12 @@ incomingCalls state pluginId param = do
         merge calls = let ranges = concatMap ((\(List x) -> x) . (^. L.fromRanges)) calls
                       in  CallHierarchyIncomingCall (head calls ^. L.from) (List ranges)
 
+-- Render outgoing calls request.
 outgoingCalls :: PluginMethodHandler IdeState CallHierarchyOutgoingCalls
 outgoingCalls state pluginId param = do
   liftIO $ runAction "CallHierarchy.outgoingCalls" state $
       queryCalls (param ^. L.item) Q.outgoingCalls mkCallHierarchyOutgoingCall
-                 foiOutgoingCalls mergeOutgoingCalls >>=
+        mergeOutgoingCalls >>=
     \case
       Just x  -> pure $ Right $ Just $ List x
       Nothing -> pure $ Left $ responseError "CallHierarchy: OutgoingCalls internal error"
@@ -223,21 +232,20 @@ queryCalls :: (Show a)
   => CallHierarchyItem
   -> (HieDb -> Symbol -> IO [Vertex])
   -> (Vertex -> Action (Maybe a))
-  -> (NormalizedFilePath -> Position -> Action (Maybe [a]))
   -> ([a] -> [a])
   -> Action (Maybe [a])
-queryCalls item queryFunc makeFunc foiCalls merge
+queryCalls item queryFunc makeFunc merge
   | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do
+    refreshHieDb
+
     ShakeExtras{hiedb} <- getShakeExtras
     maySymbol <- getSymbol nfp
     case maySymbol of
       Nothing -> error "CallHierarchy.Impossible"
       Just symbol -> do
         vs <- liftIO $ queryFunc hiedb symbol
-        nonFOIItems <- mapM makeFunc vs
-        foiRes <- foiCalls nfp pos
-        let nonFOIRes = Just $ catMaybes nonFOIItems
-        pure $ merge <$> (nonFOIRes <> foiRes)
+        items <- Just . catMaybes <$> mapM makeFunc vs
+        pure $ merge <$> items
   | otherwise = pure Nothing
   where
     uri = item ^. L.uri
@@ -266,43 +274,30 @@ queryCalls item queryFunc makeFunc foiCalls merge
                 Just res -> pure res
               Nothing -> pure Nothing
 
-foiIncomingCalls :: NormalizedFilePath -> Position -> Action (Maybe [CallHierarchyIncomingCall])
-foiIncomingCalls nfp pos =
-  use GetHieAst nfp >>=
-    \case
-      Nothing -> pure Nothing
-      Just (HAR _ hf _ _ _) -> do
-        case listToMaybe $ pointCommand hf pos id of
-          Nothing -> pure Nothing
-          Just ast -> do
-            fs <- HM.keys <$> getFilesOfInterestUntracked
-            Just . concatMap (`callers` ast) <$> mapMaybeM (use GetHieAst) fs
-  where
-    callers :: HieAstResult -> HieAST a -> [CallHierarchyIncomingCall]
-    callers (HAR _ hf _ _ _) ast = mkIncomingCalls $ filter (sameAst ast) $ M.elems (getAsts hf)
-
-    sameAst :: HieAST a -> HieAST b -> Bool
-    sameAst ast1 ast2 = (M.keys . nodeIdentifiers . nodeInfo) ast1
-                     == (M.keys . nodeIdentifiers . nodeInfo) ast2
-
-    mkIncomingCalls asts = let infos = concatMap extract asts
-                               items = mapMaybe (construct nfp) infos
-                           in  map (\item ->
-                                      CallHierarchyIncomingCall item
-                                        (List [item ^. L.selectionRange])) items
-
-foiOutgoingCalls :: NormalizedFilePath -> Position -> Action (Maybe [CallHierarchyOutgoingCall])
-foiOutgoingCalls nfp pos =
-  use GetHieAst nfp >>=
-    \case
-      Nothing -> pure Nothing
-      Just (HAR _ hf _ _ _) -> do
-        case listToMaybe $ pointCommand hf pos nodeChildren of
-          Nothing       -> pure Nothing
-          Just children -> pure $ Just $ mkOutgoingCalls children
-  where
-    mkOutgoingCalls asts = let infos = concatMap extract asts
-                               items = mapMaybe (construct nfp) infos
-                           in  map (\item ->
-                                      CallHierarchyOutgoingCall item
-                                        (List [item ^. L.selectionRange]) ) items
+-- Write modified foi files before queries.
+refreshHieDb :: Action ()
+refreshHieDb = do
+    fs <- HM.keys . HM.filter (/= OnDisk) <$> getFilesOfInterestUntracked
+    forM_ fs (\f -> do
+        tmr <- use_ TypeCheck f
+        hsc <- hscEnv <$> use_ GhcSession f
+        (_, masts) <- liftIO $ generateHieAsts hsc tmr
+        se <- getShakeExtras
+        case masts of
+            Nothing -> pure ()
+            Just asts -> do
+                source <- getSourceFileSource f
+                let exports = tcg_exports $ tmrTypechecked tmr
+                    msum = tmrModSummary tmr
+                liftIO $ writeAndIndexHieFile hsc se msum f exports asts source
+                pure ()
+        )
+    liftIO $ threadDelay 100000 -- delay 0.1 sec to make more exact results.
+
+-- Copy unexport function form `ghcide/src/Development/IDE/Core/Rules.hs`
+getSourceFileSource :: NormalizedFilePath -> Action BS.ByteString
+getSourceFileSource nfp = do
+    (_, msource) <- getFileContents nfp
+    case msource of
+        Nothing     -> liftIO $ BS.readFile (fromNormalizedFilePath nfp)
+        Just source -> pure $ T.encodeUtf8 source

plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs

@@ -2,13 +2,17 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards   #-}
 {-# LANGUAGE ViewPatterns      #-}
-module Ide.Plugin.CallHierarchy.Query where
+
+module Ide.Plugin.CallHierarchy.Query (
+  incomingCalls
+, outgoingCalls
+, getSymbolPosition
+) where
 
 import           Database.SQLite.Simple
 import           GHC
 import           HieDb                          (HieDb (getConn), Symbol (..),
                                                  toNsChar)
-import qualified HieDb
 import           Ide.Plugin.CallHierarchy.Types
 import           Module
 import           Name

plugins/hls-call-hierarchy-plugin/test/Main.hs

@@ -2,25 +2,24 @@
 {-# LANGUAGE OverloadedStrings  #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TupleSections      #-}
-module Main where
+
+module Main (main) where
 
 import           Control.Lens             (set, (^.))
 import           Control.Monad.Extra
 import           Data.Aeson
+import           Data.Functor             ((<&>))
 import           Data.List                (sort)
+import qualified Data.Map                 as M
 import qualified Data.Text                as T
 import           Ide.Plugin.CallHierarchy
 import qualified Language.LSP.Test        as Test
 import qualified Language.LSP.Types.Lens  as L
+import           System.Directory.Extra
 import           System.FilePath
 import qualified System.IO.Extra
 import           Test.Hls
 
-import           Control.Concurrent.Extra
-import           Data.Functor             ((<&>))
-import qualified Data.Map                 as M
-import           System.Directory.Extra
-
 plugin :: PluginDescriptor IdeState
 plugin = descriptor "callHierarchy"
 
@@ -177,7 +176,6 @@ incomingCallsTests =
           doc <- createDoc "A.hs" "haskell" $ T.unlines ["a=3", "b=a"]
           [item] <- Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 1 0)
           let expected = [CallHierarchyIncomingCall item (List [mkRange 1 2 1 3])]
-          liftIO delay -- A hack, ensure HieDb be initilized.
           Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 0 0) >>=
             \case
               [item] -> do
@@ -283,7 +281,6 @@ outgoingCallsTests =
           doc <- createDoc "A.hs" "haskell" $ T.unlines ["a=3", "b=a"]
           [item] <- Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 0 1)
           let expected = [CallHierarchyOutgoingCall item (List [mkRange 1 2 1 3])]
-          liftIO delay
           Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 1 0) >>=
             \case
               [item] -> do
@@ -391,7 +388,7 @@ incomingCallTestCase contents queryX queryY positions ranges = withTempDir $ \di
       )
       (zip positions ranges)
     let expected = map mkCallHierarchyIncomingCall items
-    liftIO delay
+    -- liftIO delay
     Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) >>=
       \case
         [item] -> do
@@ -411,7 +408,7 @@ incomingCallMultiFileTestCase filepath queryX queryY mp =
                     <&> map (, range)
                 ) pr) mp
     let expected = map mkCallHierarchyIncomingCall items
-    liftIO delay
+    -- liftIO delay
     Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) >>=
       \case
         [item] -> do
@@ -430,7 +427,6 @@ outgoingCallTestCase contents queryX queryY positions ranges = withTempDir $ \di
       )
       (zip positions ranges)
     let expected = map mkCallHierarchyOutgoingCall items
-    liftIO delay
     Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) >>=
       \case
         [item] -> do
@@ -450,7 +446,6 @@ outgoingCallMultiFileTestCase filepath queryX queryY mp =
                     <&> map (, range)
                 ) pr) mp
     let expected = map mkCallHierarchyOutgoingCall items
-    liftIO delay
     Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) >>=
       \case
         [item] -> do
@@ -503,6 +498,3 @@ withTempDir :: (FilePath -> IO a) -> IO a
 withTempDir f = System.IO.Extra.withTempDir $ \dir -> do
   dir' <- canonicalizePath dir
   f dir'
-
-delay :: IO ()
-delay = threadDelay 1000000