Display summary of warnings at end of execution

Hackport is noisy. At the end of the output, display any warnings that were fired so that they are easier to notice. We use a DList to hold the list of warnings. This adds `StateT WarningBuffer` to the Env monad stack and runs displayWarnings (new function) as the last part of runEnv. Add `warn` function to the Util module and display warnings whenever `die` is called. Convert `errorWarnOnUnbuildable` in the Merge module to use the new warning functionality. Signed-off-by: hololeap <[email protected]>
gentoo-haskell · Mar 23, 2024 · 2934996 · 2934996
1 parent 19f61be
commit 2934996
Show file tree

Hide file tree

Showing 4 changed files with 122 additions and 51 deletions.
diff --git a/src/Hackport/Env.hs b/src/Hackport/Env.hs
@@ -10,6 +10,10 @@ module Hackport.Env
   , HasGlobalEnv (..)
   , Env
   , runEnv
+  , WarningBuffer
+  , getWarningBuffer
+  , modifyWarningBuffer
+  , displayWarnings
     -- * Global env
   , GlobalEnv (..)
     -- * Subcommand env
@@ -29,14 +33,28 @@ module Hackport.Env
   ) where
 
 import Control.Monad.Reader
+import Control.Monad.State.Strict
+import qualified Data.DList as DL
+import qualified Data.List as L
 import Data.List.NonEmpty (NonEmpty (..))
 import Data.Semigroup (Last(..))
+import qualified Distribution.Simple.Utils as Cabal
 import qualified Distribution.Verbosity as V
 
 import Status.Types (StatusDirection)
 
-type MonadEnv env m = (HasGlobalEnv m, HasEnv env m, MonadIO m)
-type Env env = ReaderT (GlobalEnv, env) IO
+-- | @hackport@ is noisy. Hold off on displaying any warnings until the bulk
+--   of the output has been printed. We use a 'DL.DList' to hold the pending
+--   warnings.
+type WarningBuffer = DL.DList String
+
+type MonadEnv env m =
+    ( HasGlobalEnv m
+    , HasEnv env m
+    , MonadIO m
+    , MonadState WarningBuffer m
+    )
+type Env env = ReaderT (GlobalEnv, env) (StateT WarningBuffer IO)
 
 class HasGlobalEnv m where
   askGlobalEnv :: m GlobalEnv
@@ -50,6 +68,23 @@ class HasEnv env m where
 instance Monad m => HasEnv env (ReaderT (a,env) m) where
   askEnv = asks snd
 
