cabal-plan 0.7.0.0 → 0.7.1.0
raw patch · 4 files changed
+287/−186 lines, 4 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- ChangeLog.md +8/−1
- cabal-plan.cabal +8/−6
- src-exe/CText.hs +188/−0
- src-exe/cabal-plan.hs +83/−179
ChangeLog.md view
@@ -1,8 +1,15 @@ # Revision history for `cabal-plan` +## 0.7.1.0++### `exe:cabal-plan` Executable++* Add `--ascii` / `--unicode` flags to control output character set+* Add `dot-png` command as a version of `dot` command with different defaults+ ## 0.7.0.0 -### `lib:cabal-plan` Libraru+### `lib:cabal-plan` Library * Support `local+noindex` style repositories: New `Repo` constructor: `RepoLocalNoIndex`. * Support newer versions of dependencies (GHC-8.10, aeson-1.5, optics-core-0.3)
cabal-plan.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: cabal-plan-version: 0.7.0.0+version: 0.7.1.0 synopsis: Library and utility for processing cabal's plan.json file description: {@@ -38,8 +38,8 @@ build-type: Simple tested-with:- GHC==8.10.1- GHC==8.8.3,+ GHC==8.10.2,+ GHC==8.8.4, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2,@@ -97,7 +97,9 @@ hs-source-dirs: src-exe main-is: cabal-plan.hs other-modules: Paths_cabal_plan LicenseReport Flag ProcessLazyByteString+ other-modules: CText autogen-modules: Paths_cabal_plan+ ghc-options: -Wall if flag(exe) -- dependencies w/ inherited version ranges via 'cabal-plan' library@@ -112,15 +114,15 @@ -- dependencies which require version bounds build-depends: mtl ^>= 2.2.2 , async ^>= 2.2.2- , ansi-terminal ^>=0.10+ , ansi-terminal ^>=0.10 || ^>=0.11 , base-compat ^>=0.11 , optics-core ^>= 0.2 || ^>= 0.3- , optparse-applicative ^>= 0.15.0.0+ , optparse-applicative ^>= 0.15.0.0 || ^>=0.16.0.0 , parsec ^>= 3.1.13 , process ^>= 1.4.3.0 || ^>=1.6.3.0 , semialign ^>= 1.1 , singleton-bool ^>= 0.1.5- , these ^>= 1+ , these ^>= 1 || ^>=1.1 , topograph ^>= 1 , transformers ^>= 0.5.2.0 , vector ^>= 0.12.0.1
+ src-exe/CText.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE OverloadedStrings #-}+module CText (+ -- * CText+ CText (..),+ CPiece (..),+ T (..), fromT, fromText,+ -- ** Colorify+ recolorify, colorifyText, colorifyStr,+ underline, emphasise,+ -- * CWriter+ CWriter,+ runCWriterIO,+ MonadCWriter (..),+ UseColors (..),+ UseAscii (..),+ -- * Underline+ haveUnderlineSupport,+ -- * Re-exports+ module System.Console.ANSI,+ ) where++import Control.Monad.Compat (ap, unless)+import Control.Monad.State.Strict (StateT)+import Control.Monad.Trans.Class (lift)+import Data.Foldable (for_)+import qualified Data.List as L+import Data.Monoid (Endo (..))+import Data.Semigroup (Semigroup (..))+import Data.String (IsString (..))+import qualified Data.Text as T+import qualified Data.Text.IO as T+import GHC.IO.Encoding.Types (textEncodingName)+import System.Console.ANSI+import System.IO (hGetEncoding, stdout)++haveUnderlineSupport :: Bool+#if defined(UNDERLINE_SUPPORT)+haveUnderlineSupport = True+#else+haveUnderlineSupport = False+#endif++data CPiece = CPiece !T [SGR]+ deriving (Eq, Show)++data T+ = T !T.Text+ | Vert -- vertical+ | Junc -- junction+ | Corn -- corner+ | Spac -- space+ | Rest -- "ellipsis"+ deriving (Eq, Show)++newtype CText = CText [CPiece]+ deriving (Eq, Show)++instance IsString CText where+ fromString s+ | null s = mempty+ | otherwise = CText [CPiece (T (fromString s)) []]++instance Semigroup CText where+ CText xs <> CText ys = CText (xs <> ys)++instance Monoid CText where+ mempty = CText []+ mappend = (<>)++fromText :: T.Text -> CText+fromText t = CText [CPiece (T t) []]++fromT :: T -> CText+fromT t = CText [CPiece t []]++colorifyStr :: Color -> String -> CText+colorifyStr c t = CText [CPiece (T (T.pack t)) [SetColor Foreground Vivid c]]++colorifyText :: Color -> T.Text -> CText+colorifyText c t = CText [CPiece (T t) [SetColor Foreground Vivid c]]++recolorify :: Color -> CText -> CText+recolorify c (CText xs) = CText+ [ CPiece t (SetColor Foreground Vivid c : sgr)+ | CPiece t sgr' <- xs+ , let sgr = filter notSetColor sgr'+ ]+ where+ notSetColor SetColor {} = False+ notSetColor _ = True++-- | We decide to bold, we could do something else to.+emphasise :: CText -> CText+emphasise (CText xs) = CText+ [ CPiece t (SetConsoleIntensity BoldIntensity : sgr)+ | CPiece t sgr <- xs+ ]++underline :: CText -> CText+underline (CText xs) | haveUnderlineSupport = CText+ [ CPiece t (SetUnderlining SingleUnderline : sgr)+ | CPiece t sgr <- xs+ ]+underline x = x++-- | Colored writer (list is lines)+newtype CWriter a = CWriter { unCWriter :: Endo [CText] -> (Endo [CText], a) }+ deriving Functor++class Monad m => MonadCWriter m where+ putCTextLn :: CText -> m ()++instance MonadCWriter CWriter where+ putCTextLn t = CWriter $ \l -> (l <> Endo (t :), ())++instance MonadCWriter m => MonadCWriter (StateT s m) where+ putCTextLn = lift . putCTextLn++instance Applicative CWriter where+ pure = return+ (<*>) = ap++instance Monad CWriter where+ return x = CWriter $ \ls -> (ls, x)++ m >>= k = CWriter $ \ls0 ->+ let (ls1, x) = unCWriter m ls0+ in unCWriter (k x) ls1++data UseColors = ColorsNever | ColorsAuto | ColorsAlways+ deriving (Eq, Show)++data UseAscii = UseAscii | UseUnicode | UseAsciiAuto+ deriving (Eq, Show)++runCWriterIO :: UseColors -> UseAscii -> CWriter () -> IO ()+runCWriterIO ColorsNever useAscii m = do+ useAscii' <- shouldUseAscii useAscii+ runCWriterIONoColors useAscii' m+runCWriterIO ColorsAlways useAscii m = do+ useAscii' <- shouldUseAscii useAscii+ runCWriterIOColors useAscii' m+runCWriterIO ColorsAuto useAscii m = do+ useAscii' <- shouldUseAscii useAscii+ supports <- hSupportsANSIColor stdout+ if supports+ then runCWriterIOColors useAscii' m+ else runCWriterIONoColors useAscii' m++-- TODO: check environment variables?+shouldUseAscii :: UseAscii -> IO Bool+shouldUseAscii UseAscii = return True+shouldUseAscii UseUnicode = return False+shouldUseAscii UseAsciiAuto = do+ e <- hGetEncoding stdout+ return $ not $ fmap (L.isPrefixOf "UTF" . textEncodingName) e == Just True++putT :: Bool -> T -> IO ()+putT _ (T t) = T.putStr t+-- https://en.wikipedia.org/wiki/Box-drawing_character+putT False Vert = T.putStr " \x2502 "+putT False Junc = T.putStr " \x251c\x2500 "+putT False Corn = T.putStr " \x2514\x2500 "+putT False Rest = T.putStr " \x2504\x2504"+-- ascii+putT True Vert = T.putStr " | "+putT True Junc = T.putStr " +- "+putT True Corn = T.putStr " +- "+putT True Rest = T.putStr " ..."+-- space is just space+putT _ Spac = T.putStr " "++runCWriterIOColors :: Bool -> CWriter () -> IO ()+runCWriterIOColors useAscii (CWriter f) =+ for_ (appEndo (fst (f mempty)) []) $ \(CText l) -> do+ for_ l $ \(CPiece t sgr) -> do+ unless (null sgr) $ setSGR sgr+ putT useAscii t+ unless (null sgr) $ setSGR []+ putChar '\n'++runCWriterIONoColors :: Bool -> CWriter () -> IO ()+runCWriterIONoColors useAscii (CWriter f) =+ for_ (appEndo (fst (f mempty)) []) $ \(CText l) -> do+ for_ l $ \(CPiece t _) -> putT useAscii t+ putChar '\n'
src-exe/cabal-plan.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}@@ -8,13 +7,12 @@ -- | SPDX-License-Identifier: GPL-2.0-or-later module Main where -import Prelude ()-import Prelude.Compat+import Prelude ()+import Prelude.Compat -import Control.Monad.Compat (ap, forM_, guard, unless, when)+import Control.Monad.Compat (guard, unless, when) import Control.Monad.ST (runST) import Control.Monad.State.Strict (StateT, evalStateT, gets, modify')-import Control.Monad.Trans.Class (lift) import Data.Align (align) import Data.ByteString (ByteString) import qualified Data.ByteString as BS@@ -24,8 +22,9 @@ import qualified Data.Graph as G import Data.Map (Map) import qualified Data.Map as M-import Data.Maybe (catMaybes, fromMaybe, isJust, mapMaybe)-import Data.Monoid (Any (..), Endo (..))+import Data.Maybe (catMaybes, fromMaybe, isJust,+ mapMaybe)+import Data.Monoid (Any (..)) import Data.Semigroup (Semigroup (..)) import Data.Set (Set) import qualified Data.Set as S@@ -43,25 +42,19 @@ import Flag import Optics.Indexed.Core (ifor_) import Options.Applicative-import System.Console.ANSI+import ProcessLazyByteString (readProcessWithExitCode) import System.Directory (getCurrentDirectory) import System.Exit (ExitCode (..), exitFailure)-import System.IO (hPutStrLn, stderr, stdout)-import ProcessLazyByteString (readProcessWithExitCode)+import System.IO (hPutStrLn, stderr) import qualified Text.Parsec as P import qualified Text.Parsec.String as P import qualified Topograph as TG -import Cabal.Plan-import LicenseReport (generateLicenseReport)-import Paths_cabal_plan (version)+import Cabal.Plan+import CText+import LicenseReport (generateLicenseReport)+import Paths_cabal_plan (version) -haveUnderlineSupport :: Bool-#if defined(UNDERLINE_SUPPORT)-haveUnderlineSupport = True-#else-haveUnderlineSupport = False-#endif data ShowBuiltin = ShowBuiltin data ShowGlobal = ShowGlobal@@ -83,6 +76,7 @@ { optsShowBuiltin :: Flag ShowBuiltin , optsShowGlobal :: Flag ShowGlobal , optsUseColors :: UseColors+ , optsUseAscii :: UseAscii , cmd :: Command } @@ -273,7 +267,7 @@ case cmd of InfoCommand s -> do (mProjRoot, plan) <- findPlan s- doInfo optsUseColors mProjRoot plan+ doInfo optsUseColors optsUseAscii mProjRoot plan ShowCommand s -> do (mProjRoot, plan) <- findPlan s mapM_ print mProjRoot@@ -284,7 +278,7 @@ DiffCommand old new -> do (_, oldPlan) <- findPlan (Just old) (_, newPlan) <- findPlan (Just new)- doDiff optsUseColors oldPlan newPlan+ doDiff optsUseColors optsUseAscii oldPlan newPlan ListBinsCommand s count pats -> do (_, plan) <- findPlan s let bins = doListBin plan pats@@ -327,6 +321,7 @@ <$> showHide ShowBuiltin "builtin" "Show / hide packages in global (non-nix-style) package db" <*> showHide ShowGlobal "global" "Show / hide packages in nix-store" <*> useColorsParser+ <*> useAsciiParser <*> (cmdParser <|> defaultCommand) @@ -346,6 +341,13 @@ parseColor "auto" = Right ColorsAuto parseColor s = Left $ "Use always, never or auto; not " ++ s + useAsciiParser :: Parser UseAscii+ useAsciiParser =+ flag' UseAscii (mconcat [long "ascii", help "Use ASCII output"]) <|>+ flag' UseUnicode (mconcat [long "unicode", help "Use Unicode output"]) <|>+ flag' UseAsciiAuto (mconcat [long "ascii-auto"]) <|>+ pure UseAsciiAuto+ subCommand name desc val = command name $ info val $ progDesc desc patternArgument = argument (eitherReader parsePattern) . mconcat@@ -380,9 +382,18 @@ <*> switchM DotTredWght "tred-weights" "Adjust edge thickness during transitive reduction" <*> many highlightParser <*> many (patternOption [ long "root", metavar "PATTERN", help "Graph root(s)", completer $ patternCompleter True ])- <*> strOption (mconcat [ short 'o', long "output", metavar "FILE", value "-", showDefault, completer (bashCompleter "file") ])+ <*> strOption (mconcat [ short 'o', long "output", metavar "FILE", value "-", showDefault, completer (bashCompleter "file"), help "Output file"]) <*> optional runDot <**> helper+ , subCommand "dot-png" "Generate dependency PNG image" $ DotCommand+ <$> planParser+ <*> pure (toFlag DotTred True)+ <*> pure (toFlag DotTredWght True)+ <*> many highlightParser+ <*> many (patternOption [ long "root", metavar "PATTERN", help "Graph root(s)", completer $ patternCompleter True ])+ <*> strOption (mconcat [ short 'o', long "output", value "deps.png", metavar "FILE", showDefault, completer (bashCompleter "file"), help "Output file"])+ <*> pure (Just PNG)+ <**> helper , subCommand "topo" "Plan in a topological sort" $ TopoCommand <$> planParser <*> switchM TopoReverse "reverse" "Reverse order"@@ -484,15 +495,15 @@ -- info ------------------------------------------------------------------------------- -doInfo :: UseColors -> Maybe FilePath -> PlanJson -> IO ()-doInfo useColors mProjbase plan = do- forM_ mProjbase $ \projbase ->+doInfo :: UseColors -> UseAscii -> Maybe FilePath -> PlanJson -> IO ()+doInfo useColors useAscii mProjbase plan = do+ for_ mProjbase $ \projbase -> putStrLn ("using '" ++ projbase ++ "' as project root") putStrLn "" putStrLn "Tree" putStrLn "~~~~" putStrLn ""- runCWriterIO useColors (dumpPlanJson plan)+ runCWriterIO useColors useAscii (dumpPlanJson plan) -- print (findCycles (planJsonIdGrap v)) @@ -529,7 +540,7 @@ ------------------------------------------------------------------------------- doTred :: UseColors -> PlanJson -> IO ()-doTred useColors plan = runCWriterIO useColors (dumpTred plan)+doTred useColors plan = runCWriterIO useColors UseAscii (dumpTred plan) dumpTred :: PlanJson -> CWriter () dumpTred plan = case fst <$> reductionClosureAM plan of@@ -563,17 +574,17 @@ -> DotUnitId -> StateT (Set DotUnitId) CWriter () go1 am = go2 [] where- ccol :: Maybe CompName -> String -> CText- ccol Nothing = colorifyStr White+ ccol :: Maybe CompName -> CText -> CText+ ccol Nothing = recolorify White ccol (Just comp) = ccol' comp - ccol' CompNameLib = colorifyStr White- ccol' (CompNameExe _) = colorifyStr Green- ccol' CompNameSetup = colorifyStr Red- ccol' (CompNameTest _) = colorifyStr Yellow- ccol' (CompNameBench _) = colorifyStr Cyan- ccol' (CompNameSubLib _) = colorifyStr Blue- ccol' (CompNameFLib _) = colorifyStr Magenta+ ccol' CompNameLib = recolorify White+ ccol' (CompNameExe _) = recolorify Green+ ccol' CompNameSetup = recolorify Red+ ccol' (CompNameTest _) = recolorify Yellow+ ccol' (CompNameBench _) = recolorify Cyan+ ccol' (CompNameSubLib _) = recolorify Blue+ ccol' (CompNameFLib _) = recolorify Magenta go2 :: [(Maybe CompName, Bool)] -> DotUnitId@@ -603,23 +614,23 @@ linepfx :: [(Maybe CompName, Bool)] -> CText linepfx lvl = case unsnoc lvl of Nothing -> ""- Just (xs,(zt,z)) -> mconcat [ if x then ccol xt " │ " else " " | (xt,x) <- xs ]- <> (ccol zt $ if z then " ├─ " else " └─ ")+ Just (xs,(zt,z)) -> mconcat [ if x then ccol xt (fromT Vert) else fromT Spac | (xt,x) <- xs ]+ <> (ccol zt $ fromT $ if z then Junc else Corn) prettyPid = T.unpack . dispPkgId - prettyCompTy :: PkgId -> Maybe CompName -> String- prettyCompTy pid Nothing = "[" ++ prettyPid pid ++ ":all]"+ prettyCompTy :: PkgId -> Maybe CompName -> CText+ prettyCompTy pid Nothing = fromString $ "[" ++ prettyPid pid ++ ":all]" prettyCompTy pid (Just c) = prettyCompTy' pid c - prettyCompTy' :: PkgId -> CompName -> String- prettyCompTy' pid CompNameLib = prettyPid pid- prettyCompTy' _pid CompNameSetup = "[setup]"- prettyCompTy' pid (CompNameExe n) = "[" ++ prettyPid pid ++ ":exe:" ++ show n ++ "]"- prettyCompTy' pid (CompNameTest n) = "[" ++ prettyPid pid ++ ":test:" ++ show n ++ "]"- prettyCompTy' pid (CompNameBench n) = "[" ++ prettyPid pid ++ ":bench:" ++ show n ++ "]"- prettyCompTy' pid (CompNameSubLib n) = "[" ++ prettyPid pid ++ ":lib:" ++ show n ++ "]"- prettyCompTy' pid (CompNameFLib n) = "[" ++ prettyPid pid ++ ":flib:" ++ show n ++ "]"+ prettyCompTy' :: PkgId -> CompName -> CText+ prettyCompTy' pid CompNameLib = fromString $ prettyPid pid+ prettyCompTy' _pid CompNameSetup = fromString $ "[setup]"+ prettyCompTy' pid (CompNameExe n) = fromString $ "[" ++ prettyPid pid ++ ":exe:" ++ show n ++ "]"+ prettyCompTy' pid (CompNameTest n) = fromString $ "[" ++ prettyPid pid ++ ":test:" ++ show n ++ "]"+ prettyCompTy' pid (CompNameBench n) = fromString $ "[" ++ prettyPid pid ++ ":bench:" ++ show n ++ "]"+ prettyCompTy' pid (CompNameSubLib n) = fromString $ "[" ++ prettyPid pid ++ ":lib:" ++ show n ++ "]"+ prettyCompTy' pid (CompNameFLib n) = fromString $ "[" ++ prettyPid pid ++ ":flib:" ++ show n ++ "]" reductionClosureAM :: PlanJson@@ -643,8 +654,8 @@ Changed <> x = x x <> _ = x -doDiff :: UseColors -> PlanJson -> PlanJson -> IO ()-doDiff useColors oldPlan newPlan = runCWriterIO useColors (dumpDiff oldPlan newPlan)+doDiff :: UseColors -> UseAscii -> PlanJson -> PlanJson -> IO ()+doDiff useColors useAscii oldPlan newPlan = runCWriterIO useColors useAscii (dumpDiff oldPlan newPlan) dumpDiff :: PlanJson -> PlanJson -> CWriter () dumpDiff oldPlan newPlan = case liftA2 (,) (reductionClosureAM oldPlan) (reductionClosureAM newPlan) of@@ -812,8 +823,8 @@ linepfx :: [(Maybe CompName, Bool)] -> CText linepfx lvl = case unsnoc lvl of Nothing -> mempty- Just (xs,(_,z)) -> mconcat [ if x then " │ " else " " | (_,x) <- xs ]- <> (if z then " ├─ " else " └─ ")+ Just (xs,(_,z)) -> mconcat [ fromT $ if x then Vert else Spac | (_,x) <- xs ]+ <> fromT (if z then Junc else Corn) prettyPkgName (PkgName pn) = pn @@ -914,7 +925,7 @@ (foldMap (\unitId -> M.findWithDefault S.empty unitId closureAM) rootUnits) let isReachableUnit :: DotUnitId -> Bool- isReachableUnit _ | null rootPatterns = True+ isReachableUnit _ | null rootPatterns = True isReachableUnit unitId = S.member unitId reachableUnits let duShow :: DotUnitId -> Bool@@ -1170,7 +1181,7 @@ lst@(_:_:_) -> do hPutStrLn stderr "Multiple matching components found:"- forM_ lst $ \(pat', uid, cn) -> do+ for_ lst $ \(pat', uid, cn) -> do hPutStrLn stderr ("- " ++ T.unpack pat' ++ " " ++ show (uid, cn)) exitFailure @@ -1215,7 +1226,7 @@ let rev' = if fromFlag TopoReverse rev then reverse else id - runCWriterIO useColors $ for_ topo $ \topo' -> for_ (rev' topo') $ \unitId ->+ runCWriterIO useColors UseAscii $ for_ topo $ \topo' -> for_ (rev' topo') $ \unitId -> for_ (M.lookup unitId units) $ \unit -> when (showUnit unit) $ do let pkgIdColor = colorifyText $ case uType unit of@@ -1263,8 +1274,7 @@ putCTextLn $ linepfx <> pid_label showDeps else do- putCTextLn $ linepfx <> pid_label <> ccol CompNameLib " ┄┄"- -- tell $ LT.fromString (linepfx' ++ " └┄\n")+ putCTextLn $ linepfx <> pid_label <> ccol CompNameLib (fromT Rest) modify' (S.insert pid) @@ -1284,11 +1294,11 @@ linepfx :: CText linepfx = case unsnoc lvl of Nothing -> ""- Just (xs,(zt,z)) -> mconcat [ if x then ccol xt " │ " else " " | (xt,x) <- xs ]- <> (ccol zt $ if z then " ├─ " else " └─ ")+ Just (xs,(zt,z)) -> mconcat [ if x then ccol xt (fromT Vert) else fromT Spac | (xt,x) <- xs ]+ <> (ccol zt $ if z then fromT Junc else fromT Corn) linepfx' :: CText- linepfx' = mconcat [ if x then " │ " else " " | (_,x) <- lvl ]+ linepfx' = mconcat [ fromT $ if x then Vert else Spac | (_,x) <- lvl ] roots :: Set UnitId roots = M.keysSet pm `S.difference` leafs@@ -1302,23 +1312,23 @@ prettyCompTy :: PkgId -> CompName -> CText prettyCompTy _pid c@CompNameLib = ccol c "[lib]" prettyCompTy _pid c@CompNameSetup = ccol c "[setup]"- prettyCompTy pid c@(CompNameExe n) = ccol c $ "[" ++ prettyPid pid ++ ":exe:" ++ show n ++ "]"- prettyCompTy pid c@(CompNameTest n) = ccol c $ "[" ++ prettyPid pid ++ ":test:" ++ show n ++ "]"- prettyCompTy pid c@(CompNameBench n) = ccol c $ "[" ++ prettyPid pid ++ ":bench:" ++ show n ++ "]"- prettyCompTy pid c@(CompNameSubLib n) = ccol c $ "[" ++ prettyPid pid ++ ":lib:" ++ show n ++ "]"- prettyCompTy pid c@(CompNameFLib n) = ccol c $ "[" ++ prettyPid pid ++ ":flib:" ++ show n ++ "]"+ prettyCompTy pid c@(CompNameExe n) = ccol c $ fromString $ "[" ++ prettyPid pid ++ ":exe:" ++ show n ++ "]"+ prettyCompTy pid c@(CompNameTest n) = ccol c $ fromString $ "[" ++ prettyPid pid ++ ":test:" ++ show n ++ "]"+ prettyCompTy pid c@(CompNameBench n) = ccol c $ fromString $ "[" ++ prettyPid pid ++ ":bench:" ++ show n ++ "]"+ prettyCompTy pid c@(CompNameSubLib n) = ccol c $ fromString $ "[" ++ prettyPid pid ++ ":lib:" ++ show n ++ "]"+ prettyCompTy pid c@(CompNameFLib n) = ccol c $ fromString $ "[" ++ prettyPid pid ++ ":flib:" ++ show n ++ "]" - ccol CompNameLib = colorifyStr White- ccol (CompNameExe _) = colorifyStr Green- ccol CompNameSetup = colorifyStr Red- ccol (CompNameTest _) = colorifyStr Yellow- ccol (CompNameBench _) = colorifyStr Cyan- ccol (CompNameSubLib _) = colorifyStr Blue- ccol (CompNameFLib _) = colorifyStr Magenta+ ccol CompNameLib = recolorify White+ ccol (CompNameExe _) = recolorify Green+ ccol CompNameSetup = recolorify Red+ ccol (CompNameTest _) = recolorify Yellow+ ccol (CompNameBench _) = recolorify Cyan+ ccol (CompNameSubLib _) = recolorify Blue+ ccol (CompNameFLib _) = recolorify Magenta colorify_ :: Color -> String -> CText colorify_ col s- | haveUnderlineSupport = CText [CPiece (T.pack s) [SetUnderlining SingleUnderline, SetColor Foreground Vivid col]]+ | haveUnderlineSupport = CText [CPiece (T (T.pack s)) [SetUnderlining SingleUnderline, SetColor Foreground Vivid col]] | otherwise = colorifyStr col s lastAnn :: [x] -> [(Bool,x)]@@ -1344,109 +1354,3 @@ (g, v2k, _) = G.graphFromEdges [ ((), k, S.toList v) | (k,v) <- M.toList m ]------------------------------------------------------------------------------------ Colors----------------------------------------------------------------------------------data CPiece = CPiece !T.Text [SGR]- deriving (Eq, Show)--newtype CText = CText [CPiece]- deriving (Eq, Show)--instance IsString CText where- fromString s- | null s = mempty- | otherwise = CText [CPiece (fromString s) []]--instance Semigroup CText where- CText xs <> CText ys = CText (xs <> ys)--instance Monoid CText where- mempty = CText []- mappend = (<>)--fromText :: T.Text -> CText-fromText t = CText [CPiece t []]--colorifyStr :: Color -> String -> CText-colorifyStr c t = CText [CPiece (T.pack t) [SetColor Foreground Vivid c]]--colorifyText :: Color -> T.Text -> CText-colorifyText c t = CText [CPiece t [SetColor Foreground Vivid c]]--recolorify :: Color -> CText -> CText-recolorify c (CText xs) = CText- [ CPiece t (SetColor Foreground Vivid c : sgr)- | CPiece t sgr' <- xs- , let sgr = filter notSetColor sgr'- ]- where- notSetColor SetColor {} = False- notSetColor _ = True---- | We decide to bold, we could do something else to.-emphasise :: CText -> CText-emphasise (CText xs) = CText- [ CPiece t (SetConsoleIntensity BoldIntensity : sgr)- | CPiece t sgr <- xs- ]--underline :: CText -> CText-underline (CText xs) | haveUnderlineSupport = CText- [ CPiece t (SetUnderlining SingleUnderline : sgr)- | CPiece t sgr <- xs- ]-underline x = x---- | Colored writer (list is lines)-newtype CWriter a = CWriter { unCWriter :: Endo [CText] -> (Endo [CText], a) }- deriving Functor--class Monad m => MonadCWriter m where- putCTextLn :: CText -> m ()--instance MonadCWriter CWriter where- putCTextLn t = CWriter $ \l -> (l <> Endo (t :), ())--instance MonadCWriter m => MonadCWriter (StateT s m) where- putCTextLn = lift . putCTextLn--instance Applicative CWriter where- pure = return- (<*>) = ap--instance Monad CWriter where- return x = CWriter $ \ls -> (ls, x)-- m >>= k = CWriter $ \ls0 ->- let (ls1, x) = unCWriter m ls0- in unCWriter (k x) ls1--data UseColors = ColorsNever | ColorsAuto | ColorsAlways- deriving (Eq, Show)--runCWriterIO :: UseColors -> CWriter () -> IO ()-runCWriterIO ColorsNever m = runCWriterIONoColors m-runCWriterIO ColorsAlways m = runCWriterIOColors m-runCWriterIO ColorsAuto m = do- supports <- hSupportsANSIColor stdout- if supports- then runCWriterIOColors m- else runCWriterIONoColors m--runCWriterIOColors :: CWriter () -> IO ()-runCWriterIOColors (CWriter f) =- forM_ (appEndo (fst (f mempty)) []) $ \(CText l) -> do- forM_ l $ \(CPiece t sgr) -> do- unless (null sgr) $ setSGR sgr- T.putStr t- unless (null sgr) $ setSGR []- putChar '\n'--runCWriterIONoColors :: CWriter () -> IO ()-runCWriterIONoColors (CWriter f) =- forM_ (appEndo (fst (f mempty)) []) $ \(CText l) -> do- forM_ l $ \(CPiece t _) -> T.putStr t- putChar '\n'