Hello community, here is the log from the commit of package cabal-plan for openSUSE:Factory checked in at 2020-09-15 16:20:09 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/cabal-plan (Old) and /work/SRC/openSUSE:Factory/.cabal-plan.new.4249 (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "cabal-plan" Tue Sep 15 16:20:09 2020 rev:2 rq:833301 version:0.7.1.0 Changes: -------- --- /work/SRC/openSUSE:Factory/cabal-plan/cabal-plan.changes 2020-09-07 21:23:09.893044887 +0200 +++ /work/SRC/openSUSE:Factory/.cabal-plan.new.4249/cabal-plan.changes 2020-09-15 16:20:16.170136052 +0200 @@ -1,0 +2,9 @@ +Wed Sep 9 02:00:42 UTC 2020 - psim...@suse.com + +- Update cabal-plan to version 0.7.1.0. + Upstream has edited the change log file since the last release in + a non-trivial way, i.e. they did more than just add a new entry + at the top. You can review the file at: + http://hackage.haskell.org/package/cabal-plan-0.7.1.0/src/ChangeLog.md + +------------------------------------------------------------------- Old: ---- cabal-plan-0.7.0.0.tar.gz cabal-plan.cabal New: ---- cabal-plan-0.7.1.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ cabal-plan.spec ++++++ --- /var/tmp/diff_new_pack.c5g5Kr/_old 2020-09-15 16:20:17.878137687 +0200 +++ /var/tmp/diff_new_pack.c5g5Kr/_new 2020-09-15 16:20:17.882137691 +0200 @@ -18,13 +18,12 @@ %global pkg_name cabal-plan Name: %{pkg_name} -Version: 0.7.0.0 +Version: 0.7.1.0 Release: 0 Summary: Library and utility for processing cabal's plan.json file License: GPL-2.0-or-later URL: https://hackage.haskell.org/package/%{name} Source0: https://hackage.haskell.org/package/%{name}-%{version}/%{name}-%{version}.tar.gz -Source1: https://hackage.haskell.org/package/%{name}-%{version}/revision/2.cabal#/%{name}.cabal BuildRequires: chrpath BuildRequires: ghc-Cabal-devel BuildRequires: ghc-aeson-devel @@ -99,8 +98,6 @@ %prep %autosetup -find . -type f -exec chmod -x {} + -cp -p %{SOURCE1} %{name}.cabal %build %ghc_lib_build ++++++ cabal-plan-0.7.0.0.tar.gz -> cabal-plan-0.7.1.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/cabal-plan-0.7.0.0/ChangeLog.md new/cabal-plan-0.7.1.0/ChangeLog.md --- old/cabal-plan-0.7.0.0/ChangeLog.md 2001-09-09 03:46:40.000000000 +0200 +++ new/cabal-plan-0.7.1.0/ChangeLog.md 2001-09-09 03:46:40.000000000 +0200 @@ -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) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/cabal-plan-0.7.0.0/cabal-plan.cabal new/cabal-plan-0.7.1.0/cabal-plan.cabal --- old/cabal-plan-0.7.0.0/cabal-plan.cabal 2001-09-09 03:46:40.000000000 +0200 +++ new/cabal-plan-0.7.1.0/cabal-plan.cabal 2001-09-09 03:46:40.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/cabal-plan-0.7.0.0/src-exe/CText.hs new/cabal-plan-0.7.1.0/src-exe/CText.hs --- old/cabal-plan-0.7.0.0/src-exe/CText.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/cabal-plan-0.7.1.0/src-exe/CText.hs 2001-09-09 03:46:40.000000000 +0200 @@ -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' diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/cabal-plan-0.7.0.0/src-exe/cabal-plan.hs new/cabal-plan-0.7.1.0/src-exe/cabal-plan.hs --- old/cabal-plan-0.7.0.0/src-exe/cabal-plan.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/cabal-plan-0.7.1.0/src-exe/cabal-plan.hs 2001-09-09 03:46:40.000000000 +0200 @@ -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) - -haveUnderlineSupport :: Bool -#if defined(UNDERLINE_SUPPORT) -haveUnderlineSupport = True -#else -haveUnderlineSupport = False -#endif +import Cabal.Plan +import CText +import LicenseReport (generateLicenseReport) +import Paths_cabal_plan (version) + 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 ++ "]" - - 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 + 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 = 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'
