aboutsummaryrefslogtreecommitdiff
path: root/src/HaskellCodeExplorer/PackageInfo.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/HaskellCodeExplorer/PackageInfo.hs')
-rw-r--r--src/HaskellCodeExplorer/PackageInfo.hs1000
1 files changed, 508 insertions, 492 deletions
diff --git a/src/HaskellCodeExplorer/PackageInfo.hs b/src/HaskellCodeExplorer/PackageInfo.hs
index af1f478..2f336f4 100644
--- a/src/HaskellCodeExplorer/PackageInfo.hs
+++ b/src/HaskellCodeExplorer/PackageInfo.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE CPP #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RecordWildCards #-}
@@ -13,370 +12,394 @@ module HaskellCodeExplorer.PackageInfo
, testCreatePkgInfo
, ghcVersion
) where
-import qualified Data.List.NonEmpty as NE
-import Control.DeepSeq(deepseq)
-import Control.Exception
- ( IOException
- , SomeAsyncException
- , SomeException
- , fromException
- , throw
- , try
- )
-import qualified Data.Map as Map
-import Control.Monad (foldM, unless, when)
-import Control.Monad.Extra (anyM, findM)
-import Control.Monad.Logger
- ( LoggingT(..)
- , MonadLogger(..)
- , MonadLoggerIO(..)
- , logDebugN
- , logErrorN
- , logWarnN
- , logInfoN
- , runStdoutLoggingT
- )
-import qualified Data.ByteString as BS
-import qualified Data.HashMap.Strict as HM
-import Data.IORef (readIORef)
-import qualified Data.IntMap.Strict as IM
-import qualified Data.List as L
-import Data.Maybe
- ( fromMaybe
- , isJust
- , maybeToList
- , mapMaybe
- )
-import qualified Data.Set as S
-import qualified Data.Text as T
-import qualified Data.Text.Encoding as TE
-import Data.Version (Version(..), showVersion, makeVersion)
-import GHC.Data.Graph.Directed (flattenSCCs)
-import Distribution.Helper
- ( ChComponentName(..)
- , ChEntrypoint(..)
- , ChModuleName(..)
- , ProjLoc(..)
- , DistDir(..)
- , SCabalProjType(..)
- , allUnits
- , projectPackages
- , pPackageName
- , pSourceDir
- , pUnits
- , uComponentName
- , UnitInfo(..)
- , ChComponentInfo(..)
- , mkQueryEnv
- , runQuery
- )
-import GHC.Driver.Session
- ( gopt_set
- , parseDynamicFlagsCmdLine
- )
-import Control.Monad.Catch
- ( handle
- )
-import GHC.Utils.Exception
- ( ExceptionMonad
- )
-import GHC
- ( GhcLink(..)
- , Backend(..)
- , GhcMode(..)
- , DynFlags(..)
- , GeneralFlag(..)
- , LoadHowMuch(..)
- , ModLocation(..)
- , ModSummary(..)
- , getModuleGraph
- , getSession
- , getSessionDynFlags
- , guessTarget
- , load
- , noLoc
- , parseModule
- , runGhcT
- , setSessionDynFlags
- , setTargets
- , topSortModuleGraph
- , typecheckModule
- , moduleNameString
- , moduleName
- )
-import GHC.Paths (libdir)
-import GHC.Driver.Monad (GhcT(..), liftIO)
-import HaskellCodeExplorer.GhcUtils (isHsBoot,toText)
-import HaskellCodeExplorer.ModuleInfo
- ( ModuleDependencies
- , createModuleInfo
- )
-import qualified HaskellCodeExplorer.Types as HCE
-import GHC.Driver.Env (hsc_EPS, hsc_HPT, hsc_units)
-import GHC.Unit.Module.Graph (filterToposortToModules)
-import Prelude hiding (id)
-import System.Directory
- ( doesFileExist
- , findExecutable
- , setCurrentDirectory
- , getCurrentDirectory
- , makeAbsolute
- , getDirectoryContents
- , canonicalizePath
- )
-import qualified System.Directory.Tree as DT
-import System.Exit (exitFailure)
-import System.FilePath
- ( (</>)
- , addTrailingPathSeparator
- , joinPath
- , normalise
- , replaceExtension
- , splitPath
- , takeExtension
- , takeFileName
- , takeBaseName
- , takeDirectory
- , splitDirectories
- )
-import System.FilePath.Find (find,always,(==?),fileName)
-import System.Process (readProcess)
+import Control.DeepSeq ( deepseq )
+import Control.Exception ( IOException
+ , SomeAsyncException
+ , SomeException
+ , fromException
+ , throw
+ , try
+ )
+import Control.Monad ( foldM
+ , unless
+ , when
+ )
+import Control.Monad.Catch ( handle )
+import Control.Monad.Extra ( anyM
+ , findM
+ )
+import Control.Monad.Logger ( LoggingT(..)
+ , MonadLogger(..)
+ , MonadLoggerIO(..)
+ , logDebugN
+ , logErrorN
+ , logInfoN
+ , logWarnN
+ , runStdoutLoggingT
+ )
+import qualified Data.ByteString as BS
+import qualified Data.HashMap.Strict as HM
+import Data.IORef ( readIORef )
+import qualified Data.IntMap.Strict as IM
+import qualified Data.List as L
+import qualified Data.List.NonEmpty as NE
+import qualified Data.Map as Map
+import Data.Maybe ( fromMaybe
+ , isJust
+ , mapMaybe
+ , maybeToList
+ )
+import qualified Data.Set as S
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import Data.Version ( Version(..)
+ , makeVersion
+ , showVersion
+ )
+import Distribution.Helper ( ChComponentInfo(..)
+ , ChComponentName(..)
+ , ChEntrypoint(..)
+ , ChModuleName(..)
+ , DistDir(..)
+ , ProjLoc(..)
+ , SCabalProjType(..)
+ , UnitInfo(..)
+ , allUnits
+ , mkQueryEnv
+ , pPackageName
+ , pSourceDir
+ , pUnits
+ , projectPackages
+ , runQuery
+ , uComponentName
+ )
+import GHC ( Backend(..)
+ , DynFlags(..)
+ , GeneralFlag(..)
+ , GhcLink(..)
+ , GhcMode(..)
+ , LoadHowMuch(..)
+ , ModLocation(..)
+ , ModSummary(..)
+ , getModuleGraph
+ , getSession
+ , getSessionDynFlags
+ , guessTarget
+ , load
+ , moduleName
+ , moduleNameString
+ , noLoc
+ , parseModule
+ , runGhcT
+ , setSessionDynFlags
+ , setTargets
+ , topSortModuleGraph
+ , typecheckModule
+ )
+import GHC.Data.Graph.Directed ( flattenSCCs )
+import GHC.Driver.Env ( hsc_EPS
+ , hsc_HPT
+ , hsc_units
+ )
+import GHC.Driver.Monad ( GhcT(..)
+ , liftIO
+ )
+import GHC.Driver.Session ( gopt_set
+ , parseDynamicFlagsCmdLine
+ )
+import GHC.Paths ( libdir )
+import GHC.Unit.Module.Graph ( filterToposortToModules )
+import GHC.Utils.Exception ( ExceptionMonad )
+import HaskellCodeExplorer.GhcUtils ( isHsBoot
+ , toText
+ )
+import HaskellCodeExplorer.ModuleInfo ( ModuleDependencies
+ , createModuleInfo
+ )
+import qualified HaskellCodeExplorer.Types as HCE
+import Prelude hiding ( id )
+import System.Directory ( canonicalizePath
+ , doesFileExist
+ , findExecutable
+ , getCurrentDirectory
+ , getDirectoryContents
+ , makeAbsolute
+ , setCurrentDirectory
+ )
+import qualified System.Directory.Tree as DT
+import System.Exit ( exitFailure )
+import System.FilePath ( (</>)
+ , addTrailingPathSeparator
+ , joinPath
+ , normalise
+ , replaceExtension
+ , splitDirectories
+ , splitPath
+ , takeBaseName
+ , takeDirectory
+ , takeExtension
+ , takeFileName
+ )
+import System.FilePath.Find ( (==?)
+ , always
+ , fileName
+ , find
+ )
+import System.Process ( readProcess )
testCreatePkgInfo :: FilePath -> IO (HCE.PackageInfo HCE.ModuleInfo)
-testCreatePkgInfo pkgPath = runStdoutLoggingT $
- createPackageInfo pkgPath Nothing HCE.AfterPreprocessing [] []
+testCreatePkgInfo pkgPath = runStdoutLoggingT
+ $ createPackageInfo pkgPath Nothing HCE.AfterPreprocessing [] []
-createPackageInfo ::
- FilePath -- ^ Path to a Cabal package
+createPackageInfo
+ :: FilePath -- ^ Path to a Cabal package
-> Maybe FilePath -- ^ Relative path to a dist directory
-> HCE.SourceCodePreprocessing -- ^ Before or after preprocessor
-> [String] -- ^ Options for GHC
-> [String] -- ^ Directories to ignore
-> LoggingT IO (HCE.PackageInfo HCE.ModuleInfo)
-createPackageInfo packageDirectoryPath mbDistDirRelativePath sourceCodePreprocessing additionalGhcOptions ignoreDirectories = do
- packageDirectoryAbsPath <- liftIO $ makeAbsolute packageDirectoryPath
- currentDirectory <- liftIO getCurrentDirectory
- liftIO $ setCurrentDirectory packageDirectoryAbsPath
- distDir <-
- case mbDistDirRelativePath of
+createPackageInfo packageDirectoryPath mbDistDirRelativePath sourceCodePreprocessing additionalGhcOptions ignoreDirectories
+ = do
+ packageDirectoryAbsPath <- liftIO $ makeAbsolute packageDirectoryPath
+ currentDirectory <- liftIO getCurrentDirectory
+ liftIO $ setCurrentDirectory packageDirectoryAbsPath
+ distDir <- case mbDistDirRelativePath of
Just path -> return $ packageDirectoryAbsPath </> path
- Nothing -> return $ packageDirectoryAbsPath </> "dist-newstyle"
- cabalFiles <-
- liftIO $
- length .
- filter
- (\path -> takeFileName path /= ".cabal" && takeExtension path == ".cabal") <$>
- getDirectoryContents packageDirectoryAbsPath
- _ <-
- if cabalFiles == 0
+ Nothing -> return $ packageDirectoryAbsPath </> "dist-newstyle"
+ cabalFiles <-
+ liftIO
+ $ length
+ . filter
+ (\path ->
+ takeFileName path /= ".cabal" && takeExtension path == ".cabal"
+ )
+ <$> getDirectoryContents packageDirectoryAbsPath
+ _ <- if cabalFiles == 0
then do
- logErrorN $
- T.concat ["No .cabal file found in ", T.pack packageDirectoryAbsPath]
+ logErrorN $ T.concat
+ ["No .cabal file found in ", T.pack packageDirectoryAbsPath]
liftIO exitFailure
else when (cabalFiles >= 2) $ do
- logErrorN $
- T.concat
- [ "Found more than one .cabal file in "
- , T.pack packageDirectoryAbsPath
- ]
- liftIO exitFailure
- cabalHelperQueryEnv <- liftIO $
- mkQueryEnv
- (ProjLocV2Dir packageDirectoryAbsPath)
- (DistDirCabal SCV2 distDir)
- packages <- liftIO $ NE.toList <$> runQuery projectPackages cabalHelperQueryEnv
- logDebugN $ "packages: " <>
- (T.pack $ show $ zip3 (pPackageName <$> packages) (pSourceDir <$> packages) ((mapMaybe uComponentName . NE.toList . pUnits) <$> packages))
- mbPackage <- liftIO $
- findM
- (\pkg -> do
+ logErrorN
+ $ T.concat
+ [ "Found more than one .cabal file in "
+ , T.pack packageDirectoryAbsPath
+ ]
+ liftIO exitFailure
+ cabalHelperQueryEnv <- liftIO $ mkQueryEnv
+ (ProjLocV2Dir packageDirectoryAbsPath)
+ (DistDirCabal SCV2 distDir)
+ packages <-
+ liftIO $ NE.toList <$> runQuery projectPackages cabalHelperQueryEnv
+ logDebugN
+ $ "packages: "
+ <> (T.pack $ show $ zip3
+ (pPackageName <$> packages)
+ (pSourceDir <$> packages)
+ ((mapMaybe uComponentName . NE.toList . pUnits) <$> packages)
+ )
+ mbPackage <- liftIO $ findM
+ (\pkg -> do
dir1 <- (canonicalizePath . pSourceDir) pkg
dir2 <- canonicalizePath packageDirectoryAbsPath
- return $ dir1 == dir2)
- packages
- package <-
- case mbPackage of
+ return $ dir1 == dir2
+ )
+ packages
+ package <- case mbPackage of
Just package' -> return package'
- Nothing -> do
- logWarnN $
- "Cannot find a package with sourceDir in the same directory ("
+ Nothing -> do
+ logWarnN
+ $ "Cannot find a package with sourceDir in the same directory ("
<> T.pack (packageDirectoryAbsPath </> "")
<> "), indexing the first package by default."
<> "Alternatively, try using absolute path for -p."
return $ head packages
-
- units <-
- liftIO $
- (filter (\((pkgName, _), _, _) -> pkgName == pPackageName package)) . NE.toList <$>
- runQuery
- (allUnits
- (\unit ->
- (uiPackageId unit, uiCompilerId unit,
- map (\comp -> ((ciGhcOptions comp, ciComponentName comp),
- (ciEntrypoints comp, ciComponentName comp),
- (ciSourceDirs comp, ciComponentName comp))) $
- (Map.elems . uiComponents) unit)))
- cabalHelperQueryEnv
- -- TODO: we are assuming all pakcageVersion and packageCompilerVersion are the same
- let ((packageName, packageVersion), (_, packageCompilerVersion), _) = head units
- compInfo = concatMap (\(_, _, comp) -> comp) units
- currentPackageId = HCE.PackageId (T.pack packageName) packageVersion
- logDebugN $ "compinfo: " <> (T.pack $ show compInfo)
- unless
- (take 3 (versionBranch packageCompilerVersion) ==
- take 3 (versionBranch ghcVersion)) $ do
- logErrorN $
- T.concat
- [ "GHC version mismatch. haskell-code-indexer: "
- , T.pack $ showVersion ghcVersion
- , ", package: "
- , T.pack $ showVersion packageCompilerVersion
- ]
- liftIO exitFailure
- logInfoN $ T.append "Indexing " $ HCE.packageIdToText currentPackageId
- let buildComponents =
- L.map
- (\((options, compName), (entrypoint, _), (srcDirs, _)) ->
- ( chComponentNameToComponentId compName
- , options
- , chEntrypointsToModules entrypoint
- , srcDirs
- , chComponentNameToComponentType compName)) .
- L.sortBy
- (\((_, compName1), _, _) ((_, compName2), _, _) ->
- compare compName1 compName2) $
- compInfo
- libSrcDirs =
- concatMap (\(_, _, _, srcDirs, _) -> srcDirs) .
- filter (\(_, _, _, _, compType) -> HCE.isLibrary compType) $
+
+ units <-
+ liftIO
+ $ (filter (\((pkgName, _), _, _) -> pkgName == pPackageName package))
+ . NE.toList
+ <$> runQuery
+ (allUnits
+ (\unit ->
+ ( uiPackageId unit
+ , uiCompilerId unit
+ , map
+ (\comp ->
+ ( (ciGhcOptions comp , ciComponentName comp)
+ , (ciEntrypoints comp, ciComponentName comp)
+ , (ciSourceDirs comp , ciComponentName comp)
+ )
+ )
+ $ (Map.elems . uiComponents) unit
+ )
+ )
+ )
+ cabalHelperQueryEnv
+ -- TODO: we are assuming all pakcageVersion and packageCompilerVersion are the same
+ let ((packageName, packageVersion), (_, packageCompilerVersion), _) =
+ head units
+ compInfo = concatMap (\(_, _, comp) -> comp) units
+ currentPackageId = HCE.PackageId (T.pack packageName) packageVersion
+ logDebugN $ "compinfo: " <> (T.pack $ show compInfo)
+ unless
+ ( take 3 (versionBranch packageCompilerVersion)
+ == take 3 (versionBranch ghcVersion)
+ )
+ $ do
+ logErrorN $ T.concat
+ [ "GHC version mismatch. haskell-code-indexer: "
+ , T.pack $ showVersion ghcVersion
+ , ", package: "
+ , T.pack $ showVersion packageCompilerVersion
+ ]
+ liftIO exitFailure
+ logInfoN $ T.append "Indexing " $ HCE.packageIdToText currentPackageId
+ let buildComponents =
+ L.map
+ (\((options, compName), (entrypoint, _), (srcDirs, _)) ->
+ ( chComponentNameToComponentId compName
+ , options
+ , chEntrypointsToModules entrypoint
+ , srcDirs
+ , chComponentNameToComponentType compName
+ )
+ )
+ . L.sortBy
+ (\((_, compName1), _, _) ((_, compName2), _, _) ->
+ compare compName1 compName2
+ )
+ $ compInfo
+ libSrcDirs =
+ concatMap (\(_, _, _, srcDirs, _) -> srcDirs)
+ . filter (\(_, _, _, _, compType) -> HCE.isLibrary compType)
+ $ buildComponents
+ (indexedModules, (_fileMapResult, _defSiteMapResult, modNameMapResult)) <-
+ foldM
+ (\(modules, (fileMap, defSiteMap, modNameMap)) (compId, options, (mbMain, moduleNames), srcDirs, _) ->
+ do
+ mbMainPath <- case mbMain of
+ Just mainPath ->
+ liftIO
+ $ findM doesFileExist
+ $ mainPath
+ : map (\srcDir -> normalise $ srcDir </> mainPath) srcDirs
+ Nothing -> return Nothing
+ (modules', (fileMap', defSiteMap', modNameMap')) <-
+ indexBuildComponent
+ sourceCodePreprocessing
+ currentPackageId
+ compId
+ (fileMap, defSiteMap, modNameMap)
+ srcDirs
+ libSrcDirs
+ (options ++ additionalGhcOptions)
+ (maybe moduleNames (: moduleNames) mbMainPath)
+ return (modules ++ modules', (fileMap', defSiteMap', modNameMap'))
+ )
+ ([], (HM.empty, HM.empty, HM.empty))
buildComponents
- (indexedModules, (_fileMapResult, _defSiteMapResult, modNameMapResult)) <-
- foldM
- (\(modules, (fileMap, defSiteMap, modNameMap)) (compId, options, (mbMain, moduleNames), srcDirs, _) -> do
- mbMainPath <-
- case mbMain of
- Just mainPath ->
- liftIO $
- findM doesFileExist $
- mainPath :
- map (\srcDir -> normalise $ srcDir </> mainPath) srcDirs
- Nothing -> return Nothing
- (modules', (fileMap', defSiteMap', modNameMap')) <-
- indexBuildComponent
- sourceCodePreprocessing
- currentPackageId
- compId
- (fileMap, defSiteMap, modNameMap)
- srcDirs
- libSrcDirs
- (options ++ additionalGhcOptions)
- (maybe moduleNames (: moduleNames) mbMainPath)
- return (modules ++ modules', (fileMap', defSiteMap', modNameMap')))
- ([], (HM.empty, HM.empty, HM.empty))
- buildComponents
- let modId = HCE.id :: HCE.ModuleInfo -> HCE.HaskellModulePath
- moduleMap =
- HM.fromList . map (\modInfo -> (modId modInfo, modInfo)) $
- indexedModules
- references = L.foldl' addReferencesFromModule HM.empty indexedModules
- moduleId = HCE.id :: HCE.ModuleInfo -> HCE.HaskellModulePath
- topLevelIdentifiersTrie =
- L.foldl' addTopLevelIdentifiersFromModule HCE.emptyTrie .
- L.filter (not . isHsBoot . moduleId) $
- indexedModules
- directoryTree <-
- liftIO $
- buildDirectoryTree
+ let modId = HCE.id :: HCE.ModuleInfo -> HCE.HaskellModulePath
+ moduleMap =
+ HM.fromList
+ . map (\modInfo -> (modId modInfo, modInfo))
+ $ indexedModules
+ references = L.foldl' addReferencesFromModule HM.empty indexedModules
+ moduleId = HCE.id :: HCE.ModuleInfo -> HCE.HaskellModulePath
+ topLevelIdentifiersTrie =
+ L.foldl' addTopLevelIdentifiersFromModule HCE.emptyTrie
+ . L.filter (not . isHsBoot . moduleId)
+ $ indexedModules
+ directoryTree <- liftIO $ buildDirectoryTree
packageDirectoryAbsPath
ignoreDirectories
(\path -> HM.member (HCE.HaskellModulePath . T.pack $ path) moduleMap)
- liftIO $ setCurrentDirectory currentDirectory
- return
- HCE.PackageInfo
- { id = currentPackageId
- , moduleMap = moduleMap
- , moduleNameMap = modNameMapResult
- , directoryTree = directoryTree
- , externalIdOccMap = references
- , externalIdInfoMap = topLevelIdentifiersTrie
- }
- where
- chEntrypointsToModules :: ChEntrypoint -> (Maybe String, [String])
- chEntrypointsToModules (ChLibEntrypoint modules otherModules signatures) =
- ( Nothing
- , L.map chModuleToString modules ++
- L.map chModuleToString otherModules ++ L.map chModuleToString signatures)
- chEntrypointsToModules (ChExeEntrypoint mainModule _otherModules) =
- (Just mainModule, [])
- chEntrypointsToModules (ChSetupEntrypoint _) = (Nothing, [])
- chModuleToString :: ChModuleName -> String
- chModuleToString (ChModuleName n) = n
- chComponentNameToComponentType :: ChComponentName -> HCE.ComponentType
- chComponentNameToComponentType ChSetupHsName = HCE.Setup
- chComponentNameToComponentType (ChLibName _) = HCE.Lib
- chComponentNameToComponentType (ChFLibName name) = HCE.FLib $ T.pack name
- chComponentNameToComponentType (ChExeName name) = HCE.Exe $ T.pack name
- chComponentNameToComponentType (ChTestName name) = HCE.Test $ T.pack name
- chComponentNameToComponentType (ChBenchName name) = HCE.Bench $ T.pack name
- chComponentNameToComponentId :: ChComponentName -> HCE.ComponentId
- chComponentNameToComponentId (ChLibName _) = HCE.ComponentId "lib"
- chComponentNameToComponentId (ChFLibName name) =
- HCE.ComponentId . T.append "flib-" . T.pack $ name
- chComponentNameToComponentId (ChExeName name) =
- HCE.ComponentId . T.append "exe-" . T.pack $ name
- chComponentNameToComponentId (ChTestName name) =
- HCE.ComponentId . T.append "test-" . T.pack $ name
- chComponentNameToComponentId (ChBenchName name) =
- HCE.ComponentId . T.append "bench-" . T.pack $ name
- chComponentNameToComponentId ChSetupHsName = HCE.ComponentId "setup"
+ liftIO $ setCurrentDirectory currentDirectory
+ return HCE.PackageInfo { id = currentPackageId
+ , moduleMap = moduleMap
+ , moduleNameMap = modNameMapResult
+ , directoryTree = directoryTree
+ , externalIdOccMap = references
+ , externalIdInfoMap = topLevelIdentifiersTrie
+ }
+ where
+ chEntrypointsToModules :: ChEntrypoint -> (Maybe String, [String])
+ chEntrypointsToModules (ChLibEntrypoint modules otherModules signatures) =
+ ( Nothing
+ , L.map chModuleToString modules
+ ++ L.map chModuleToString otherModules
+ ++ L.map chModuleToString signatures
+ )
+ chEntrypointsToModules (ChExeEntrypoint mainModule _otherModules) =
+ (Just mainModule, [])
+ chEntrypointsToModules (ChSetupEntrypoint _) = (Nothing, [])
+ chModuleToString :: ChModuleName -> String
+ chModuleToString (ChModuleName n) = n
+ chComponentNameToComponentType :: ChComponentName -> HCE.ComponentType
+ chComponentNameToComponentType ChSetupHsName = HCE.Setup
+ chComponentNameToComponentType (ChLibName _ ) = HCE.Lib
+ chComponentNameToComponentType (ChFLibName name) = HCE.FLib $ T.pack name
+ chComponentNameToComponentType (ChExeName name) = HCE.Exe $ T.pack name
+ chComponentNameToComponentType (ChTestName name) = HCE.Test $ T.pack name
+ chComponentNameToComponentType (ChBenchName name) = HCE.Bench $ T.pack name
+ chComponentNameToComponentId :: ChComponentName -> HCE.ComponentId
+ chComponentNameToComponentId (ChLibName _) = HCE.ComponentId "lib"
+ chComponentNameToComponentId (ChFLibName name) =
+ HCE.ComponentId . T.append "flib-" . T.pack $ name
+ chComponentNameToComponentId (ChExeName name) =
+ HCE.ComponentId . T.append "exe-" . T.pack $ name
+ chComponentNameToComponentId (ChTestName name) =
+ HCE.ComponentId . T.append "test-" . T.pack $ name
+ chComponentNameToComponentId (ChBenchName name) =
+ HCE.ComponentId . T.append "bench-" . T.pack $ name
+ chComponentNameToComponentId ChSetupHsName = HCE.ComponentId "setup"
ghcVersion :: Version
ghcVersion = makeVersion [9, 2, 2, 0]
-buildDirectoryTree :: FilePath -> [FilePath] -> (FilePath -> Bool) -> IO HCE.DirTree
+buildDirectoryTree
+ :: FilePath -> [FilePath] -> (FilePath -> Bool) -> IO HCE.DirTree
buildDirectoryTree path ignoreDirectories isHaskellModule = do
(_dir DT.:/ tree) <- DT.readDirectoryWith (const . return $ ()) path
-- Tuple up the complete file path with the file contents, by building up the path,
-- trie-style, from the root. The filepath will be relative to "anchored" directory.
let treeWithPaths = DT.zipPaths ("" DT.:/ DT.filterDir (not . ignore) tree)
return $ toDirTree (removeTopDir . fst <$> treeWithPaths)
- where
- ignore :: DT.DirTree a -> Bool
- ignore (DT.Dir dirName _)
- | "." `L.isPrefixOf` dirName = True
- | dirName == "dist" = True
- | dirName == "dist-newstyle" = True
- | dirName == "tmp" = True
- | otherwise = dirName `elem` ignoreDirectories
- ignore (DT.Failed _ _) = True
- ignore _ = False
- removeTopDir :: FilePath -> FilePath
- removeTopDir p =
- case splitPath p of
- _x:xs -> joinPath xs
- [] -> ""
- toDirTree :: DT.DirTree FilePath -> HCE.DirTree
- toDirTree (DT.Dir name contents) =
- HCE.Dir name (map toDirTree . filter (not . DT.failed) $ contents)
- toDirTree (DT.File name filePath) =
- HCE.File name filePath (isHaskellModule filePath)
- toDirTree (DT.Failed name err) =
- HCE.File (name ++ " : " ++ show err) "" False
+ where
+ ignore :: DT.DirTree a -> Bool
+ ignore (DT.Dir dirName _) | "." `L.isPrefixOf` dirName = True
+ | dirName == "dist" = True
+ | dirName == "dist-newstyle" = True
+ | dirName == "tmp" = True
+ | otherwise = dirName `elem` ignoreDirectories
+ ignore (DT.Failed _ _) = True
+ ignore _ = False
+ removeTopDir :: FilePath -> FilePath
+ removeTopDir p = case splitPath p of
+ _x : xs -> joinPath xs
+ [] -> ""
+ toDirTree :: DT.DirTree FilePath -> HCE.DirTree
+ toDirTree (DT.Dir name contents) =
+ HCE.Dir name (map toDirTree . filter (not . DT.failed) $ contents)
+ toDirTree (DT.File name filePath) =
+ HCE.File name filePath (isHaskellModule filePath)
+ toDirTree (DT.Failed name err) =
+ HCE.File (name ++ " : " ++ show err) "" False
-addTopLevelIdentifiersFromModule ::
- HCE.Trie Char HCE.ExternalIdentifierInfo
+addTopLevelIdentifiersFromModule
+ :: HCE.Trie Char HCE.ExternalIdentifierInfo
-> HCE.ModuleInfo
-> HCE.Trie Char HCE.ExternalIdentifierInfo
-addTopLevelIdentifiersFromModule trieIdInfo HCE.ModuleInfo {..} =
- L.foldl'
- (\trie idInfo@(HCE.ExternalIdentifierInfo HCE.IdentifierInfo {..}) ->
- HCE.insertToTrie S.insert (T.unpack demangledOccName) idInfo trie)
- trieIdInfo
- externalIds
+addTopLevelIdentifiersFromModule trieIdInfo HCE.ModuleInfo {..} = L.foldl'
+ (\trie idInfo@(HCE.ExternalIdentifierInfo HCE.IdentifierInfo {..}) ->
+ HCE.insertToTrie S.insert (T.unpack demangledOccName) idInfo trie
+ )
+ trieIdInfo
+ externalIds
-addReferencesFromModule ::
- HM.HashMap HCE.ExternalId (S.Set HCE.IdentifierSrcSpan)
+addReferencesFromModule
+ :: HM.HashMap HCE.ExternalId (S.Set HCE.IdentifierSrcSpan)
-> HCE.ModuleInfo
-> HM.HashMap HCE.ExternalId (S.Set HCE.IdentifierSrcSpan)
addReferencesFromModule references modInfo@HCE.ModuleInfo {..} =
@@ -384,40 +407,36 @@ addReferencesFromModule references modInfo@HCE.ModuleInfo {..} =
references
modInfo
(\occMap lineNumber startCol endCol occ ->
- let mbIdExternalId =
- HCE.externalId =<<
- maybe
- Nothing
- (`HM.lookup` idInfoMap)
- (HCE.internalId (occ :: HCE.IdentifierOccurrence))
- idSrcSpan =
- HCE.IdentifierSrcSpan
- { modulePath = id
- , line = lineNumber
- , startColumn = startCol
- , endColumn = endCol
- }
- in case mbIdExternalId of
- Just externalId ->
- HM.insertWith S.union externalId (S.singleton idSrcSpan) occMap
- Nothing -> occMap)
+ let mbIdExternalId = HCE.externalId =<< maybe
+ Nothing
+ (`HM.lookup` idInfoMap)
+ (HCE.internalId (occ :: HCE.IdentifierOccurrence))
+ idSrcSpan = HCE.IdentifierSrcSpan { modulePath = id
+ , line = lineNumber
+ , startColumn = startCol
+ , endColumn = endCol
+ }
+ in case mbIdExternalId of
+ Just externalId ->
+ HM.insertWith S.union externalId (S.singleton idSrcSpan) occMap
+ Nothing -> occMap
+ )
-eachIdentifierOccurrence ::
- forall a.
- a
+eachIdentifierOccurrence
+ :: forall a
+ . a
-> HCE.ModuleInfo
-> (a -> IM.Key -> Int -> Int -> HCE.IdentifierOccurrence -> a)
-> a
-eachIdentifierOccurrence accumulator HCE.ModuleInfo {..} f =
- IM.foldlWithKey'
- (\acc lineNumber occurences ->
- L.foldl'
- (\a ((startCol, endCol), occ) -> f a lineNumber startCol endCol occ)
- acc
- occurences)
- accumulator
- idOccMap
+eachIdentifierOccurrence accumulator HCE.ModuleInfo {..} f = IM.foldlWithKey'
+ (\acc lineNumber occurences -> L.foldl'
+ (\a ((startCol, endCol), occ) -> f a lineNumber startCol endCol occ)
+ acc
+ occurences
+ )
+ accumulator
+ idOccMap
instance MonadLoggerIO (GhcT (LoggingT IO)) where
askLoggerIO = GhcT $ const askLoggerIO
@@ -430,15 +449,14 @@ gtrySync :: (ExceptionMonad m) => m a -> m (Either SomeException a)
gtrySync action = ghandleSync (return . Left) (fmap Right action)
ghandleSync :: (ExceptionMonad m) => (SomeException -> m a) -> m a -> m a
-ghandleSync onError =
- handle
- (\ex ->
- case fromException ex of
- Just (asyncEx :: SomeAsyncException) -> throw asyncEx
- _ -> onError ex)
+ghandleSync onError = handle
+ (\ex -> case fromException ex of
+ Just (asyncEx :: SomeAsyncException) -> throw asyncEx
+ _ -> onError ex
+ )
-indexBuildComponent ::
- HCE.SourceCodePreprocessing -- ^ Before or after preprocessor
+indexBuildComponent
+ :: HCE.SourceCodePreprocessing -- ^ Before or after preprocessor
-> HCE.PackageId -- ^ Current package id
-> HCE.ComponentId -- ^ Current component id
-> ModuleDependencies -- ^ Already indexed modules
@@ -446,133 +464,125 @@ indexBuildComponent ::
-> [FilePath] -- ^ Src dirs of libraries
-> [String] -- ^ Command-line options for GHC
-> [String] -- ^ Modules to compile
- -> LoggingT IO ([HCE.ModuleInfo],ModuleDependencies)
-indexBuildComponent sourceCodePreprocessing currentPackageId componentId deps@(fileMap, defSiteMap, modNameMap) srcDirs libSrcDirs options modules = do
- let onError ex = do
- logErrorN $
- T.concat
+ -> LoggingT IO ([HCE.ModuleInfo], ModuleDependencies)
+indexBuildComponent sourceCodePreprocessing currentPackageId componentId deps@(fileMap, defSiteMap, modNameMap) srcDirs libSrcDirs options modules
+ = do
+ let onError ex = do
+ logErrorN $ T.concat
[ "Error while indexing component "
, HCE.getComponentId componentId
, " : "
, T.pack . show $ ex
]
- return ([], deps)
- ghandleSync onError $
- runGhcT (Just libdir) $ do
+ return ([], deps)
+ ghandleSync onError $ runGhcT (Just libdir) $ do
logDebugN (T.append "Component id : " $ HCE.getComponentId componentId)
logDebugN (T.append "Modules : " $ T.pack $ show modules)
logDebugN
- (T.append "GHC command line options : " $
- T.pack $ L.unwords (options ++ modules))
- flags <- getSessionDynFlags
- (flags', _, _) <-
- parseDynamicFlagsCmdLine
- flags
- (L.map noLoc . L.filter ("-Werror" /=) $ options) -- -Werror flag makes warnings fatal
- let mbTmpDir =
- case hiDir flags' of
- Just buildDir ->
- Just $ buildDir </> (takeBaseName buildDir ++ "-tmp")
- Nothing -> Nothing
+ (T.append "GHC command line options : " $ T.pack $ L.unwords
+ (options ++ modules)
+ )
+ flags <- getSessionDynFlags
+ (flags', _, _) <- parseDynamicFlagsCmdLine
+ flags
+ (L.map noLoc . L.filter ("-Werror" /=) $ options) -- -Werror flag makes warnings fatal
+ let mbTmpDir = case hiDir flags' of
+ Just buildDir ->
+ Just $ buildDir </> (takeBaseName buildDir ++ "-tmp")
+ Nothing -> Nothing
_ <-
-- initUnits happens here
- setSessionDynFlags $
- L.foldl'
- gopt_set
- (flags'
- { backend = NCG
- , ghcLink = LinkInMemory
- , ghcMode = CompManager
- , importPaths = importPaths flags' ++ maybeToList mbTmpDir
- })
- [Opt_Haddock]
+ setSessionDynFlags $ L.foldl'
+ gopt_set
+ (flags' { backend = NCG
+ , ghcLink = LinkInMemory
+ , ghcMode = CompManager
+ , importPaths = importPaths flags' ++ maybeToList mbTmpDir
+ }
+ )
+ [Opt_Haddock]
targets <- mapM (`guessTarget` Nothing) modules
setTargets targets
- _ <- load LoadAllTargets
+ _ <- load LoadAllTargets
modGraph <- getModuleGraph
- let topSortMods =
- flattenSCCs $
- filterToposortToModules (topSortModuleGraph False modGraph Nothing)
+ let topSortMods = flattenSCCs $ filterToposortToModules
+ (topSortModuleGraph False modGraph Nothing)
buildDir =
- addTrailingPathSeparator . normalise . fromMaybe "" . hiDir $
- flags'
- pathsModuleName =
- "Paths_" ++
- map
- (\c ->
- if c == '-'
- then '_'
- else c)
- (T.unpack (HCE.name (currentPackageId :: HCE.PackageId)))
+ addTrailingPathSeparator . normalise . fromMaybe "" . hiDir $ flags'
+ pathsModuleName = "Paths_" ++ map
+ (\c -> if c == '-' then '_' else c)
+ (T.unpack (HCE.name (currentPackageId :: HCE.PackageId)))
(modSumWithPath, modulesNotFound) <-
(\(mods, notFound) ->
- ( L.reverse .
- L.foldl'
- (\acc (mbPath, modSum) ->
- case mbPath of
- Just path
- | not $ HM.member path defSiteMap -> (path, modSum) : acc
- _ -> acc)
- [] $
- mods
- , map snd notFound)) .
- L.partition (\(mbPath, _) -> isJust mbPath) <$>
- mapM
- (\modSum ->
- liftIO $
- (, modSum) <$>
- findHaskellModulePath buildDir (srcDirs ++ libSrcDirs) modSum)
- (filter
- (\modSum ->
- pathsModuleName /=
- (moduleNameString . moduleName $ ms_mod modSum))
- topSortMods)
- unless (null modulesNotFound) $
- logErrorN $
- T.append
- "Cannot find module path : "
- (toText flags' $ map ms_mod modulesNotFound)
+ ( L.reverse
+ . L.foldl'
+ (\acc (mbPath, modSum) -> case mbPath of
+ Just path | not $ HM.member path defSiteMap ->
+ (path, modSum) : acc
+ _ -> acc
+ )
+ []
+ $ mods
+ , map snd notFound
+ )
+ )
+ . L.partition (\(mbPath, _) -> isJust mbPath)
+ <$> mapM
+ (\modSum ->
+ liftIO
+ $ (, modSum)
+ <$> findHaskellModulePath buildDir
+ (srcDirs ++ libSrcDirs)
+ modSum
+ )
+ (filter
+ (\modSum ->
+ pathsModuleName
+ /= (moduleNameString . moduleName $ ms_mod modSum)
+ )
+ topSortMods
+ )
+ unless (null modulesNotFound) $ logErrorN $ T.append
+ "Cannot find module path : "
+ (toText flags' $ map ms_mod modulesNotFound)
foldM
- (\(indexedModules, (fileMap', defSiteMap', modNameMap')) (modulePath, modSum) -> do
- result <-
- indexModule
- sourceCodePreprocessing
- componentId
- currentPackageId
- flags'
- (fileMap', defSiteMap', modNameMap')
- (modulePath, modSum)
- case result of
- Right (modInfo, (fileMap'', defSiteMap'', modNameMap'')) ->
- return
- ( modInfo : indexedModules
- , (fileMap'', defSiteMap'', modNameMap''))
- Left exception -> do
- logErrorN $
- T.concat
- [ "Error while indexing "
- , T.pack . show $ modulePath
- , " : "
- , T.pack . show $ exception
- ]
- return (indexedModules, (fileMap', defSiteMap', modNameMap')))
+ (\(indexedModules, (fileMap', defSiteMap', modNameMap')) (modulePath, modSum) ->
+ do
+ result <- indexModule sourceCodePreprocessing
+ componentId
+ currentPackageId
+ flags'
+ (fileMap', defSiteMap', modNameMap')
+ (modulePath, modSum)
+ case result of
+ Right (modInfo, (fileMap'', defSiteMap'', modNameMap'')) ->
+ return
+ ( modInfo : indexedModules
+ , (fileMap'', defSiteMap'', modNameMap'')
+ )
+ Left exception -> do
+ logErrorN $ T.concat
+ [ "Error while indexing "
+ , T.pack . show $ modulePath
+ , " : "
+ , T.pack . show $ exception
+ ]
+ return (indexedModules, (fileMap', defSiteMap', modNameMap'))
+ )
([], (fileMap, defSiteMap, modNameMap))
modSumWithPath
-findHaskellModulePath ::
- FilePath -> [FilePath] -> ModSummary -> IO (Maybe HCE.HaskellModulePath)
+findHaskellModulePath
+ :: FilePath -> [FilePath] -> ModSummary -> IO (Maybe HCE.HaskellModulePath)
findHaskellModulePath buildDir srcDirs modSum =
case normalise <$> (ml_hs_file . ms_location $ modSum) of
Just modulePath ->
let toHaskellModulePath = return . Just . HCE.HaskellModulePath . T.pack
- removeTmpDir path =
- case splitDirectories path of
- parent:rest ->
- if "-tmp" `L.isSuffixOf` parent
- then joinPath rest
- else path
- _ -> path
- in case removeTmpDir <$> L.stripPrefix buildDir modulePath of
+ removeTmpDir path = case splitDirectories path of
+ parent : rest ->
+ if "-tmp" `L.isSuffixOf` parent then joinPath rest else path
+ _ -> path
+ in case removeTmpDir <$> L.stripPrefix buildDir modulePath of
-- File is in the build directory
Just path
| takeExtension path == ".hs-boot" -> do
@@ -580,43 +590,45 @@ findHaskellModulePath buildDir srcDirs modSum =
mbFoundPath <- findM doesFileExist possiblePaths
case mbFoundPath of
Just p -> toHaskellModulePath p
- _ -> return Nothing
+ _ -> return Nothing
| takeExtension path == ".hs" -> do
- let paths =
- map
- (replaceExtension path)
- HCE.haskellPreprocessorExtensions
- possiblePaths =
- paths ++
- concatMap (\srcDir -> map (srcDir </>) paths) srcDirs
+ let
+ paths = map (replaceExtension path)
+ HCE.haskellPreprocessorExtensions
+ possiblePaths =
+ paths
+ ++ concatMap (\srcDir -> map (srcDir </>) paths) srcDirs
mbFoundPath <- findM doesFileExist possiblePaths
case mbFoundPath of
Just p -> toHaskellModulePath p
- _ -> return Nothing
+ _ -> return Nothing
| otherwise -> return Nothing
Nothing -> toHaskellModulePath modulePath
Nothing -> return Nothing
-indexModule ::
- HCE.SourceCodePreprocessing
+indexModule
+ :: HCE.SourceCodePreprocessing
-> HCE.ComponentId
-> HCE.PackageId
-> DynFlags
-> ModuleDependencies
-> (HCE.HaskellModulePath, ModSummary)
- -> GhcT (LoggingT IO) (Either SomeException ( HCE.ModuleInfo
- , ModuleDependencies))
-indexModule sourceCodePreprocessing componentId currentPackageId flags deps (modulePath, modSum) =
- gtrySync $ do
+ -> GhcT
+ (LoggingT IO)
+ ( Either
+ SomeException
+ (HCE.ModuleInfo, ModuleDependencies)
+ )
+indexModule sourceCodePreprocessing componentId currentPackageId flags deps (modulePath, modSum)
+ = gtrySync $ do
logDebugN (T.append "Indexing " $ HCE.getHaskellModulePath modulePath)
- parsedModule <- parseModule modSum
- typecheckedModule <- typecheckModule parsedModule
- hscEnv <- getSession
+ parsedModule <- parseModule modSum
+ typecheckedModule <- typecheckModule parsedModule
+ hscEnv <- getSession
externalPackageState <- liftIO . readIORef . hsc_EPS $ hscEnv
- originalSourceCode <-
- liftIO $
- T.replace "\t" " " . TE.decodeUtf8 <$>
- BS.readFile (T.unpack . HCE.getHaskellModulePath $ modulePath)
+ originalSourceCode <-
+ liftIO $ T.replace "\t" " " . TE.decodeUtf8 <$> BS.readFile
+ (T.unpack . HCE.getHaskellModulePath $ modulePath)
let (modInfo, (fileMap', exportMap', moduleNameMap'), typeErrors) =
createModuleInfo
deps
@@ -625,11 +637,15 @@ indexModule sourceCodePreprocessing componentId currentPackageId flags deps (mod
, typecheckedModule
, hsc_HPT hscEnv
, externalPackageState
- , modSum)
+ , modSum
+ )
modulePath
currentPackageId
componentId
(originalSourceCode, sourceCodePreprocessing)
- unless (null typeErrors) $
- logInfoN $ T.append "Type errors : " $ T.pack $ show typeErrors
+ unless (null typeErrors)
+ $ logInfoN
+ $ T.append "Type errors : "
+ $ T.pack
+ $ show typeErrors
deepseq modInfo $ return (modInfo, (fileMap', exportMap', moduleNameMap'))
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-17 19:01:21 +0000