+getWarningBuffer :: MonadState WarningBuffer m => m WarningBuffer
+getWarningBuffer = get
+
+modifyWarningBuffer :: MonadState WarningBuffer m
+  => (WarningBuffer -> WarningBuffer) -> m ()
+modifyWarningBuffer = modify
+
+-- | Read the warning buffer and output using 'Cabal.warn'.
+displayWarnings :: MonadIO m => V.Verbosity -> WarningBuffer -> m ()
+displayWarnings v dl =
+    liftIO $ Cabal.warn v $ unlines $ L.intercalate [""] $
+        ["hackport emitted the following warnings:"]
+            : (indent <$> DL.toList dl)
+  where
+    indent :: String -> [String]
+    indent = map ("  " ++) . lines
+
 data GlobalEnv = GlobalEnv
   { globalVerbosity :: V.Verbosity
   , globalPathToOverlay :: Maybe FilePath
@@ -102,9 +137,14 @@ data MergeEnv = MergeEnv
 instance WritesMetadata MergeEnv where
   useHackageRemote _ = True
 
+-- | Run with environment information. This calls 'displayWarnings' at the
+--   end of the execution.
 runEnv
   :: Env env a
   -> env
   -> GlobalEnv
   -> IO a
-runEnv env e global = runReaderT env (global, e)
+runEnv env e global = do
+    (a, dl) <- runStateT (runReaderT env (global, e)) DL.empty
+    displayWarnings (V.verboseNoWrap (globalVerbosity global)) dl
+    pure a
diff --git a/src/Hackport/Util.hs b/src/Hackport/Util.hs
@@ -43,14 +43,15 @@ getPortageDir = do
 withHackportContext :: (DCG.GlobalFlags -> DCG.RepoContext -> Env env a) -> Env env a
 withHackportContext callback = do
     (GlobalEnv verbosity _ _, _) <- ask
+    warnBuffer <- getWarningBuffer
     overlayPath <- getOverlayPath
     let flags = DCG.defaultGlobalFlags {
                     DCG.globalRemoteRepos = DUN.toNubList [defaultRemoteRepo]
                   , DCG.globalCacheDir    = DSS.Flag $ overlayPath </> ".hackport"
                 }
     control
-      $ \runInIO -> DCG.withRepoContext verbosity flags
-      $ runInIO . (callback flags <=< restoreM)
+        $ \runInIO -> DCG.withRepoContext verbosity flags
+        $ \ctx -> runInIO $ restoreM (ctx, warnBuffer) >>= callback flags
 
 -- | Default remote repository. Defaults to [hackage](hackage.haskell.org).
 defaultRemoteRepo :: DCT.RemoteRepo

diff --git a/src/Merge.hs b/src/Merge.hs
@@ -399,7 +399,7 @@ mergeGenericPackageDescription cat pkgGenericDesc fetch users_cabal_flags = do
   debug $ "buildDepends pkgDesc:  " ++ show (map prettyShow (Merge.buildDepends pkgDesc))
 
   -- <https://github.com/gentoo-haskell/hackport/issues/116>
-  warnings <- errorWarnOnUnbuildable
+  errorWarnOnUnbuildable
     (prettyShow cat)
     (prettyShow merged_cabal_pkg_name)
     pkgDesc0
@@ -477,8 +477,6 @@ mergeGenericPackageDescription cat pkgGenericDesc fetch users_cabal_flags = do
     fetchDigestAndCheck (overlayPath </> prettyShow cat </> prettyShow norm_pkgName)
       $ Portage.fromCabalPackageId cat cabal_pkgId
 
-  forM_ warnings $ notice . ("\n" ++)
-
 -- | Run @ebuild@ and @pkgcheck@ commands in the directory of the
 -- newly-generated ebuild.
 --
@@ -601,50 +599,63 @@ mergeEbuild existing_meta pkgdir ebuild flags = do
     notice $ "Writing " ++ emeta
     liftIO $ T.writeFile mpath updatedMetaText
 
+---
+
 -- <https://github.com/gentoo-haskell/hackport/issues/116>
 -- TODO: Make it so this is automatically fixed instead of requiring manual
 -- intervention
+
+-- | Check for unbuildable components. Unbuildable libraries are considered
+--   a fatal error, whereas any other unbuildable components only require a
+--   warning. This may produce false negatives when components are toggled by
+--   flags, but it also helps catch .cabal files that hackport has a hard time
+--   processing.
 errorWarnOnUnbuildable
     :: String -- Category name
     -> String -- Package name
     -> Cabal.PackageDescription
-    -> Env env [String]
-errorWarnOnUnbuildable cn pn pkgdesc = execWriterT $ do
-  let lib = Cabal.library pkgdesc            -- Main library
-      subLibs = Cabal.subLibraries pkgdesc   -- sub-libraries
-      exes = Cabal.executables pkgdesc       -- executables
-      tests = Cabal.testSuites pkgdesc       -- test-suites
-      ubLib = findUnbuildable Cabal.libName Cabal.libBuildInfo lib
-      ubSubLibs = findUnbuildable Cabal.libName Cabal.libBuildInfo subLibs
-      ubExes = findUnbuildable Cabal.exeName Cabal.buildInfo exes
-      ubTests = findUnbuildable Cabal.testName Cabal.testBuildInfo tests
-      ubErrs = execWriter $ do
-        forM_ ubLib $ \_ ->
-          tell ["main library"]
-        forM_ ubSubLibs $ \l ->
-          tell ["sub-library: " ++ Cabal.showLibraryName l]
-      ubWarns = execWriter $ do
-        forM_ ubExes $ \e ->
-          tell ["executable: " ++ Cabal.unUnqualComponentName e]
-        forM_ ubTests $ \t ->
-          tell ["test-suite: " ++ Cabal.unUnqualComponentName t]
-
-  unless (null ubWarns) $ tell $ pure $ unlines
-    $  [ "WARNING: The following components are unbuildable!" ]
-    ++ map ("  - " ++) ubWarns
-
-  unless (null ubErrs) $ error $ unlines
-    $  [ "FATAL: The following library components are unbuildable!" ]
-    ++ map ("  - " ++) ubErrs
-    ++ [ ""
-       , "You can edit the .cabal file to make the needed components buildable,"
-       , "then merge the package manually:"
-       , "  $ cabal get " ++ pn
-       , "  $ cd " ++ pn ++ "*/"
-       , "  # fix " ++ pn ++ ".cabal"
-       , "  $ hackport make-ebuild " ++ cn ++ " " ++ pn ++ ".cabal"
-       ]
-
+    -> Env env ()
+errorWarnOnUnbuildable cn pn pkgdesc = do
+    unless (null ubWarns) $ warn $ unlines $
+        [ "The following components are unbuildable!" ]
+        ++ map ("  - " ++) ubWarns
+    unless (null ubErrs) $ die ubErrMsg
   where
     findUnbuildable toName toBuildable
         = fmap toName . mfilter (not . Cabal.buildable . toBuildable)
+
+    lib = Cabal.library pkgdesc            -- Main library
+    subLibs = Cabal.subLibraries pkgdesc   -- sub-libraries
+    exes = Cabal.executables pkgdesc       -- executables
+    tests = Cabal.testSuites pkgdesc       -- test-suites
+    ubLib = findUnbuildable Cabal.libName Cabal.libBuildInfo lib
+    ubSubLibs = findUnbuildable Cabal.libName Cabal.libBuildInfo subLibs
+    ubExes = findUnbuildable Cabal.exeName Cabal.buildInfo exes
+    ubTests = findUnbuildable Cabal.testName Cabal.testBuildInfo tests
+
+    ubWarns :: [String]
+    ubWarns = execWriter $ do
+        forM_ ubExes $ \e ->
+            tell ["executable: " ++ Cabal.unUnqualComponentName e]
+        forM_ ubTests $ \t ->
+            tell ["test-suite: " ++ Cabal.unUnqualComponentName t]
+
+    ubErrs :: [String]
+    ubErrs = execWriter $ do
+        forM_ ubLib $ \_ ->
+            tell ["main library"]
+        forM_ ubSubLibs $ \l ->
+            tell ["sub-library: " ++ Cabal.showLibraryName l]
+
+    ubErrMsg :: String
+    ubErrMsg = unlines
+        $  [ "FATAL: The following library components are unbuildable!" ]
+        ++ map ("  - " ++) ubErrs
+        ++ [ ""
+           , "You can edit the .cabal file to make the needed components buildable,"
+           , "then merge the package manually:"
+           , "  $ cabal get " ++ pn
+           , "  $ cd " ++ pn ++ "*/"
+           , "  # fix " ++ pn ++ ".cabal"
+           , "  $ hackport make-ebuild " ++ cn ++ " " ++ pn ++ ".cabal"
+           ]
diff --git a/src/Util.hs b/src/Util.hs
@@ -11,14 +11,19 @@ module Util
     , debug
     , notice
     , info
+    , warn
+    , displayWarnings
     , die
     ) where
 
 import Control.Monad.IO.Class
