module Development.IDE.Import.DependencyInformation
( DependencyInformation(..)
, ModuleImports(..)
, RawDependencyInformation(..)
, NodeError(..)
, ModuleParseError(..)
, TransitiveDependencies(..)
, FilePathId(..)
, PathIdMap
, emptyPathIdMap
, getPathId
, insertImport
, pathToId
, idToPath
, reachableModules
, processDependencyInformation
, transitiveDeps
) where
import Control.DeepSeq
import Data.Bifunctor
import Data.Coerce
import Data.List
import Development.IDE.GHC.Orphans()
import Data.Either
import Data.Graph
import Data.List.NonEmpty (NonEmpty(..), nonEmpty)
import qualified Data.List.NonEmpty as NonEmpty
import Data.IntMap (IntMap)
import qualified Data.IntMap.Strict as IntMap
import qualified Data.IntMap.Lazy as IntMapLazy
import Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet
import Data.Map (Map)
import qualified Data.Map.Strict as MS
import Data.Maybe
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Tuple.Extra (fst3)
import GHC.Generics (Generic)
import Development.IDE.Types.Diagnostics
import Development.IDE.Types.Location
import GHC
import Module
data ModuleImports = ModuleImports
{ moduleImports :: ![(Located ModuleName, Maybe FilePathId)]
, packageImports :: !(Set InstalledUnitId)
}
newtype FilePathId = FilePathId { getFilePathId :: Int }
deriving (Show, NFData, Eq, Ord)
data PathIdMap = PathIdMap
{ idToPathMap :: !(IntMap NormalizedFilePath)
, pathToIdMap :: !(Map NormalizedFilePath FilePathId)
}
deriving (Show, Generic)
instance NFData PathIdMap
emptyPathIdMap :: PathIdMap
emptyPathIdMap = PathIdMap IntMap.empty MS.empty
getPathId :: NormalizedFilePath -> PathIdMap -> (FilePathId, PathIdMap)
getPathId path m@PathIdMap{..} =
case MS.lookup path pathToIdMap of
Nothing ->
let !newId = FilePathId $ MS.size pathToIdMap
in (newId, insertPathId path newId m)
Just id -> (id, m)
insertPathId :: NormalizedFilePath -> FilePathId -> PathIdMap -> PathIdMap
insertPathId path id PathIdMap{..} =
PathIdMap (IntMap.insert (getFilePathId id) path idToPathMap) (MS.insert path id pathToIdMap)
insertImport :: FilePathId -> Either ModuleParseError ModuleImports -> RawDependencyInformation -> RawDependencyInformation
insertImport (FilePathId k) v rawDepInfo = rawDepInfo { rawImports = IntMap.insert k v (rawImports rawDepInfo) }
pathToId :: PathIdMap -> NormalizedFilePath -> FilePathId
pathToId PathIdMap{pathToIdMap} path = pathToIdMap MS.! path
idToPath :: PathIdMap -> FilePathId -> NormalizedFilePath
idToPath PathIdMap{idToPathMap} (FilePathId id) = idToPathMap IntMap.! id
data RawDependencyInformation = RawDependencyInformation
{ rawImports :: !(IntMap (Either ModuleParseError ModuleImports))
, rawPathIdMap :: !PathIdMap
}
pkgDependencies :: RawDependencyInformation -> IntMap (Set InstalledUnitId)
pkgDependencies RawDependencyInformation{..} =
IntMap.map (either (const Set.empty) packageImports) rawImports
data DependencyInformation =
DependencyInformation
{ depErrorNodes :: !(IntMap (NonEmpty NodeError))
, depModuleDeps :: !(IntMap IntSet)
, depPkgDeps :: !(IntMap (Set InstalledUnitId))
, depPathIdMap :: !PathIdMap
} deriving (Show, Generic)
reachableModules :: DependencyInformation -> [NormalizedFilePath]
reachableModules DependencyInformation{..} =
map (idToPath depPathIdMap . FilePathId) $ IntMap.keys depErrorNodes <> IntMap.keys depModuleDeps
instance NFData DependencyInformation
data ModuleParseError = ModuleParseError
deriving (Show, Generic)
instance NFData ModuleParseError
data LocateError = LocateError [Diagnostic]
deriving (Eq, Show, Generic)
instance NFData LocateError
data NodeError
= PartOfCycle (Located ModuleName) [FilePathId]
| FailedToLocateImport (Located ModuleName)
| ParseError ModuleParseError
| ParentOfErrorNode (Located ModuleName)
deriving (Show, Generic)
instance NFData NodeError where
rnf (PartOfCycle m fs) = m `seq` rnf fs
rnf (FailedToLocateImport m) = m `seq` ()
rnf (ParseError e) = rnf e
rnf (ParentOfErrorNode m) = m `seq` ()
data NodeResult
= ErrorNode (NonEmpty NodeError)
| SuccessNode [(Located ModuleName, FilePathId)]
deriving Show
partitionNodeResults
:: [(a, NodeResult)]
-> ([(a, NonEmpty NodeError)], [(a, [(Located ModuleName, FilePathId)])])
partitionNodeResults = partitionEithers . map f
where f (a, ErrorNode errs) = Left (a, errs)
f (a, SuccessNode imps) = Right (a, imps)
instance Semigroup NodeResult where
ErrorNode errs <> ErrorNode errs' = ErrorNode (errs <> errs')
ErrorNode errs <> SuccessNode _ = ErrorNode errs
SuccessNode _ <> ErrorNode errs = ErrorNode errs
SuccessNode a <> SuccessNode _ = SuccessNode a
processDependencyInformation :: RawDependencyInformation -> DependencyInformation
processDependencyInformation rawDepInfo@RawDependencyInformation{..} =
DependencyInformation
{ depErrorNodes = IntMap.fromList errorNodes
, depModuleDeps = moduleDeps
, depPkgDeps = pkgDependencies rawDepInfo
, depPathIdMap = rawPathIdMap
}
where resultGraph = buildResultGraph rawImports
(errorNodes, successNodes) = partitionNodeResults $ IntMap.toList resultGraph
successEdges :: [(FilePathId, FilePathId, [FilePathId])]
successEdges =
map (\(file, imports) -> (FilePathId file, FilePathId file, map snd imports)) successNodes
moduleDeps =
IntMap.fromList $ map (\(_, FilePathId v, vs) -> (v, IntSet.fromList $ coerce vs)) successEdges
buildResultGraph :: IntMap (Either ModuleParseError ModuleImports) -> IntMap NodeResult
buildResultGraph g = propagatedErrors
where
sccs = stronglyConnComp (graphEdges g)
(_, cycles) = partitionSCC sccs
cycleErrors :: IntMap NodeResult
cycleErrors = IntMap.unionsWith (<>) $ map errorsForCycle cycles
errorsForCycle :: [FilePathId] -> IntMap NodeResult
errorsForCycle files =
IntMap.fromListWith (<>) $ coerce $ concatMap (cycleErrorsForFile files) files
cycleErrorsForFile :: [FilePathId] -> FilePathId -> [(FilePathId,NodeResult)]
cycleErrorsForFile cycle f =
let entryPoints = mapMaybe (findImport f) cycle
in map (\imp -> (f, ErrorNode (PartOfCycle imp cycle :| []))) entryPoints
otherErrors = IntMap.map otherErrorsForFile g
otherErrorsForFile :: Either ModuleParseError ModuleImports -> NodeResult
otherErrorsForFile (Left err) = ErrorNode (ParseError err :| [])
otherErrorsForFile (Right ModuleImports{moduleImports}) =
let toEither (imp, Nothing) = Left imp
toEither (imp, Just path) = Right (imp, path)
(errs, imports') = partitionEithers (map toEither moduleImports)
in case nonEmpty errs of
Nothing -> SuccessNode imports'
Just errs' -> ErrorNode (NonEmpty.map FailedToLocateImport errs')
unpropagatedErrors = IntMap.unionWith (<>) cycleErrors otherErrors
propagatedErrors =
IntMapLazy.map propagate unpropagatedErrors
propagate :: NodeResult -> NodeResult
propagate n@(ErrorNode _) = n
propagate n@(SuccessNode imps) =
let results = map (\(imp, FilePathId dep) -> (imp, propagatedErrors IntMap.! dep)) imps
(errs, _) = partitionNodeResults results
in case nonEmpty errs of
Nothing -> n
Just errs' -> ErrorNode (NonEmpty.map (ParentOfErrorNode . fst) errs')
findImport :: FilePathId -> FilePathId -> Maybe (Located ModuleName)
findImport (FilePathId file) importedFile =
case g IntMap.! file of
Left _ -> error "Tried to call findImport on a module with a parse error"
Right ModuleImports{moduleImports} ->
fmap fst $ find (\(_, resolvedImp) -> resolvedImp == Just importedFile) moduleImports
graphEdges :: IntMap (Either ModuleParseError ModuleImports) -> [(FilePathId, FilePathId, [FilePathId])]
graphEdges g =
map (\(k, v) -> (FilePathId k, FilePathId k, deps v)) $ IntMap.toList g
where deps :: Either e ModuleImports -> [FilePathId]
deps (Left _) = []
deps (Right ModuleImports{moduleImports}) = mapMaybe snd moduleImports
partitionSCC :: [SCC a] -> ([a], [[a]])
partitionSCC (CyclicSCC xs:rest) = second (xs:) $ partitionSCC rest
partitionSCC (AcyclicSCC x:rest) = first (x:) $ partitionSCC rest
partitionSCC [] = ([], [])
transitiveDeps :: DependencyInformation -> NormalizedFilePath -> Maybe TransitiveDependencies
transitiveDeps DependencyInformation{..} file = do
let !fileId = pathToId depPathIdMap file
reachableVs <-
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 transitivePkgDeps =
Set.toList $ Set.unions $
map (\f -> IntMap.findWithDefault Set.empty f depPkgDeps) $
getFilePathId fileId : transitiveModuleDepIds
let transitiveModuleDeps = map (idToPath depPathIdMap . FilePathId) transitiveModuleDepIds
pure TransitiveDependencies {..}
where (g, fromVertex, toVertex) = graphFromEdges (map (\(f, fs) -> (f, f, IntSet.toList fs)) $ IntMap.toList depModuleDeps)
vs = topSort g
data TransitiveDependencies = TransitiveDependencies
{ transitiveModuleDeps :: [NormalizedFilePath]
, transitivePkgDeps :: [InstalledUnitId]
} deriving (Eq, Show, Generic)
instance NFData TransitiveDependencies