module Xrefcheck.Progress
(
Progress (..)
, initProgress
, incProgress
, incProgressErrors
, showProgress
, Rewrite
, allowRewrite
, putTextRewrite
) where
import Data.Ratio ((%))
import System.Console.Pretty (Color (..), Style (..), color, style)
import Time (ms, threadDelay)
data Progress a = Progress
{ pCurrent :: a
, pTotal :: a
, pErrors :: !a
} deriving (Show)
initProgress :: Num a => a -> Progress a
initProgress a = Progress{ pTotal = a, pCurrent = 0, pErrors = 0 }
incProgress :: (Num a, Show a) => Progress a -> Progress a
incProgress Progress{..} = Progress{ pCurrent = pCurrent + 1, .. }
incProgressErrors :: (Num a, Show a) => Progress a -> Progress a
incProgressErrors Progress{..} = Progress{ pErrors = pErrors + 1, .. }
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 "!"
data RewriteCtx = RewriteCtx
{ rMaxPrintedSize :: IORef Int
}
data Rewrite
= Rewrite RewriteCtx
| RewriteDisabled
allowRewrite :: (MonadIO m, MonadMask m) => Bool -> (Rewrite -> m a) -> m a
allowRewrite enabled action =
bracket prepare erase action
where
prepare
| enabled = do
rMaxPrintedSize <- newIORef 0
return $ Rewrite RewriteCtx{..}
| otherwise =
pure RewriteDisabled
erase (Rewrite RewriteCtx{..}) = liftIO $ do
maxPrintedSize <- readIORef rMaxPrintedSize
hPutStr stderr $ '\r' : replicate maxPrintedSize ' ' ++ "\r"
threadDelay (ms 100)
erase RewriteDisabled = pass
putTextRewrite :: MonadIO m => Rewrite -> Text -> m ()
putTextRewrite (Rewrite RewriteCtx{..}) msg = do
liftIO $ hPutStr stderr ('\r' : toString msg)
atomicModifyIORef' rMaxPrintedSize $ \maxPrinted ->
(max maxPrinted (length msg), ())
putTextRewrite RewriteDisabled _ = pass