Track module dependencies (#431)

* Add ModLocation to Import type * Add ModuleNames to dependency information With @adamse * Clarify ModLocation assumption * Add a comment on use of rwhnf * newtype ArtifactsLocation Co-authored-by: Marcelo Lazaroni <[email protected]>
haskell · Feb 17, 2020 · 2ae46ae · 2ae46ae
1 parent fd01d20
commit 2ae46ae
Show file tree

Hide file tree

Showing 6 changed files with 109 additions and 28 deletions.
diff --git a/src/Development/IDE/Core/RuleTypes.hs b/src/Development/IDE/Core/RuleTypes.hs
@@ -15,7 +15,6 @@ import           Control.DeepSeq
 import Data.Binary
 import           Development.IDE.Import.DependencyInformation
 import Development.IDE.GHC.Util
-import Development.IDE.Types.Location
 import           Data.Hashable
 import           Data.Typeable
 import qualified Data.Set as S
@@ -28,6 +27,7 @@ import HscTypes (CgGuts, Linkable, HomeModInfo, ModDetails)
 import Development.IDE.GHC.Compat
 
 import           Development.IDE.Spans.Type
+import           Development.IDE.Import.FindImports (ArtifactsLocation)
 
 
 -- NOTATION
@@ -75,7 +75,7 @@ type instance RuleResult GhcSession = HscEnvEq
 
 -- | Resolve the imports in a module to the file path of a module
 -- in the same package or the package id of another package.
-type instance RuleResult GetLocatedImports = ([(Located ModuleName, Maybe NormalizedFilePath)], S.Set InstalledUnitId)
+type instance RuleResult GetLocatedImports = ([(Located ModuleName, Maybe ArtifactsLocation)], S.Set InstalledUnitId)
 
 -- | This rule is used to report import cycles. It depends on GetDependencyInformation.
 -- We cannot report the cycles directly from GetDependencyInformation since

diff --git a/src/Development/IDE/Core/Rules.hs b/src/Development/IDE/Core/Rules.hs
@@ -4,6 +4,7 @@
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE PatternSynonyms       #-}
 
 -- | A Shake implementation of the compiler service, built
 --   using the "Shaker" abstraction layer for in-memory use.
@@ -27,6 +28,7 @@ module Development.IDE.Core.Rules(
 import Fingerprint
 
 import Data.Binary
+import Data.Bifunctor (second)
 import Control.Monad
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.Maybe
@@ -39,6 +41,7 @@ import           Development.IDE.Core.FileExists
 import           Development.IDE.Core.FileStore        (getFileContents)
 import           Development.IDE.Types.Diagnostics
 import Development.IDE.Types.Location
+import Development.IDE.GHC.Compat hiding (parseModule, typecheckModule)
 import Development.IDE.GHC.Util
 import Data.Coerce
 import Data.Either.Extra
@@ -54,9 +57,7 @@ import           Development.Shake                        hiding (Diagnostic)
 import Development.IDE.Core.RuleTypes
 import Development.IDE.Spans.Type
 
-import           GHC hiding (parseModule, typecheckModule)
 import qualified GHC.LanguageExtensions as LangExt
-import Development.IDE.GHC.Compat (hie_file_result, readHieFile)
 import           UniqSupply
 import NameCache
 import HscTypes
@@ -176,7 +177,7 @@ getLocatedImportsRule =
 -- imports recursively.
 rawDependencyInformation :: NormalizedFilePath -> Action RawDependencyInformation
 rawDependencyInformation f = do
-    let (initialId, initialMap) = getPathId f emptyPathIdMap
+    let (initialId, initialMap) = getPathId (ArtifactsLocation $ ModLocation (Just $ fromNormalizedFilePath f) "" "") emptyPathIdMap
     go (IntSet.singleton $ getFilePathId initialId)
        (RawDependencyInformation IntMap.empty initialMap)
   where
@@ -194,7 +195,7 @@ rawDependencyInformation f = do
                     let rawDepInfo' = insertImport fId (Left ModuleParseError) rawDepInfo
                     in go fs rawDepInfo'
                   Just (modImports, pkgImports) -> do
-                    let f :: PathIdMap -> (a, Maybe NormalizedFilePath) -> (PathIdMap, (a, Maybe FilePathId))
+                    let f :: PathIdMap -> (a, Maybe ArtifactsLocation) -> (PathIdMap, (a, Maybe FilePathId))
                         f pathMap (imp, mbPath) = case mbPath of
                             Nothing -> (pathMap, (imp, Nothing))
                             Just path ->
@@ -265,11 +266,11 @@ getSpanInfoRule :: Rules ()
 getSpanInfoRule =
     define $ \GetSpanInfo file -> do
         tc <- use_ TypeCheck file
-        deps <- maybe (TransitiveDependencies [] []) fst <$> useWithStale GetDependencies file
+        deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file
         parsedDeps <- mapMaybe (fmap fst) <$> usesWithStale GetParsedModule (transitiveModuleDeps deps)
         (fileImports, _) <- use_ GetLocatedImports file
         packageState <- hscEnv <$> use_ GhcSession file
-        x <- liftIO $ getSrcSpanInfos packageState fileImports tc parsedDeps
+        x <- liftIO $ getSrcSpanInfos packageState (fmap (second (fmap modLocationToNormalizedFilePath)) fileImports) tc parsedDeps
         return ([], Just x)
 
 -- Typechecks a module.

diff --git a/src/Development/IDE/GHC/Compat.hs b/src/Development/IDE/GHC/Compat.hs
@@ -23,6 +23,8 @@ module Development.IDE.GHC.Compat(
     pattern ValD,
     pattern ClassOpSig,
     pattern IEThingWith,
+    GHC.ModLocation,
+    pattern ModLocation,
 
     module GHC
     ) where
@@ -32,14 +34,14 @@ import DynFlags
 import FieldLabel
 
 import qualified GHC
-import GHC hiding (ClassOpSig, DerivD, ForD, IEThingWith, InstD, TyClD, ValD)
+import GHC hiding (ClassOpSig, DerivD, ForD, IEThingWith, InstD, TyClD, ValD, ModLocation)
 
 #if MIN_GHC_API_VERSION(8,8,0)
 import HieAst
 import HieBin
 import HieTypes
 #else
-import GhcPlugins
+import GhcPlugins hiding (ModLocation)
 import NameCache
 import Avail
 import TcRnTypes
@@ -136,4 +138,12 @@ pattern IEThingWith a b c d <-
     GHC.IEThingWith _ a b c d
 #else
     GHC.IEThingWith a b c d
-#endif
+#endif
+
+pattern ModLocation :: Maybe FilePath -> FilePath -> FilePath -> GHC.ModLocation
+pattern ModLocation a b c <-
+#if MIN_GHC_API_VERSION(8,8,0)
+    GHC.ModLocation a b c _ where ModLocation a b c = GHC.ModLocation a b c ""
+#else
+    GHC.ModLocation a b c where ModLocation a b c = GHC.ModLocation a b c
+#endif
diff --git a/src/Development/IDE/Import/DependencyInformation.hs b/src/Development/IDE/Import/DependencyInformation.hs
@@ -9,6 +9,7 @@ module Development.IDE.Import.DependencyInformation
   , ModuleParseError(..)
   , TransitiveDependencies(..)
   , FilePathId(..)
+  , NamedModuleDep(..)
 
   , PathIdMap
   , emptyPathIdMap
@@ -17,7 +18,7 @@ module Development.IDE.Import.DependencyInformation
   , pathToId
   , idToPath
   , reachableModules
-
+  , modLocationToNormalizedFilePath
   , processDependencyInformation
   , transitiveDeps
   ) where
@@ -46,6 +47,7 @@ import GHC.Generics (Generic)
 
 import Development.IDE.Types.Diagnostics
 import Development.IDE.Types.Location
+import Development.IDE.Import.FindImports (ArtifactsLocation(..))
 
 import GHC
 import Module
@@ -67,27 +69,34 @@ newtype FilePathId = FilePathId { getFilePathId :: Int }
   deriving (Show, NFData, Eq, Ord)
 
 data PathIdMap = PathIdMap
-  { idToPathMap :: !(IntMap NormalizedFilePath)
+  { idToPathMap :: !(IntMap ArtifactsLocation)
   , pathToIdMap :: !(HashMap NormalizedFilePath FilePathId)
   }
   deriving (Show, Generic)
 
 instance NFData PathIdMap
 
+modLocationToNormalizedFilePath :: ArtifactsLocation -> NormalizedFilePath
+modLocationToNormalizedFilePath (ArtifactsLocation loc) =
+    case ml_hs_file loc of
+      Just filePath -> toNormalizedFilePath filePath
+      -- Since we craete all 'ModLocation' values via 'mkHomeModLocation'
+      Nothing -> error "Has something changed in mkHomeModLocation?"
+
 emptyPathIdMap :: PathIdMap
 emptyPathIdMap = PathIdMap IntMap.empty HMS.empty
 
-getPathId :: NormalizedFilePath -> PathIdMap -> (FilePathId, PathIdMap)
+getPathId :: ArtifactsLocation -> PathIdMap -> (FilePathId, PathIdMap)
 getPathId path m@PathIdMap{..} =
-    case HMS.lookup path pathToIdMap of
+    case HMS.lookup (modLocationToNormalizedFilePath path) pathToIdMap of
         Nothing ->
             let !newId = FilePathId $ HMS.size pathToIdMap
             in (newId, insertPathId path newId m)
         Just id -> (id, m)
 
-insertPathId :: NormalizedFilePath -> FilePathId -> PathIdMap -> PathIdMap
+insertPathId :: ArtifactsLocation -> FilePathId -> PathIdMap -> PathIdMap
 insertPathId path id PathIdMap{..} =
-    PathIdMap (IntMap.insert (getFilePathId id) path idToPathMap) (HMS.insert path id pathToIdMap)
+    PathIdMap (IntMap.insert (getFilePathId id) path idToPathMap) (HMS.insert (modLocationToNormalizedFilePath path) id pathToIdMap)
 
 insertImport :: FilePathId -> Either ModuleParseError ModuleImports -> RawDependencyInformation -> RawDependencyInformation
 insertImport (FilePathId k) v rawDepInfo = rawDepInfo { rawImports = IntMap.insert k v (rawImports rawDepInfo) }
@@ -96,7 +105,11 @@ pathToId :: PathIdMap -> NormalizedFilePath -> FilePathId
 pathToId PathIdMap{pathToIdMap} path = pathToIdMap HMS.! path
 
 idToPath :: PathIdMap -> FilePathId -> NormalizedFilePath
-idToPath PathIdMap{idToPathMap} (FilePathId id) = idToPathMap IntMap.! id
+idToPath pathIdMap filePathId = modLocationToNormalizedFilePath $ idToModLocation pathIdMap filePathId
+
+idToModLocation :: PathIdMap -> FilePathId -> ArtifactsLocation
+idToModLocation PathIdMap{idToPathMap} (FilePathId id) = idToPathMap IntMap.! id
+
 
 -- | Unprocessed results that we find by following imports recursively.
 data RawDependencyInformation = RawDependencyInformation
@@ -112,6 +125,7 @@ data DependencyInformation =
   DependencyInformation
     { depErrorNodes :: !(IntMap (NonEmpty NodeError))
     -- ^ Nodes that cannot be processed correctly.
+    , depModuleNames :: !(IntMap ShowableModuleName)
     , depModuleDeps :: !(IntMap IntSet)
     -- ^ For a non-error node, this contains the set of module immediate dependencies
     -- in the same package.
@@ -120,6 +134,12 @@ data DependencyInformation =
     , depPathIdMap :: !PathIdMap
     } deriving (Show, Generic)
 
+newtype ShowableModuleName =
+  ShowableModuleName {showableModuleName :: ModuleName}
+  deriving NFData
+
+instance Show ShowableModuleName where show = moduleNameString . showableModuleName
+
 reachableModules :: DependencyInformation -> [NormalizedFilePath]
 reachableModules DependencyInformation{..} =
     map (idToPath depPathIdMap . FilePathId) $ IntMap.keys depErrorNodes <> IntMap.keys depModuleDeps
@@ -186,16 +206,24 @@ processDependencyInformation rawDepInfo@RawDependencyInformation{..} =
   DependencyInformation
     { depErrorNodes = IntMap.fromList errorNodes
     , depModuleDeps = moduleDeps
+    , depModuleNames = IntMap.fromList $ coerce moduleNames
     , depPkgDeps = pkgDependencies rawDepInfo
     , depPathIdMap = rawPathIdMap
     }
   where resultGraph = buildResultGraph rawImports
         (errorNodes, successNodes) = partitionNodeResults $ IntMap.toList resultGraph
+        moduleNames :: [(FilePathId, ModuleName)]
+        moduleNames =
+          [ (fId, modName) | (_, imports) <- successNodes, (L _ modName, fId) <- imports]
         successEdges :: [(FilePathId, FilePathId, [FilePathId])]
         successEdges =
-            map (\(file, imports) -> (FilePathId file, FilePathId file, map snd imports)) successNodes
+            map
+              (\(file, imports) -> (FilePathId file, FilePathId file, map snd imports))
+              successNodes
         moduleDeps =
-          IntMap.fromList $ map (\(_, FilePathId v, vs) -> (v, IntSet.fromList $ coerce vs)) successEdges
+          IntMap.fromList $
+          map (\(_, FilePathId v, vs) -> (v, IntSet.fromList $ coerce vs))
+            successEdges
 
 -- | Given a dependency graph, buildResultGraph detects and propagates errors in that graph as follows:
 -- 1. Mark each node that is part of an import cycle as an error node.
@@ -268,22 +296,52 @@ transitiveDeps DependencyInformation{..} file = do
       IntSet.delete (getFilePathId fileId) .
       IntSet.fromList . map (fst3 . fromVertex) .
       reachable g <$> toVertex (getFilePathId fileId)
-  let transitiveModuleDepIds = filter (\v -> v `IntSet.member` reachableVs) $ map (fst3 . fromVertex) vs
+  let transitiveModuleDepIds =
+        filter (\v -> v `IntSet.member` reachableVs) $ map (fst3 . fromVertex) vs
   let transitivePkgDeps =
           Set.toList $ Set.unions $
           map (\f -> IntMap.findWithDefault Set.empty f depPkgDeps) $
           getFilePathId fileId : transitiveModuleDepIds
-  let transitiveModuleDeps = map (idToPath depPathIdMap . FilePathId) transitiveModuleDepIds
+  let transitiveModuleDeps =
+        map (idToPath depPathIdMap . FilePathId) transitiveModuleDepIds
+  let transitiveNamedModuleDeps =
+        [ NamedModuleDep (idToPath depPathIdMap (FilePathId fid)) mn ml
+        | (fid, ShowableModuleName mn) <- IntMap.toList depModuleNames
+        , let ArtifactsLocation ml = idToPathMap depPathIdMap IntMap.! fid
+        ]
   pure TransitiveDependencies {..}
-  where (g, fromVertex, toVertex) = graphFromEdges (map (\(f, fs) -> (f, f, IntSet.toList fs)) $ IntMap.toList depModuleDeps)
-        vs = topSort g
+  where
+    (g, fromVertex, toVertex) = graphFromEdges (map (\(f, fs) -> (f, f, IntSet.toList fs)) $ IntMap.toList depModuleDeps)
+    vs = topSort g
 
 data TransitiveDependencies = TransitiveDependencies
   { transitiveModuleDeps :: [NormalizedFilePath]
+  , transitiveNamedModuleDeps :: [NamedModuleDep]
   -- ^ Transitive module dependencies in topological order.
   -- The module itself is not included.
   , transitivePkgDeps :: [InstalledUnitId]
   -- ^ Transitive pkg dependencies in unspecified order.
   } deriving (Eq, Show, Generic)
 
 instance NFData TransitiveDependencies
+
+data NamedModuleDep = NamedModuleDep {
+  nmdFilePath :: !NormalizedFilePath,
+  nmdModuleName :: !ModuleName,
+  nmdModLocation :: !ModLocation
+  }
+  deriving Generic
+
+instance Eq NamedModuleDep where
+  a == b = nmdFilePath a == nmdFilePath b
+
+instance NFData NamedModuleDep where
+  rnf NamedModuleDep{..} =
+    rnf nmdFilePath `seq`
+    rnf nmdModuleName `seq`
+    -- 'ModLocation' lacks an 'NFData' instance
+    rwhnf nmdModLocation
+
+instance Show NamedModuleDep where
+  show NamedModuleDep{..} = show nmdFilePath
+
diff --git a/src/Development/IDE/Import/FindImports.hs b/src/Development/IDE/Import/FindImports.hs
@@ -7,6 +7,7 @@
 module Development.IDE.Import.FindImports
   ( locateModule
   , Import(..)
+  , ArtifactsLocation(..)
   ) where
 
 import           Development.IDE.GHC.Error as ErrUtils
@@ -29,10 +30,16 @@ import           Control.Monad.IO.Class
 import           System.FilePath
 
 data Import
-  = FileImport !NormalizedFilePath
+  = FileImport !ArtifactsLocation
   | PackageImport !M.InstalledUnitId
   deriving (Show)
 
+newtype ArtifactsLocation =  ArtifactsLocation ModLocation
+    deriving (Show)
+
+instance NFData ArtifactsLocation where
+  rnf = const ()
+
 instance NFData Import where
   rnf (FileImport x) = rnf x
   rnf (PackageImport x) = rnf x
@@ -74,7 +81,7 @@ locateModule dflags exts doesExist modName mbPkgName isSource = do
       mbFile <- locateModuleFile dflags exts doesExist isSource $ unLoc modName
       case mbFile of
         Nothing -> return $ Left $ notFoundErr dflags modName $ LookupNotFound []
-        Just file -> return $ Right $ FileImport file
+        Just file -> toModLocation file
     -- if a package name is given we only go look for a package
     Just _pkgName -> lookupInPackageDB dflags
     Nothing -> do
@@ -83,8 +90,13 @@ locateModule dflags exts doesExist modName mbPkgName isSource = do
       mbFile <- locateModuleFile dflags exts doesExist isSource $ unLoc modName
       case mbFile of
         Nothing -> lookupInPackageDB dflags
-        Just file -> return $ Right $ FileImport file
+        Just file -> toModLocation file
   where
+    toModLocation file = liftIO $ do
+        loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file)
+        return $ Right $ FileImport $ ArtifactsLocation loc
+
+
     lookupInPackageDB dfs =
       case lookupModuleWithSuggestions dfs (unLoc modName) mbPkgName of
         LookupFound _m pkgConfig -> return $ Right $ PackageImport $ unitId pkgConfig

diff --git a/src/Development/IDE/Plugin/Completions.hs b/src/Development/IDE/Plugin/Completions.hs
@@ -31,7 +31,7 @@ plugin = Plugin produceCompletions setHandlersCompletion
 produceCompletions :: Rules ()
 produceCompletions =
     define $ \ProduceCompletions file -> do
-        deps <- maybe (TransitiveDependencies [] []) fst <$> useWithStale GetDependencies file
+        deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file
         parsedDeps <- mapMaybe (fmap fst) <$> usesWithStale GetParsedModule (transitiveModuleDeps deps)
         tm <- fmap fst <$> useWithStale TypeCheck file
         packageState <- fmap (hscEnv . fst) <$> useWithStale GhcSession file