From 444fa7349f370c1be0864b5134d34fc680f6b08d Mon Sep 17 00:00:00 2001 From: martoon Date: Tue, 12 Mar 2019 16:29:15 +0300 Subject: [PATCH] Add verification progress bar --- .crossref-verifier.yaml | 2 +- exec/Main.hs | 8 +++- package.yaml | 1 + src/Crv/Core.hs | 42 ++++++++++++++++- src/Crv/Progress.hs | 102 ++++++++++++++++++++++++++++++++++++++++ src/Crv/Scan.hs | 11 +++-- src/Crv/Verify.hs | 61 +++++++++++++++++------- 7 files changed, 204 insertions(+), 23 deletions(-) create mode 100644 src/Crv/Progress.hs diff --git a/.crossref-verifier.yaml b/.crossref-verifier.yaml index a86cf6b..a7a9231 100644 --- a/.crossref-verifier.yaml +++ b/.crossref-verifier.yaml @@ -4,7 +4,7 @@ traversal: excluded: - .stack-work - .github/pull_request_template.md - - .docs/pull_request_template.md + - docs/pull_request_template.md # Parameters of verification. verification: diff --git a/exec/Main.hs b/exec/Main.hs index 034012a..4a8a2a5 100644 --- a/exec/Main.hs +++ b/exec/Main.hs @@ -5,6 +5,7 @@ import Fmt (blockListF', build, fmt, fmtLn, indentF) import Crv.CLI import Crv.Config +import Crv.Progress import Crv.Scan import Crv.Scanners import Crv.Verify @@ -21,11 +22,14 @@ main = do config <- decodeFileEither oConfig >>= either (error . show) pure - repoInfo <- gatherRepoInfo formats (cTraversal config) root + repoInfo <- allowRewrite $ \rw -> + gatherRepoInfo rw formats (cTraversal config) root + when (cVerbose config) $ fmtLn $ "Repository data:\n\n" <> indentF 2 (build repoInfo) - verifyRes <- verifyRepo (cVerification config) root repoInfo + verifyRes <- allowRewrite $ \rw -> + verifyRepo rw (cVerification config) root repoInfo case verifyErrors verifyRes of Nothing -> fmtLn "All repository links are valid." diff --git a/package.yaml b/package.yaml index 0790851..22ca27a 100644 --- a/package.yaml +++ b/package.yaml @@ -46,6 +46,7 @@ build-tools: ghc-options: - -Wall + - -Wincomplete-record-updates dependencies: - aeson diff --git a/src/Crv/Core.hs b/src/Crv/Core.hs index f8e5150..6ae84bc 100644 --- a/src/Crv/Core.hs +++ b/src/Crv/Core.hs @@ -6,13 +6,15 @@ import Control.DeepSeq (NFData) import Control.Lens (makeLenses, (%=)) import Data.Char (isAlphaNum) import Data.Default (Default (..)) +import qualified Data.List as L import qualified Data.Map as M import qualified Data.Text as T import Fmt (Buildable (..), blockListF, blockListF', nameF, (+|), (|+)) import System.Console.Pretty (Color (..), Style (..), color, style) import Text.Numeral.Roman (toRoman) -import Crv.Util (paren) +import Crv.Progress +import Crv.Util ----------------------------------------------------------- -- Types @@ -133,6 +135,13 @@ instance Buildable LocationType where ExternalLoc -> color Red "external" OtherLoc -> "" +-- | Whether this is a link to external resource. +isExternal :: LocationType -> Bool +isExternal = \case + ExternalLoc -> True + _ -> False + + -- | Get type of reference. locationType :: Text -> LocationType locationType location = case toString location of @@ -155,3 +164,34 @@ headerToAnchor = T.replace " " "-" . T.replace "+" "-" . T.toLower + +----------------------------------------------------------- +-- Visualisation +----------------------------------------------------------- + +data VerifyProgress = VerifyProgress + { vrLocal :: !(Progress Int) + , vrExternal :: !(Progress Int) + } deriving (Show) + +initVerifyProgress :: RepoInfo -> VerifyProgress +initVerifyProgress (RepoInfo info) = + VerifyProgress + { vrLocal = initProgress (length localRefs) + , vrExternal = initProgress (length extRefs) + } + where + (extRefs, localRefs) = + L.partition isExternal $ + map locationType . map rLink . foldMap (_fiReferences) $ toList info + +showAnalyseProgress :: VerifyProgress -> Text +showAnalyseProgress VerifyProgress{..} = mconcat + [ "Verifying " + , showProgress "local" 10 White vrLocal + , " " + , showProgress "external" 15 Yellow vrExternal + ] + +reprintAnalyseProgress :: Rewrite -> VerifyProgress -> IO () +reprintAnalyseProgress rw p = putTextRewrite rw (showAnalyseProgress p) diff --git a/src/Crv/Progress.hs b/src/Crv/Progress.hs new file mode 100644 index 0000000..902e74c --- /dev/null +++ b/src/Crv/Progress.hs @@ -0,0 +1,102 @@ +-- | Printing progress bars. +module Crv.Progress + ( -- * Progress + Progress (..) + , initProgress + , incProgress + , incProgressErrors + , showProgress + + -- * Printing + , Rewrite + , allowRewrite + , putTextRewrite + ) where + +import Data.Ratio ((%)) +import GHC.IO.Handle.Text (hPutStr) +import System.Console.Pretty (Color (..), Style (..), color, style) +import Time (ms, threadDelay) + +----------------------------------------------------------- +-- Progress +----------------------------------------------------------- + +-- | Processing progress of any thing. +data Progress a = Progress + { pCurrent + -- ^ How much has been completed. + , pTotal + -- ^ Overall amount of work. + , pErrors :: !a + -- ^ How many of the completed work finished with an error. + } deriving (Show) + +-- | Initialise null progress. +initProgress :: Num a => a -> Progress a +initProgress a = Progress{ pTotal = a, pCurrent = 0, pErrors = 0 } + +-- | Increase progress amount. +incProgress :: (Num a, Show a) => Progress a -> Progress a +incProgress Progress{..} = Progress{ pCurrent = pCurrent + 1, .. } + +-- | Increase errors amount. +incProgressErrors :: (Num a, Show a) => Progress a -> Progress a +incProgressErrors Progress{..} = Progress{ pErrors = pErrors + 1, .. } + +-- | Visualise progress bar. +showProgress :: Text -> Int -> Color -> Progress Int -> Text +showProgress name width col Progress{..} = mconcat + [ color col (name <> ": [") + , toText bar + , color col "]" + , status + ] + where + done = floor $ (pCurrent % pTotal) * fromIntegral width + errs = ceiling $ (pErrors % pTotal) * fromIntegral width + done' = max 0 $ done - errs + remained' = width - errs - done' + bar | pTotal == 0 = replicate width '-' + | otherwise = mconcat + [ color Red $ replicate errs '■' + , color col $ replicate done' '■' + , color col $ replicate remained' ' ' + , " " + ] + status + | pTotal == 0 = "" + | pErrors == 0 = style Faint $ color White "✓" + | otherwise = color Red "!" + +----------------------------------------------------------- +-- Rewritable output +----------------------------------------------------------- + +-- | Dummy datatype which allows to return caret and replace text in line. +-- Only functions which has this thing can do that because being +-- interleaved with 'putTextLn' printing caret symbol produced garbage. +data Rewrite = Rewrite + { rMaxPrintedSize :: IORef Int + } + +-- | Provide context for rewrite operations. +allowRewrite :: (MonadIO m, MonadMask m) => (Rewrite -> m a) -> m a +allowRewrite action = + bracket prepare erase action + where + prepare = do + rMaxPrintedSize <- newIORef 0 + return Rewrite{..} + erase Rewrite{..} = liftIO $ do + maxPrintedSize <- readIORef rMaxPrintedSize + hPutStr stderr $ '\r' : replicate maxPrintedSize ' ' ++ "\r" + -- prevent our output to interleave with further outputs + threadDelay (ms 70) + +-- | Return caret and print the given text. +putTextRewrite :: MonadIO m => Rewrite -> Text -> m () +putTextRewrite Rewrite{..} msg = do + liftIO $ hPutStr stderr ('\r' : toString msg) + atomicModifyIORef' rMaxPrintedSize $ \maxPrinted -> + (max maxPrinted (length msg), ()) diff --git a/src/Crv/Scan.hs b/src/Crv/Scan.hs index 531fad5..9bbf4b7 100644 --- a/src/Crv/Scan.hs +++ b/src/Crv/Scan.hs @@ -12,11 +12,13 @@ module Crv.Scan import qualified Data.Foldable as F import qualified Data.Map as M +import GHC.Err (errorWithoutStackTrace) import qualified System.Directory.Tree as Tree import System.FilePath.Posix (takeDirectory, takeExtension, ()) import Crv.Config import Crv.Core +import Crv.Progress import Crv.Util () -- | File extension, dot included. @@ -39,8 +41,9 @@ specificFormatsSupport formats = \ext -> M.lookup ext formatsMap gatherRepoInfo :: MonadIO m - => FormatsSupport -> TraversalConfig -> FilePath -> m RepoInfo -gatherRepoInfo formatsSupport config root = do + => Rewrite -> FormatsSupport -> TraversalConfig -> FilePath -> m RepoInfo +gatherRepoInfo rw formatsSupport config root = do + putTextRewrite rw "Scanning repository..." _ Tree.:/ repoTree <- liftIO $ Tree.readDirectoryWithL processFile rootNE let fileInfos = filter (\(path, _) -> not $ isExcluded path) $ dropSndMaybes . F.toList $ @@ -66,4 +69,6 @@ gatherRepoInfo formatsSupport config root = do else map visitRec subfiles visitRec sub = filterExcludedDirs (cur Tree.name sub) sub in Tree.Dir name subfiles' - other -> other + file@Tree.File{} -> file + Tree.Failed _name err -> + errorWithoutStackTrace $ "Repository traversal failed: " <> show err diff --git a/src/Crv/Verify.hs b/src/Crv/Verify.hs index b5b5459..a5d0577 100644 --- a/src/Crv/Verify.hs +++ b/src/Crv/Verify.hs @@ -17,7 +17,7 @@ module Crv.Verify , checkExternalResource ) where -import Control.Concurrent.Async (Concurrently (..)) +import Control.Concurrent.Async (forConcurrently, withAsync) import Control.Monad.Except (ExceptT (..), MonadError (..)) import Data.Default (def) import qualified Data.Map as M @@ -32,10 +32,11 @@ import System.Console.Pretty (Style (..), style) import System.Directory (doesDirectoryExist, doesFileExist) import System.FilePath.Posix (takeDirectory) import System.FilePath.Posix (()) -import Time (RatioNat, Second, Time (..), timeout) +import Time (RatioNat, Second, Time (..), ms, threadDelay, timeout) import Crv.Config import Crv.Core +import Crv.Progress ----------------------------------------------------------- -- General verification @@ -107,23 +108,51 @@ instance Buildable CrvVerifyError where hs -> ", did you mean:\n" +| blockListF' " -" build hs verifyRepo - :: VerifyConfig + :: Rewrite + -> VerifyConfig -> FilePath -> RepoInfo -> IO (VerifyResult $ WithReferenceLoc CrvVerifyError) -verifyRepo config@VerifyConfig{..} root (RepoInfo repoInfo) = - runConcurrently $ - concatForM (M.toList repoInfo) $ \(file, fileInfo) -> - concatForM (_fiReferences fileInfo) $ \ref@Reference{..} -> - Concurrently $ - fmap (fmap $ WithReferenceLoc file ref) $ - case locationType rLink of - LocalLoc -> checkFileRef rAnchor file - RelativeLoc -> checkFileRef rAnchor - (takeDirectory file toString rLink) - AbsoluteLoc -> checkFileRef rAnchor (root <> toString rLink) - ExternalLoc -> checkExternalResource config rLink - OtherLoc -> verifying pass +verifyRepo rw config@VerifyConfig{..} root repoInfo'@(RepoInfo repoInfo) = do + progressRef <- newIORef $ initVerifyProgress repoInfo' + withAsync (printer progressRef) $ \_ -> + fmap fold . forConcurrently (M.toList repoInfo) $ \(file, fileInfo) -> + fmap fold . forConcurrently (_fiReferences fileInfo) $ \ref -> + verifyReference config progressRef repoInfo' root file ref + where + printer progressRef = forever $ do + readIORef progressRef >>= reprintAnalyseProgress rw + threadDelay (ms 100) + +verifyReference + :: VerifyConfig + -> IORef VerifyProgress + -> RepoInfo + -> FilePath + -> FilePath + -> Reference + -> IO (VerifyResult $ WithReferenceLoc CrvVerifyError) +verifyReference config@VerifyConfig{..} progressRef (RepoInfo repoInfo) + root containingFile ref@Reference{..} = do + res <- case locationType rLink of + LocalLoc -> checkFileRef rAnchor containingFile + RelativeLoc -> checkFileRef rAnchor + (takeDirectory containingFile toString rLink) + AbsoluteLoc -> checkFileRef rAnchor (root <> toString rLink) + ExternalLoc -> checkExternalResource config rLink + OtherLoc -> verifying pass + + let moveProgress = + incProgress . + (if verifyOk res then id else incProgressErrors) + + atomicModifyIORef' progressRef $ \VerifyProgress{..} -> + ( if isExternal (locationType rLink) + then VerifyProgress{ vrExternal = moveProgress vrExternal, .. } + else VerifyProgress{ vrLocal = moveProgress vrLocal, .. } + , () + ) + return $ fmap (WithReferenceLoc containingFile ref) res where checkFileRef mAnchor file = verifying $ do fileExists <- liftIO $ doesFileExist file