local type references

Author: wz1000

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

@@ -113,7 +113,6 @@ import Control.Concurrent.Extra
 import Data.Functor
 import Data.Unique
 import GHC.Fingerprint
-import Debug.Trace
 
 -- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'.
 parseModule
@@ -507,10 +506,10 @@ indexHieFile se mod_summary srcPath hash hf = atomically $ do
         Nothing -> do
           u <- LSP.ProgressTextToken . T.pack . show . hashUnique <$> newUnique
           lspId <- getLspId se
-          eventer se $ traceShowId $ LSP.ReqWorkDoneProgressCreate $
+          eventer se $ LSP.ReqWorkDoneProgressCreate $
             LSP.fmServerWorkDoneProgressCreateRequest lspId $
               LSP.WorkDoneProgressCreateParams { _token = u }
-          eventer se $ traceShowId $ LSP.NotWorkDoneProgressBegin $
+          eventer se $ LSP.NotWorkDoneProgressBegin $
             LSP.fmServerWorkDoneProgressBeginNotification
               LSP.ProgressParams
                   { _token = u
@@ -527,7 +526,7 @@ indexHieFile se mod_summary srcPath hash hf = atomically $ do
         remaining <- HashMap.size <$> readTVar indexPending
         pure (done, remaining)
       let progress = " (" <> T.pack (show done) <> "/" <> T.pack (show $ done + remaining) <> ")..."
-      eventer se $ traceShowId $ LSP.NotWorkDoneProgressReport $
+      eventer se $ LSP.NotWorkDoneProgressReport $
         LSP.fmServerWorkDoneProgressReportNotification
           LSP.ProgressParams
               { _token = tok
@@ -554,7 +553,7 @@ indexHieFile se mod_summary srcPath hash hf = atomically $ do
         Nothing -> pure ()
         Just done ->
           modifyVar_ indexProgressToken $ \_ -> do
-            eventer se $ traceShowId $ LSP.NotWorkDoneProgressEnd $
+            eventer se $ LSP.NotWorkDoneProgressEnd $
               LSP.fmServerWorkDoneProgressEndNotification
                 LSP.ProgressParams
                     { _token = tok

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

@@ -174,6 +174,8 @@ data HieAstResult
   -- ^ Lazy because its value only depends on the hieAst, which is bundled in this type
   -- Lazyness can't cause leaks here because the lifetime of `refMap` will be the same
   -- as that of `hieAst`
+  , typeRefs :: M.Map Name [RealSrcSpan]
+  -- ^ type references in this file
   , hieKind :: !(HieKind a)
   -- ^ Is this hie file loaded from the disk, or freshly computed?
   }
@@ -187,7 +189,7 @@ instance NFData (HieKind a) where
     rnf HieFresh = ()
 
 instance NFData HieAstResult where
-    rnf (HAR m hf _rm kind) = rnf m `seq` rwhnf hf `seq` rnf kind
+    rnf (HAR m hf _rm _tr kind) = rnf m `seq` rwhnf hf `seq` rnf kind
 
 instance Show HieAstResult where
     show = show . hieModule

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

@@ -102,9 +102,6 @@ import Module
 import qualified Data.Rope.UTF16 as Rope
 import GHC.IO.Encoding
 import Data.ByteString.Encoding as T
-import Debug.Trace
-import Outputable (showSDocUnsafe)
-import HieDebug
 
 import qualified HieDb
 
@@ -152,12 +149,10 @@ getAtPoint file pos = runMaybeT $ do
   ide <- ask
   opts <- liftIO $ getIdeOptionsIO ide
 
-  (hf@HAR{hieAst = asts}, mapping) <- useE GetHieAst file
+  (hf, mapping) <- useE GetHieAst file
   dkMap <- lift $ maybe (DKMap mempty mempty) fst <$> (runMaybeT $ useE GetDocMap file)
 
   !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
-  traceShowM ("Got pos",pos',"in original file")
-  -- traceM (showSDocUnsafe $ ppHies asts)
   MaybeT $ pure $ fmap (first (toCurrentRange mapping =<<)) $ AtPoint.atPoint opts hf dkMap pos'
 
 toCurrentLocations :: PositionMapping -> [Location] -> [Location]
@@ -170,7 +165,7 @@ getDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location])
 getDefinition file pos = runMaybeT $ do
     ide <- ask
     opts <- liftIO $ getIdeOptionsIO ide
-    (HAR _ hf _ _, mapping) <- useE GetHieAst file
+    (HAR _ hf _ _ _, mapping) <- useE GetHieAst file
     (ImportMap imports, _) <- useE GetImportMap file
     !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
     hiedb <- lift $ asks hiedb
@@ -189,7 +184,7 @@ getTypeDefinition file pos = runMaybeT $ do
 
 highlightAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe [DocumentHighlight])
 highlightAtPoint file pos = runMaybeT $ do
