Add verification progress bar

.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:

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."

package.yaml

@@ -46,6 +46,7 @@ build-tools:
 
 ghc-options:
   - -Wall
+  - -Wincomplete-record-updates
 
 dependencies:
   - aeson

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)

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), ())

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

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