+import Control.Monad.State.Strict
+import qualified Data.DList as DL
 import System.IO
 import System.Process
 import System.Exit (ExitCode(..))
 import qualified Distribution.Simple.Utils as Cabal
+import qualified Distribution.Verbosity as Cabal
 import Hackport.Env
 
 -- | 'run_cmd' executes command and returns it's standard output
@@ -38,14 +43,28 @@ run_cmd cmd = liftIO $ do
         else Just output
 
 debug :: (HasGlobalEnv m, MonadIO m) => String -> m ()
-debug s = askGlobalEnv >>= \(GlobalEnv v _ _) -> liftIO $ Cabal.debug v s
+debug s = withVerbosity $ \v -> liftIO $ Cabal.debug v s
 
 notice :: (HasGlobalEnv m, MonadIO m) => String -> m ()
-notice s = askGlobalEnv >>= \(GlobalEnv v _ _) -> liftIO $ Cabal.notice v s
+notice s = withVerbosity $ \v -> liftIO $ Cabal.notice v s
 
 info :: (HasGlobalEnv m, MonadIO m) => String -> m ()
-info s = askGlobalEnv >>= \(GlobalEnv v _ _) -> liftIO $ Cabal.info v s
+info s = withVerbosity $ \v -> liftIO $ Cabal.info v s
 
--- | Terminate with an error message
-die :: (HasGlobalEnv m, MonadIO m) => String -> m a
-die s = askGlobalEnv >>= \(GlobalEnv v _ _) -> liftIO $ Cabal.die' v s
+-- | Display a warning, then add a it to the global 'WarningBuffer', so that
+--   it will be displayed at the end of hackport's output.
+warn :: (HasGlobalEnv m, MonadIO m, MonadState WarningBuffer m) => String -> m ()
+warn s = withVerbosity $ \v -> do
+    liftIO $ Cabal.warn v s
+    modifyWarningBuffer (<> DL.singleton s)
+
+-- | Display all pending warnings, then terminate with an error message
+die :: (MonadState WarningBuffer m, HasGlobalEnv m, MonadIO m) => String -> m a
+die s = withVerbosity $ \v -> getWarningBuffer >>= \dl -> do
+    displayWarnings v dl
+    liftIO $ error s
+
+withVerbosity :: (Monad m, HasGlobalEnv m) => (Cabal.Verbosity -> m a) -> m a
+withVerbosity f = do
+    verbosity <- globalVerbosity <$> askGlobalEnv
+    f (Cabal.verboseNoWrap verbosity)