-    (HAR _ hf rf _,mapping) <- useE GetHieAst file
+    (HAR _ hf rf _ _,mapping) <- useE GetHieAst file
     !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
     let toCurrentHighlight (DocumentHighlight range t) = flip DocumentHighlight t <$> toCurrentRange mapping range
     mapMaybe toCurrentHighlight <$>AtPoint.documentHighlight hf rf pos'
@@ -531,7 +526,7 @@ persistentHieFileRule = addPersistentRule GetHieAst $ \file -> runMaybeT $ do
   encoding <- liftIO $ getLocaleEncoding
   let refmap = generateReferencesMap . getAsts . hie_asts $ res
       del = deltaFromDiff (T.decode encoding $ hie_hs_src res) currentSource
-  pure $ (HAR (hie_module res) (hie_asts res) refmap (HieFromDisk res),del,ver)
+  pure $ (HAR (hie_module res) (hie_asts res) refmap mempty (HieFromDisk res),del,ver)
 
 getHieAstRuleDefinition :: NormalizedFilePath -> HscEnv -> TcModuleResult -> Action (IdeResult HieAstResult)
 getHieAstRuleDefinition f hsc tmr = do
@@ -549,7 +544,8 @@ getHieAstRuleDefinition f hsc tmr = do
     _ -> pure []
 
   let refmap = generateReferencesMap . getAsts <$> masts
-  pure (diags <> diagsWrite, HAR (ms_mod $ tmrModSummary tmr) <$> masts <*> refmap <*> pure HieFresh)
+      typemap = AtPoint.computeTypeReferences . getAsts <$> masts
+  pure (diags <> diagsWrite, HAR (ms_mod $ tmrModSummary tmr) <$> masts <*> refmap <*> typemap <*> pure HieFresh)
 
 getImportMapRule :: Rules ()
 getImportMapRule = define $ \GetImportMap f -> do
@@ -786,6 +782,7 @@ getModIfaceFromDiskRule = defineEarlyCutoff $ \GetModIfaceFromDisk f -> do
                           Nothing -> regenerateHieFile
                           -- can just re-index the file we read from disk
                           Just hf -> liftIO $ do
+                            L.logInfo (logger se) $ "Re-indexing hie file for" <> T.pack (show (f,hash,fmap (HieDb.modInfoHash . HieDb.hieModInfo) mrow))
                             indexHieFile se ms f hash hf
                             return (fp, (diags <> diags_session, Just x))
 

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

@@ -135,7 +135,6 @@ import OpenTelemetry.Eventlog
 import GHC.Fingerprint
 
 import HieDb.Types
-import Debug.Trace
 
 -- | We need to serialize writes to the database, so we send any function that
 -- needs to write to the database over the channel, where it will be picked up by
@@ -1183,8 +1182,7 @@ filterVersionMap =
     HMap.intersectionWith $ \versionsToKeep versionMap -> Map.restrictKeys versionMap versionsToKeep
 
 updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> IO ()
-updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} v@VersionedTextDocumentIdentifier{..} (List changes) = do
-    traceShowM ("UpdatePositionMapping",v,changes)
+updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} (List changes) = do
     modifyVar_ positionMapping $ \allMappings -> do
         let uri = toNormalizedUri _uri
         let mappingForUri = HMap.lookupDefault Map.empty uri allMappings

ghcide/src/Development/IDE/Spans/AtPoint.hs

@@ -12,6 +12,7 @@ module Development.IDE.Spans.AtPoint (
   , documentHighlight
   , pointCommand
   , referencesAtPoint
+  , computeTypeReferences
   , FOIReferences(..)
   , defRowToSymbolInfo
   ) where
@@ -46,7 +47,7 @@ import Control.Monad.Trans.Class
 import Control.Monad.IO.Class
 import           Data.Maybe
 import qualified Data.Text as T
-import qualified Data.Map as M
+import qualified Data.Map.Strict as M
 import qualified Data.HashMap.Strict as HM
 
 import qualified Data.Array as A
@@ -63,6 +64,18 @@ type LookupModule m = FilePath -> ModuleName -> UnitId -> Bool -> MaybeT m Uri
 -- | HieFileResult for files of interest, along with the position mappings
 newtype FOIReferences = FOIReferences (HM.HashMap NormalizedFilePath (HieAstResult, PositionMapping))
 
+computeTypeReferences :: Foldable f => f (HieAST Type) -> M.Map Name [Span]
+computeTypeReferences = foldr (\ast m -> M.unionWith (++) (go ast) m) M.empty
+  where
+    go ast = M.unionsWith (++) (this : map go (nodeChildren ast))
+      where
+        this = M.fromListWith (++)
+          $ map (, [nodeSpan ast])
+          $ concatMap namesInType
+          $ mapMaybe (\x -> guard (any (not . isOccurrence) (identInfo x)) *> identType x)
+          $ M.elems
+          $ nodeIdentifiers $ nodeInfo ast
+
 -- | Given a file and position, return the names at a point, the references for
 -- those names in the FOIs, and a list of file paths we already searched through
 foiReferencesAtPoint
