[pkg-haskell-tools] 01/01: Fancy concurrent output
Joachim Breitner
nomeata at moszumanska.debian.org
Thu Jun 2 16:14:08 UTC 2016
This is an automated email from the git hooks/post-receive script.
nomeata pushed a commit to branch master
in repository pkg-haskell-tools.
commit 680177ab0ec6bf0e680ef673b09dbf6a8e99318b
Author: Joachim Breitner <mail at joachim-breitner.de>
Date: Thu Jun 2 15:22:24 2016 +0200
Fancy concurrent output
Looks good on the console.
---
.gitignore | 1 +
debian/changelog | 6 ++
debian/control | 2 +
dht.cabal | 8 +-
src/Development/Shake/Fancy.hs | 235 +++++++++++++++++++++++++++++++++++++++++
src/Utils.hs | 2 +-
src/make-all.hs | 81 ++++++++------
7 files changed, 298 insertions(+), 37 deletions(-)
diff --git a/.gitignore b/.gitignore
index e2ff01d..3fdfd72 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,4 +1,5 @@
debian/dht.1
+debian/.debhelper
dist/
debian/dht.html
dist-ghc/
diff --git a/debian/changelog b/debian/changelog
index 3a932e7..f2c08ab 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,9 @@
+pkg-haskell-tools (0.10.4) UNRELEASED; urgency=medium
+
+ * dht make-all: Fancy dynamic console output
+
+ -- Joachim Breitner <nomeata at debian.org> Thu, 02 Jun 2016 18:12:52 +0200
+
pkg-haskell-tools (0.10.3) unstable; urgency=medium
* dht upgrade: Minor improvements.
diff --git a/debian/control b/debian/control
index 3958791..22054da 100644
--- a/debian/control
+++ b/debian/control
@@ -22,6 +22,8 @@ Build-Depends: debhelper (>= 9),
libghc-text-dev,
libghc-missingh-dev (>= 1.3.0.1),
libghc-missingh-dev (<< 1.4),
+ libghc-concurrent-output-dev (>= 1.7),
+ libghc-concurrent-output-dev (<< 1.8),
libfile-slurp-perl
Standards-Version: 3.9.6
Homepage: https://wiki.debian.org/Haskell
diff --git a/dht.cabal b/dht.cabal
index 71fb693..514ce76 100644
--- a/dht.cabal
+++ b/dht.cabal
@@ -14,11 +14,14 @@ cabal-version: >=1.10
executable make-all
main-is: make-all.hs
- other-modules: Utils
+ other-modules:
+ Utils
+ Development.Shake.Fancy
build-depends:
base >=4.6 && <4.9,
containers,
directory,
+ transformers,
filepath,
time,
unix,
@@ -28,6 +31,7 @@ executable make-all
extra >= 1.1,
debian == 3.89.*,
optparse-applicative == 0.12.*,
- split == 0.2.*
+ split == 0.2.*,
+ concurrent-output == 1.7.*
hs-source-dirs: src
default-language: Haskell2010
diff --git a/src/Development/Shake/Fancy.hs b/src/Development/Shake/Fancy.hs
new file mode 100644
index 0000000..5bbbb49
--- /dev/null
+++ b/src/Development/Shake/Fancy.hs
@@ -0,0 +1,235 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds #-}
+module Development.Shake.Fancy
+ ( module Development.Shake
+
+ , cmdWrap
+
+ , shake
+ , shakeArgs
+ , Action
+ , action
+ , actionFinally
+ , putNormal
+ , putLoud
+ , (%>)
+ , (~>)
+ , writeFile'
+ , writeFileChanged
+ , need
+ , orderOnly
+ , readFileLines
+ , liftAction
+ , doesFileExist
+ , getDirectoryFiles
+ , askOracle
+ , addOracle
+ , addQuietOracle
+ , newCache
+ , alwaysRerun
+ , readFile'
+ , phonys
+ )
+ where
+
+import Development.Shake hiding
+ ( Action
+ , shake
+ , shakeArgs
+ , action
+ , actionFinally
+ , putNormal
+ , putLoud
+ , (%>)
+ , (~>)
+ , writeFile'
+ , writeFileChanged
+ , need
+ , orderOnly
+ , readFileLines
+ , doesFileExist
+ , getDirectoryFiles
+ , askOracle
+ , addOracle
+ , newCache
+ , alwaysRerun
+ , readFile'
+ , phonys
+ )
+import qualified Development.Shake as S
+import qualified Development.Shake.Rule as S
+import qualified Development.Shake.Classes as S
+import qualified Development.Shake.Command as S
+import System.Console.Concurrent
+import System.Console.Regions
+import Control.Monad.Trans.Reader
+import Control.Monad.IO.Class
+import Control.Monad
+import Control.Applicative
+import Data.List
+
+-- | Wrapper around 'S.shake'
+shake :: ShakeOptions -> Rules () -> IO ()
+shake opts rules = displayConsoleRegions $ S.shake opts rules
+
+-- | Wrapper around 'S.shakeArgs'
+shakeArgs :: ShakeOptions -> Rules () -> IO ()
+shakeArgs opts rules = displayConsoleRegions $ S.shakeArgs opts rules
+
+data FancyEnv = FancyEnv
+ { currentTarget :: String
+ , currentRegion :: ConsoleRegion
+ }
+
+-- | Wrapper around 'S.Action'
+newtype Action a = Action (ReaderT FancyEnv S.Action a)
+ deriving (Monad, Applicative, Functor, MonadIO)
+
+runAction :: Action a -> FancyEnv -> S.Action a
+runAction (Action fa) = runReaderT fa
+
+mkAction :: (FancyEnv -> S.Action a) -> Action a
+mkAction act = Action (ReaderT act)
+
+liftAction :: S.Action a -> Action a
+liftAction act = mkAction (const act)
+
+
+finish :: FancyEnv -> IO ()
+finish env = finishConsoleRegion (currentRegion env) $
+ "✓ " ++ currentTarget env ++ " done"
+
+wrapAction :: Action a -> String -> S.Action a
+wrapAction act target = do
+ region <- liftIO $ openConsoleRegion Linear
+ let env = FancyEnv target region
+ runAction act env `S.actionFinally` finish env
+
+-- Does not leave a ✓ line
+wrapSpuriousAction :: Action a -> String -> S.Action a
+wrapSpuriousAction act target = do
+ region <- liftIO $ openConsoleRegion Linear
+ let env = FancyEnv target region
+ runAction act env `S.actionFinally` closeConsoleRegion (currentRegion env)
+
+setDefaultMessage :: Action ()
+setDefaultMessage = mkAction $ \env ->
+ liftIO $ setConsoleRegion (currentRegion env) $
+ " " ++ currentTarget env ++ " processing..."
+
+setMessage :: Char -> String -> Action ()
+setMessage c doing = mkAction $ \env ->
+ liftIO $ setConsoleRegion (currentRegion env) $
+ [c] ++ " " ++ currentTarget env ++ " " ++ doing
+
+
+describe :: S.Action a -> Char -> String -> Action a
+describe act symb desc = do
+ setMessage symb desc
+ x <- liftAction act
+ setDefaultMessage
+ return x
+
+-- | Wrapper around 'S.action'
+action :: Action a -> Rules ()
+action act = S.action $ wrapAction act "some action"
+
+-- | Wrapper around 'S.actionFinally'
+actionFinally :: Action a -> IO b -> Action a
+actionFinally act io = mkAction $ \env -> runAction act env `S.actionFinally` io
+
+-- | Wrapper around 'S.putNormal'
+putNormal :: String -> Action ()
+putNormal txt = mkAction $ \env -> do
+ verb <- getVerbosity
+ when (Normal >= verb) $ liftIO $ outputConcurrent $ currentTarget env ++ ": " ++ txt
+
+-- | Wrapper around 'S.putLoud'
+putLoud :: String -> Action ()
+putLoud txt = mkAction $ \env -> do
+ verb <- getVerbosity
+ when (Loud >= verb) $ liftIO $ outputConcurrent $ currentTarget env ++ ": " ++ txt
+
+-- | Wrapper around '%>'
+(%>) :: FilePattern -> (FilePath -> Action ()) -> Rules ()
+pat %> act = pat S.%> (\out -> wrapAction (act out) out)
+infix 1 %>
+
+(~>) :: String -> Action () -> Rules ()
+target ~> act = target S.~> wrapAction act target
+infix 1 ~>
+
+
+-- | Wrapper around 'writeFile''
+writeFile' :: FilePath -> String -> Action ()
+writeFile' filepath content =
+ describe (S.writeFile' filepath content) '→' ("writing " ++ filepath)
+
+-- | Wrapper around 'writeFile''
+writeFileChanged :: FilePath -> String -> Action ()
+writeFileChanged filepath content =
+ describe (S.writeFileChanged filepath content) '→' ("writing " ++ filepath)
+
+readFileLines :: FilePath -> Action [String]
+readFileLines filepath =
+ describe (S.readFileLines filepath) '←' ("reading " ++ filepath)
+
+doesFileExist :: FilePath -> Action Bool
+doesFileExist filepath = liftAction $ S.doesFileExist filepath
+
+getDirectoryFiles :: FilePath -> [FilePattern] -> Action [FilePath]
+getDirectoryFiles dir pats = liftAction $ S.getDirectoryFiles dir pats
+
+need :: [FilePath] -> Action ()
+need filepaths =
+ describe (S.need filepaths) '…' ("waiting for " ++ showLongList filepaths)
+
+showLongList :: [String] -> String
+showLongList [] = "nothing"
+showLongList (x:xs) = x ++ go 60 xs
+ where
+ go remaining [] = ""
+ go remaining (x:xs)
+ | length x + 10 < remaining
+ = ", " ++ x ++ go (remaining - length x - 10) xs
+ | otherwise
+ = " and " ++ show (length (x:xs)) ++ " more"
+
+
+readFile' :: FilePath -> Action String
+readFile' x = need [x] >> liftIO (readFile x)
+
+orderOnly :: [FilePath] -> Action ()
+orderOnly filepaths =
+ describe (S.orderOnly filepaths) '…' ("waiting for " ++ showLongList filepaths)
+
+
+alwaysRerun :: Action ()
+alwaysRerun = liftAction S.alwaysRerun
+
+cmdWrap :: String -> S.Action a -> Action a
+cmdWrap cmd act =
+ describe (quietly act) '!' ("running " ++ cmd)
+
+askOracle :: (S.ShakeValue q, S.ShakeValue a) => q -> Action a
+askOracle query =
+ describe (S.askOracle query) '?' ("querying oracle " ++ show query)
+
+addOracle :: (S.ShakeValue q, S.ShakeValue a) => (q -> Action a) -> S.Rules (q -> Action a)
+addOracle action = do
+ query <- S.addOracle (\q -> wrapAction (action q) (show q))
+ return $ liftAction . query
+
+addQuietOracle :: (S.ShakeValue q, S.ShakeValue a) => (q -> Action a) -> S.Rules (q -> Action a)
+addQuietOracle action = do
+ query <- S.addOracle (\q -> wrapSpuriousAction (action q) (show q))
+ return $ liftAction . query
+
+newCache :: (Eq k, S.Hashable k) => (k -> Action v) -> Rules (k -> Action v)
+newCache cache = do
+ query <- S.newCache (\k -> wrapAction (cache k) "cache")
+ return $ liftAction . query
+
+phonys :: (String -> Maybe (Action ())) -> Rules ()
+phonys actions = S.phonys $ \name -> case actions name of
+ Just act -> Just $ wrapAction act "name"
+ Nothing -> Nothing
diff --git a/src/Utils.hs b/src/Utils.hs
index adea67f..50d6558 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -12,7 +12,7 @@ import System.FilePath
import Data.Char
import Data.Time.Clock
-import Development.Shake hiding (withTempDir)
+import Development.Shake.Fancy hiding (withTempDir)
-- This is copied from extra and shake sources, because they do not allow to
diff --git a/src/make-all.hs b/src/make-all.hs
index 06de1a9..588f6df 100644
--- a/src/make-all.hs
+++ b/src/make-all.hs
@@ -20,7 +20,8 @@ import Options.Applicative hiding (many)
import qualified Options.Applicative as O
import Options.Applicative.Types (readerAsk)
-import Development.Shake hiding (withTempDir)
+import Development.Shake.Fancy hiding (withTempDir)
+import qualified Development.Shake.Fancy as S
import Development.Shake.Classes
import Development.Shake.FilePath
@@ -174,10 +175,10 @@ splitDebName filename
ensureVersion :: String -> String -> Action ()
ensureVersion s v = do
ex <- doesFileExist $ "p" </> s </> "debian" </> "changelog"
- unless ex $ do
+ unless ex $
fail $ "I do not know about package " ++ s
v' <- versionOfSource s
- when (v /= v') $ do
+ when (v /= v') $
fail $ "Cannot build " ++ s ++ " version " ++ v ++ ", as we have " ++ v' ++ "."
ensureArch :: String -> Action ()
@@ -234,7 +235,7 @@ parseFlatRel = flatRels . parseRels
parseRels :: String -> Relations
parseRels s = case parseRelations s of
- Left pe -> error $ "Failed to parse relations " ++ (show pe)
+ Left pe -> error $ "Failed to parse relations " ++ show pe
Right rel -> rel
fixupScript :: [String] -> String
@@ -270,7 +271,9 @@ newtype GetExcludedSources = GetExcludedSources () deriving (Show,Typeable,Eq,Ha
newtype GetDebBuiltBy = GetDebBuiltBy String deriving (Show,Typeable,Eq,Hashable,Binary,NFData)
newtype GetBinToDeb = GetBinToDeb String deriving (Show,Typeable,Eq,Hashable,Binary,NFData)
-newtype GetArch = GetArch () deriving (Show,Typeable,Eq,Hashable,Binary,NFData)
+newtype GetArch = GetArch () deriving (Typeable,Eq,Hashable,Binary,NFData)
+
+instance Show GetArch where show (GetArch ()) = "querying architecture"
-- Find dependencies on binary packages we build ourselves.
-- This is needed, because those binary packages don't need to be
@@ -279,23 +282,26 @@ newtype GetArch = GetArch () deriving (Show,Typeable,Eq,Hashable,Binary,NFData)
-- Finding library packages isn't necessary, because they were already
-- built as a build-dependency.
extendBuildDepends :: FilePath -> (String -> Action (Maybe String)) -> [String] -> [String] -> Action [String]
-extendBuildDepends targetDir binToDeb ourBins buildDeps = (buildDeps ++) <$> concat <$> mapM ourDepends buildDeps
- where ourDepends dep = if dep `notElem` ourBins
- then do
- let debFile = targetDir </> dep
- need [debFile]
- Stdout depList <- cmd (Traced "")
- [ "dpkg-deb"
- , "--field"
- , debFile
- , "Depends"
- ]
- let depPkgs = map cleanDep $ splitOn "," depList
- depends <- catMaybes <$> mapM binToDeb depPkgs
- recursive <- extendBuildDepends targetDir binToDeb ourBins depends
- return $ depends ++ recursive
- else return []
- cleanDep = takeWhile (not . isSpace) . dropWhile isSpace
+extendBuildDepends targetDir binToDeb ourBins buildDeps = do
+ let notOurBin = map (targetDir </>) $ filter (`notElem` ourBins) buildDeps
+ -- First need all
+ need notOurBin
+ -- The look for additional dependencies
+ (buildDeps ++) <$> concat <$> mapM ourDepends notOurBin
+ where
+ ourDepends debFile = do
+ Stdout depList <- cmdWrap "dpkg-deb --field Depends" $ cmd
+ [ "dpkg-deb"
+ , "--field"
+ , debFile
+ , "Depends"
+ ]
+ let depPkgs = map cleanDep $ splitOn "," depList
+ depends <- catMaybes <$> mapM binToDeb depPkgs
+ recursive <- extendBuildDepends targetDir binToDeb ourBins depends
+ return $ depends ++ recursive
+
+ cleanDep = takeWhile (not . isSpace) . dropWhile isSpace
manpage :: String
manpage = unlines [ "TODO" ]
@@ -307,7 +313,7 @@ main = do
let failure = parserFailure (prefs idm) opts ShowHelpText mempty
let message = renderFailure failure "dht make-all"
putStrLn . unlines . drop 2 . lines . fst $ message
- _ -> do execParser opts >>= run
+ _ -> execParser opts >>= run
where
opts = info (helper <*> confSpec)
( fullDesc
@@ -358,7 +364,7 @@ shakeMain conf@(Conf {..}) sources = do
if null targets then want ["all"] else want targets
getArch' <- addOracle $ \GetArch{} -> do
- Stdout archString <- cmd
+ Stdout archString <- cmdWrap "schroot" $ cmd
[ "schroot"
, "-d", "/"
, "-c", schrootName
@@ -390,7 +396,7 @@ shakeMain conf@(Conf {..}) sources = do
| [deb,source] <- words <$> builtBy
]
- getDebBuiltBy <- addOracle $ \(GetDebBuiltBy bin) -> do
+ getDebBuiltBy <- addQuietOracle $ \(GetDebBuiltBy bin) -> do
map <- debBuiltByMap ()
return $ M.lookup bin map
@@ -405,7 +411,7 @@ shakeMain conf@(Conf {..}) sources = do
, let (pkgname,_,_) = splitDebName deb
]
- getBinToDeb <- addOracle $ \(GetBinToDeb bin) -> M.lookup bin <$> binToDebMap ()
+ getBinToDeb <- addQuietOracle $ \(GetBinToDeb bin) -> M.lookup bin <$> binToDebMap ()
let binToDeb :: String -> Action (Maybe String)
binToDeb = getBinToDeb . GetBinToDeb
@@ -419,7 +425,7 @@ shakeMain conf@(Conf {..}) sources = do
writeFileChanged out $ unlines $ map (flip (uncurry changesFileName) arch) versioned
targetDir </> "cache/binaries/*.txt" %> \out -> do
- let s = dropExtension $ takeFileName $ out
+ let s = dropExtension $ takeFileName out
putNormal $ "# enumerating binaries of " ++ show s
arch <- getArch
pkgs <- binaryPackagesOfSource s arch
@@ -436,7 +442,7 @@ shakeMain conf@(Conf {..}) sources = do
versioned <- forM sources $ \s -> do
v <- versionOfSource s
return (s,v)
- need $ [ targetDir </> sourceFileName s v | (s,v) <- versioned ]
+ need [ targetDir </> sourceFileName s v | (s,v) <- versioned ]
-- Binary packages depend on the corresponding changes file log
targetDir </> "*.deb" %> \out -> do
@@ -511,7 +517,10 @@ shakeMain conf@(Conf {..}) sources = do
let repoDir = tmpdir </> "repo"
liftIO $ createDirectory repoDir
forM_ localDebs $ \p -> liftIO $ linkOrCopyFile ("lab" </> p) (repoDir </> p)
- unit $ cmd (Cwd repoDir) (EchoStderr False) (FileStdout (repoDir </> "Packages"))
+ unit $ cmdWrap "dpkg-scanpackages" $ cmd
+ (Cwd repoDir)
+ (EchoStderr False)
+ (FileStdout (repoDir </> "Packages"))
["dpkg-scanpackages", "."]
-- Always pass the distribution in the changelog to sbuild, otherwise
@@ -522,7 +531,9 @@ shakeMain conf@(Conf {..}) sources = do
dist <- distributionOfSource source
-- Run sbuild
- Exit c <- cmd (Cwd targetDir) (EchoStdout False) $
+ Exit c <- cmdWrap "sbuild" $ cmd
+ (Cwd targetDir)
+ (EchoStdout False) $
["sbuild"
, "-c", schrootName
, "-A"
@@ -532,12 +543,13 @@ shakeMain conf@(Conf {..}) sources = do
, "--extra-repository=deb [trusted=yes] file://" ++ repoDir ++ " ./"
, dsc
] ++ sbuildArgs
- if (c == ExitSuccess)
- then do
+ if c == ExitSuccess
+ then
-- Add the sources to the changes file. We do not simply pass
-- "-s" to sbuild, as it would make sbuild re-create and override the .dsc file
-- which confuses the build system.
- unit $ cmd ["changestool", targetDir </> changes, "adddsc", targetDir </> dsc]
+ unit $ cmdWrap "changestool" $
+ cmd ["changestool", targetDir </> changes, "adddsc", targetDir </> dsc]
else do
putNormal $ "Failed to build " ++ source ++ "_" ++ version
ex <- liftIO $ System.Directory.doesFileExist out
@@ -551,7 +563,8 @@ shakeMain conf@(Conf {..}) sources = do
ensureVersion source version
sourceFiles <- getDirectoryFiles ("p" </> source) ["debian//*"]
need [ "p" </> source </> f | f <- sourceFiles]
- unit $ cmd (EchoStdout False) (Traced "debian2dsc") "dht" "debian2dsc" "-o" targetDir ("p" </> source </> "debian")
+ unit $ cmdWrap "debian2dsc" $ cmd (EchoStdout False)
+ "dht" "debian2dsc" "-o" targetDir ("p" </> source </> "debian")
phonys $ \source -> if source `elem` sources
then Just $ do
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-haskell/pkg-haskell-tools.git
More information about the Pkg-haskell-commits
mailing list