mirror of
https://github.com/serokell/xrefcheck.git
synced 2024-08-16 17:10:26 +03:00
Add verification progress bar
This commit is contained in:
parent
7b3f3b1bdd
commit
444fa7349f
@ -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:
|
||||
|
@ -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."
|
||||
|
@ -46,6 +46,7 @@ build-tools:
|
||||
|
||||
ghc-options:
|
||||
- -Wall
|
||||
- -Wincomplete-record-updates
|
||||
|
||||
dependencies:
|
||||
- aeson
|
||||
|
@ -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)
|
||||
|
102
src/Crv/Progress.hs
Normal file
102
src/Crv/Progress.hs
Normal file
@ -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), ())
|
@ -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
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user