From b69b74c577f3b1aeb1f2722f53d037d6a21d1abc Mon Sep 17 00:00:00 2001 From: Yuchen Pei Date: Mon, 6 Jun 2022 15:35:44 +1000 Subject: packageinfo done --- haskell-code-explorer.cabal | 1 + src/HaskellCodeExplorer/PackageInfo.hs | 150 +++++++++++++++++---------------- 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 -- cgit v1.2.3