add colours to emerge and haskell-updater outputs

Author: GuillaumedeVolpiano

src/GHRB/Core.hs

@@ -25,7 +25,7 @@ module GHRB.Core
   ) where
 
 import           Control.Applicative        (many, optional, (<|>))
-import           Control.Monad              (void)
+import           Control.Monad              (void, unless)
 import qualified Data.ByteString            as BS (ByteString)
 import qualified Data.ByteString.Char8      as BS (pack)
 import qualified Data.HashSet               as Set (insert, member)
@@ -42,7 +42,8 @@ import           Distribution.Portage.Types (Category (Category),
                                              getVersion, unwrapCategory,
                                              unwrapPkgName)
 import           FlatParse.Basic            (Parser, Result (OK), char, eof,
-                                             runParser, satisfy, string)
+                                             runParser, satisfy, string, anyChar)
+import qualified FlatParse.Basic as FP (failed)
 import           GHRB.Core.Types            (PackageSet, St (St), completed,
                                              downgrade, failed,
                                              tried, unresolved, untried, installed)
@@ -59,11 +60,24 @@ parsePackageList packageList =
 parsePackages :: Parser Void PackageSet
 parsePackages = parsePackage <|> (eof >> return mempty)
 
+stripANSI :: (Char -> Bool) -> Parser Void String
+stripANSI terminator = parseANSI terminator <|> (satisfy terminator >> pure "") <|> parseChar terminator
+
+parseChar :: (Char -> Bool) -> Parser Void String
+parseChar terminator = anyChar >>= \c -> (c :) <$> stripANSI terminator
+
+parseANSI :: (Char -> Bool) -> Parser Void String
+parseANSI terminator = do
+  $(string "\\[ESC")
+  void $ many (satisfy (/= 'm'))
+  $(char 'm')
+  stripANSI terminator
+
 parsePackage :: Parser Void PackageSet
 parsePackage = do
   category <- many (satisfy (/= '/'))
   $(char '/')
-  name <- many (satisfy (/= '\n'))
+  name <- many (satisfy (/= '\n'))
   void . optional $ $(char '\n')
   Set.insert
     Package
@@ -81,9 +95,9 @@ parseDowngrades = runParser parseDowngradeByLine
 parseDowngradeByLine :: Parser Void Bool
 parseDowngradeByLine =
   ($(string "[ebuild")
-     >> many (satisfy (`notElem` "^\\[]D"))
+     >> stripANSI (`elem` "^\\[]D")
      >> $(char 'D')
-     >> many (satisfy (`notElem` "^\\[]"))
+     >> stripANSI (`elem` "^\\[]")
      >> $(char ']')
      >> pure True)
     <|> (many (satisfy (/= '\n')) >> $(char '\n') >> parseDowngradeByLine)

src/GHRB/IO.hs

@@ -46,8 +46,8 @@ import           GHRB.IO.Cmd                   (defaultEmergeArgs,
                                                 defaultPqueryArgs,
                                                 installedArgs, repo,
                                                 runTransparent)
-import           GHRB.IO.Utils                 (bStderr, logOutput, stderr,
-                                                stdout, bStdout)
+import           GHRB.IO.Utils                 (bStderr, bStdout, logOutput,
+                                                stderr, stdout)
 import           System.Exit                   (ExitCode (ExitFailure, ExitSuccess))
 
 tmpLogRoot :: String
@@ -171,7 +171,7 @@ install ::
 install = do
   pkg <- gets package
   bStderr . prettyMessage $ "Preliminary emerge run succeeded..."
-  (exitCode, _, _) <- runEmerge ["--keep-going=y"] pkg
+  (exitCode, _, _) <- runEmerge ["--keep-going=y", "--color=n"] pkg
   time <- currentTime
   let result =
         if exitCode == ExitSuccess
@@ -232,7 +232,7 @@ totalStats = do
   let is = Set.size . Set.intersection total $ inst
       ts = Set.size total
       pc = (100 * is) `div` ts
-  pure 
+  pure
     $ show is
         ++ " installed out of "
         ++ show ts
@@ -255,13 +255,8 @@ capturePortageOutput ::
   -> Eff es (ExitCode, String)
 capturePortageOutput pkg = do
   emerge <- asks getEmerge
-  stderr
-    (emerge
-       ++ " "
-       ++ unwords defaultEmergeArgs
-       ++ " "
-       ++ "--pretend")
-  (exitCode, stdOut, stdErr) <- runEmerge ["--pretend"] pkg
+  stderr (emerge ++ " " ++ unwords defaultEmergeArgs ++ " " ++ "--pretend --color=y")
+  (exitCode, stdOut, stdErr) <- runEmerge ["--pretend", "--color=y"] pkg
   let output = stdOut ++ stdErr
   stderr ("pretend_return: " ++ output)
   pure (exitCode, output)

src/GHRB/IO/Cmd.hs

@@ -39,7 +39,6 @@ defaultEmergeArgs =
   , "--complete-graph"
   , "--oneshot"
   , "--update"
-  , "--color=n" -- Need a ANSI filtering library
   , "--nospinner"
   ]
 
@@ -52,7 +51,7 @@ defaultHUArgs =
   , "--ignore-default-opts"
   , "--verbose"
   , "--quiet-build"
-  , "--color=n" -- Need a ANSI filtering library
+  , "--color=y"
   , "--nospinner"
   ]