@@ -73,14 +86,16 @@ foiReferencesAtPoint
 foiReferencesAtPoint file pos (FOIReferences asts) =
   case HM.lookup file asts of
     Nothing -> ([],[],[])
-    Just (HAR _ hf _ _,mapping) ->
+    Just (HAR _ hf _ _ _,mapping) ->
       let posFile = fromMaybe pos $ fromCurrentPosition mapping pos
           names = concat $ pointCommand hf posFile (rights . M.keys . nodeIdentifiers . nodeInfo)
           adjustedLocs = HM.foldr go [] asts
-          go (HAR _ _ rf _, mapping) xs = refs ++ xs
+          go (HAR _ _ rf tr _, mapping) xs = refs ++ typerefs ++ xs
             where
               refs = mapMaybe (toCurrentLocation mapping . realSrcSpanToLocation . fst)
                    $ concat $ mapMaybe (\n -> M.lookup (Right n) rf) names
+              typerefs = mapMaybe (toCurrentLocation mapping . realSrcSpanToLocation)
+                   $ concat $ mapMaybe (`M.lookup` tr) names
           toCurrentLocation mapping (Location uri range) = Location uri <$> toCurrentRange mapping range
         in (names, adjustedLocs,map fromNormalizedFilePath $ HM.keys asts)
 
@@ -101,14 +116,12 @@ referencesAtPoint hiedb nfp pos refs = do
       Just mod -> do
          -- Look for references (strictly in project files, not dependencies),
          -- excluding the files in the FOIs (since those are in foiRefs)
-         rows <- liftIO $ search hiedb True (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnitId mod) exclude
+         rows <- liftIO $ findReferences hiedb True (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnitId mod) exclude
          pure $ mapMaybe rowToLoc rows
-  -- Type references are expensive to compute, so we only look for them in the database, not the FOIs
-  -- Some inaccuracy for FOIs can be expected.
   typeRefs <- forM names $ \name ->
     case nameModule_maybe name of
       Just mod | isTcClsNameSpace (occNameSpace $ nameOccName name) -> do
-        refs <- liftIO $ findTypeRefs hiedb (nameOccName name) (moduleName mod) (moduleUnitId mod)
+        refs <- liftIO $ findTypeRefs hiedb True (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnitId mod) exclude
         pure $ mapMaybe typeRowToLoc refs
       _ -> pure []
   pure $ nubOrd $ foiRefs ++ concat nonFOIRefs ++ concat typeRefs
@@ -183,7 +196,7 @@ atPoint
   -> DocAndKindMap
   -> Position
   -> Maybe (Maybe Range, [T.Text])
-atPoint IdeOptions{} (HAR _ hf _ kind) (DKMap dm km) pos = listToMaybe $ pointCommand hf pos hoverInfo
+atPoint IdeOptions{} (HAR _ hf _ _ kind) (DKMap dm km) pos = listToMaybe $ pointCommand hf pos hoverInfo
   where
     -- Hover info for values/data
     hoverInfo ast = (Just range, prettyNames ++ pTypes)
@@ -230,7 +243,7 @@ typeLocationsAtPoint
   -> Position
   -> HieAstResult
   -> m [Location]
-typeLocationsAtPoint hiedb lookupModule _ideOptions pos (HAR _ ast _ hieKind) =
+typeLocationsAtPoint hiedb lookupModule _ideOptions pos (HAR _ ast _ _ hieKind) =
   case hieKind of
     HieFromDisk hf ->
       let arr = hie_types hf
@@ -252,16 +265,21 @@ typeLocationsAtPoint hiedb lookupModule _ideOptions pos (HAR _ ast _ hieKind) =
       let ts = concat $ pointCommand ast pos getts
           getts x = nodeType ni  ++ (mapMaybe identType $ M.elems $ nodeIdentifiers ni)
             where ni = nodeInfo x
-          getTypes ts = flip concatMap ts $ \case
-            TyVarTy n -> [Var.varName n]
-            AppTy a b -> getTypes [a,b]
-            TyConApp tc ts -> tyConName tc : getTypes ts
-            ForAllTy _ t -> getTypes [t]
-            FunTy a b -> getTypes [a,b]
-            CastTy t _ -> getTypes [t]
-            _ -> []
         in fmap nubOrd $ concatMapM (fmap (maybe [] id) . nameToLocation hiedb lookupModule) (getTypes ts)
 
+namesInType :: Type -> [Name]
+namesInType (TyVarTy n)      = [Var.varName n]
+namesInType (AppTy a b)      = getTypes [a,b]
+namesInType (TyConApp tc ts) = tyConName tc : getTypes ts
+namesInType (ForAllTy b t)   = Var.varName (binderVar b) : namesInType t
+namesInType (FunTy a b)      = getTypes [a,b]
+namesInType (CastTy t _)     = namesInType t
+namesInType (LitTy _)        = []
+namesInType _                = []
+
+getTypes :: [Type] -> [Name]
+getTypes ts = concatMap namesInType ts
+
 locationsAtPoint
   :: forall m a
    . MonadIO m