aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--haskell-code-explorer.cabal1
-rw-r--r--src/HaskellCodeExplorer/PackageInfo.hs150
2 files changed, 77 insertions, 74 deletions
diff --git a/haskell-code-explorer.cabal b/haskell-code-explorer.cabal
index 06cb5c8..a0dddda 100644
--- a/haskell-code-explorer.cabal
+++ b/haskell-code-explorer.cabal
@@ -34,6 +34,7 @@ library
, containers
, directory
, directory-tree
+ , exceptions
, filemanip
, filepath
, ghc
diff --git a/src/HaskellCodeExplorer/PackageInfo.hs b/src/HaskellCodeExplorer/PackageInfo.hs
index 466b518..0800382 100644
--- a/src/HaskellCodeExplorer/PackageInfo.hs
+++ b/src/HaskellCodeExplorer/PackageInfo.hs
@@ -12,7 +12,7 @@ module HaskellCodeExplorer.PackageInfo
( createPackageInfo
, ghcVersion
) where
-
+import qualified Data.List.NonEmpty as NE
import Control.DeepSeq(deepseq)
import Control.Exception
( IOException
@@ -22,6 +22,7 @@ import Control.Exception
, throw
, try
)
+import qualified Data.Map as Map
import Control.Monad (foldM, unless, when)
import Control.Monad.Extra (anyM, findM)
import Control.Monad.Logger
@@ -42,37 +43,39 @@ 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 Digraph (flattenSCCs)
+import GHC.Data.Graph.Directed (flattenSCCs)
import Distribution.Helper
( ChComponentName(..)
, ChEntrypoint(..)
, ChModuleName(..)
- , components
- , entrypoints
- , ghcOptions
+ , ProjLoc(..)
+ , DistDir(..)
+ , SCabalProjType(..)
+ , allUnits
+ , UnitInfo(..)
+ , ChComponentInfo(..)
, mkQueryEnv
- , packageId
, runQuery
- , sourceDirs
- , compilerVersion
)
-import DynFlags
- ( DynFlags(..)
- , GeneralFlag(..)
- , GhcMode(..)
- , WarnReason(..)
- , gopt_set
+import GHC.Driver.Session
+ ( gopt_set
, parseDynamicFlagsCmdLine
)
-import Exception (ExceptionMonad(..), ghandle)
+import Control.Monad.Catch
+ ( handle
+ )
+import GHC.Utils.Exception
+ ( ExceptionMonad
+ )
import GHC
( GhcLink(..)
- , HscTarget(..)
+ , Backend(..)
+ , GhcMode(..)
+ , DynFlags(..)
+ , GeneralFlag(..)
, LoadHowMuch(..)
, ModLocation(..)
, ModSummary(..)
- , Severity
- , SrcSpan
, getModuleGraph
, getSession
, getSessionDynFlags
@@ -89,13 +92,15 @@ import GHC
, moduleName
)
import GHC.Paths (libdir)
-import GhcMonad (GhcT(..), liftIO)
+import GHC.Driver.Monad (GhcT(..), liftIO)
import HaskellCodeExplorer.GhcUtils (isHsBoot,toText)
-import HaskellCodeExplorer.ModuleInfo (ModuleDependencies, createModuleInfo)
+import HaskellCodeExplorer.ModuleInfo
+ ( ModuleDependencies
+ , createModuleInfo
+ )
import qualified HaskellCodeExplorer.Types as HCE
-import HscTypes (hsc_EPS, hsc_HPT)
-import Outputable (PprStyle, SDoc, neverQualify, showSDocForUser)
-import Packages (initPackages)
+import GHC.Driver.Env (hsc_EPS, hsc_HPT, hsc_units)
+import GHC.Unit.Module.Graph (filterToposortToModules)
import Prelude hiding (id)
import System.Directory
( doesFileExist
@@ -162,15 +167,25 @@ createPackageInfo packageDirectoryPath mbDistDirRelativePath sourceCodePreproces
, T.pack packageDirectoryAbsPath
]
liftIO exitFailure
- let cabalHelperQueryEnv = mkQueryEnv packageDirectoryAbsPath distDir
+ cabalHelperQueryEnv <- liftIO $
+ mkQueryEnv
+ (ProjLocV2Dir packageDirectoryAbsPath)
+ (DistDirCabal SCV2 distDir)
((packageName, packageVersion), (_packageCompilerName, packageCompilerVersion), compInfo) <-
- liftIO $
+ liftIO $ NE.head <$>
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
- ((,,) <$> packageId <*> compilerVersion <*>
- (zip3 <$> components ((,) <$> ghcOptions) <*>
- components ((,) <$> entrypoints) <*>
- components ((,) <$> sourceDirs)))
+ -- ((,,) <$> packageId <*> compilerVersion <*>
+ -- (zip3 <$> components ((,) <$> ghcOptions) <*>
+ -- components ((,) <$> entrypoints) <*>
+ -- components ((,) <$> sourceDirs)))
let currentPackageId = HCE.PackageId (T.pack packageName) packageVersion
unless
(take 3 (versionBranch packageCompilerVersion) ==
@@ -258,22 +273,22 @@ createPackageInfo packageDirectoryPath mbDistDirRelativePath sourceCodePreproces
L.map chModuleToString otherModules ++ L.map chModuleToString signatures)
chEntrypointsToModules (ChExeEntrypoint mainModule _otherModules) =
(Just mainModule, [])
- chEntrypointsToModules ChSetupEntrypoint = (Nothing, [])
+ chEntrypointsToModules (ChSetupEntrypoint _) = (Nothing, [])
chModuleToString :: ChModuleName -> String
chModuleToString (ChModuleName n) = n
chComponentNameToComponentType :: ChComponentName -> HCE.ComponentType
chComponentNameToComponentType ChSetupHsName = HCE.Setup
- chComponentNameToComponentType ChLibName = HCE.Lib
- chComponentNameToComponentType (ChSubLibName name) =
- HCE.SubLib $ T.pack name
+ chComponentNameToComponentType (ChLibName _) = HCE.Lib
+ -- chComponentNameToComponentType (ChSubLibName name) =
+ -- HCE.SubLib $ T.pack name
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 (ChSubLibName name) =
- HCE.ComponentId . T.append "sublib-" . T.pack $ name
+ chComponentNameToComponentId (ChLibName _) = HCE.ComponentId "lib"
+ -- chComponentNameToComponentId (ChSubLibName name) =
+ -- HCE.ComponentId . T.append "sublib-" . T.pack $ name
chComponentNameToComponentId (ChFLibName name) =
HCE.ComponentId . T.append "flib-" . T.pack $ name
chComponentNameToComponentId (ChExeName name) =
@@ -445,15 +460,17 @@ eachIdentifierOccurrence accumulator HCE.ModuleInfo {..} f =
accumulator
idOccMap
-instance ExceptionMonad (LoggingT IO) where
- gcatch act h =
- LoggingT $ \logFn ->
- runLoggingT act logFn `gcatch` \e -> runLoggingT (h e) logFn
- gmask f =
- LoggingT $ \logFn ->
- gmask $ \io_restore ->
- let g_restore (LoggingT m) = LoggingT $ \lf -> io_restore (m lf)
- in runLoggingT (f g_restore) logFn
+-- loggingT IO is already MonadCatch and MonadMask
+-- instance MonadCatch (LoggingT IO) where
+-- catch act h =
+-- LoggingT $ \logFn ->
+-- runLoggingT act logFn `gcatch` \e -> runLoggingT (h e) logFn
+-- instance MonadMask (LoggingT IO) where
+-- mask f =
+-- LoggingT $ \logFn ->
+-- gmask $ \io_restore ->
+-- let g_restore (LoggingT m) = LoggingT $ \lf -> io_restore (m lf)
+-- in runLoggingT (f g_restore) logFn
instance MonadLoggerIO (GhcT (LoggingT IO)) where
askLoggerIO = GhcT $ const askLoggerIO
@@ -467,7 +484,7 @@ gtrySync action = ghandleSync (return . Left) (fmap Right action)
ghandleSync :: (ExceptionMonad m) => (SomeException -> m a) -> m a -> m a
ghandleSync onError =
- ghandle
+ handle
(\ex ->
case fromException ex of
Just (asyncEx :: SomeAsyncException) -> throw asyncEx
@@ -505,49 +522,33 @@ indexBuildComponent sourceCodePreprocessing currentPackageId componentId deps@(f
parseDynamicFlagsCmdLine
flags
(L.map noLoc . L.filter ("-Werror" /=) $ options) -- -Werror flag makes warnings fatal
- (flags'', _) <- liftIO $ initPackages flags'
- logFn <- askLoggerIO
- let logAction ::
- DynFlags
- -> WarnReason
- -> Severity
- -> SrcSpan
- -> Outputable.PprStyle
- -> SDoc
- -> IO ()
- logAction fs _reason _severity srcSpan _stype msg =
- runLoggingT
- (logDebugN
- (T.append "GHC message : " $
- T.pack $
- showSDocForUser fs neverQualify msg ++
- " , SrcSpan : " ++ show srcSpan))
- logFn
- mbTmpDir =
- case hiDir flags'' of
+ let mbTmpDir =
+ case hiDir flags' of
Just buildDir ->
Just $ buildDir </> (takeBaseName buildDir ++ "-tmp")
Nothing -> Nothing
_ <-
+ -- initUnits happens here
setSessionDynFlags $
L.foldl'
gopt_set
- (flags''
- { hscTarget = HscAsm
+ (flags'
+ { backend = NCG
, ghcLink = LinkInMemory
, ghcMode = CompManager
- , log_action = logAction
- , importPaths = importPaths flags'' ++ maybeToList mbTmpDir
+ , importPaths = importPaths flags' ++ maybeToList mbTmpDir
})
[Opt_Haddock]
targets <- mapM (`guessTarget` Nothing) modules
setTargets targets
_ <- load LoadAllTargets
modGraph <- getModuleGraph
- let topSortMods = flattenSCCs (topSortModuleGraph False modGraph Nothing)
+ let topSortMods =
+ flattenSCCs $
+ filterToposortToModules (topSortModuleGraph False modGraph Nothing)
buildDir =
addTrailingPathSeparator . normalise . fromMaybe "" . hiDir $
- flags''
+ flags'
pathsModuleName =
"Paths_" ++
map
@@ -583,7 +584,7 @@ indexBuildComponent sourceCodePreprocessing currentPackageId componentId deps@(f
logErrorN $
T.append
"Cannot find module path : "
- (toText flags'' $ map ms_mod modulesNotFound)
+ (toText flags' $ map ms_mod modulesNotFound)
foldM
(\(indexedModules, (fileMap', defSiteMap', modNameMap')) (modulePath, modSum) -> do
result <-
@@ -591,7 +592,7 @@ indexBuildComponent sourceCodePreprocessing currentPackageId componentId deps@(f
sourceCodePreprocessing
componentId
currentPackageId
- flags''
+ flags'
(fileMap', defSiteMap', modNameMap')
(modulePath, modSum)
case result of
@@ -673,6 +674,7 @@ indexModule sourceCodePreprocessing componentId currentPackageId flags deps (mod
createModuleInfo
deps
( flags
+ , hsc_units hscEnv
, typecheckedModule
, hsc_HPT hscEnv
, externalPackageState
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-25 19:40:16 +0000