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
{ Progress a -> a
pCurrent :: a
, Progress a -> a
pTotal :: a
, Progress a -> a
pErrors :: !a
} deriving (Int -> Progress a -> ShowS
[Progress a] -> ShowS
Progress a -> String
(Int -> Progress a -> ShowS)
-> (Progress a -> String)
-> ([Progress a] -> ShowS)
-> Show (Progress a)
forall a. Show a => Int -> Progress a -> ShowS
forall a. Show a => [Progress a] -> ShowS
forall a. Show a => Progress a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Progress a] -> ShowS
$cshowList :: forall a. Show a => [Progress a] -> ShowS
show :: Progress a -> String
$cshow :: forall a. Show a => Progress a -> String
showsPrec :: Int -> Progress a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Progress a -> ShowS
Show)
initProgress :: Num a => a -> Progress a
initProgress :: a -> Progress a
initProgress a
a = Progress :: forall a. a -> a -> a -> Progress a
Progress{ pTotal :: a
pTotal = a
a, pCurrent :: a
pCurrent = a
0, pErrors :: a
pErrors = a
0 }
incProgress :: (Num a, Show a) => Progress a -> Progress a
incProgress :: Progress a -> Progress a
incProgress Progress{a
pErrors :: a
pTotal :: a
pCurrent :: a
pErrors :: forall a. Progress a -> a
pTotal :: forall a. Progress a -> a
pCurrent :: forall a. Progress a -> a
..} = Progress :: forall a. a -> a -> a -> Progress a
Progress{ pCurrent :: a
pCurrent = a
pCurrent a -> a -> a
forall a. Num a => a -> a -> a
+ a
1, a
pErrors :: a
pTotal :: a
pErrors :: a
pTotal :: a
.. }
incProgressErrors :: (Num a, Show a) => Progress a -> Progress a
incProgressErrors :: Progress a -> Progress a
incProgressErrors Progress{a
pErrors :: a
pTotal :: a
pCurrent :: a
pErrors :: forall a. Progress a -> a
pTotal :: forall a. Progress a -> a
pCurrent :: forall a. Progress a -> a
..} = Progress :: forall a. a -> a -> a -> Progress a
Progress{ pErrors :: a
pErrors = a
pErrors a -> a -> a
forall a. Num a => a -> a -> a
+ a
1, a
pTotal :: a
pCurrent :: a
pTotal :: a
pCurrent :: a
.. }
showProgress :: Text -> Int -> Color -> Progress Int -> Text
showProgress :: Text -> Int -> Color -> Progress Int -> Text
showProgress Text
name Int
width Color
col Progress{Int
pErrors :: Int
pTotal :: Int
pCurrent :: Int
pErrors :: forall a. Progress a -> a
pTotal :: forall a. Progress a -> a
pCurrent :: forall a. Progress a -> a
..} = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
[ Color -> Text -> Text
forall a. Pretty a => Color -> a -> a
color Color
col (Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": [")
, String -> Text
forall a. ToText a => a -> Text
toText String
bar
, Color -> Text -> Text
forall a. Pretty a => Color -> a -> a
color Color
col Text
"]"
, Text
status
]
where
done :: Int
done = Ratio Int -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (Ratio Int -> Int) -> Ratio Int -> Int
forall a b. (a -> b) -> a -> b
$ (Int
pCurrent Int -> Int -> Ratio Int
forall a. Integral a => a -> a -> Ratio a
% Int
pTotal) Ratio Int -> Ratio Int -> Ratio Int
forall a. Num a => a -> a -> a
* Int -> Ratio Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
width
errs :: Int
errs = Ratio Int -> Int
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Ratio Int -> Int) -> Ratio Int -> Int
forall a b. (a -> b) -> a -> b
$ (Int
pErrors Int -> Int -> Ratio Int
forall a. Integral a => a -> a -> Ratio a
% Int
pTotal) Ratio Int -> Ratio Int -> Ratio Int
forall a. Num a => a -> a -> a
* Int -> Ratio Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
width
done' :: Int
done' = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
done Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
errs
remained' :: Int
remained' = Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
errs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
done'
bar :: String
bar | Int
pTotal Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
width Char
'-'
| Bool
otherwise = [String] -> String
forall a. Monoid a => [a] -> a
mconcat
[ Color -> ShowS
forall a. Pretty a => Color -> a -> a
color Color
Red ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
errs Char
'■'
, Color -> ShowS
forall a. Pretty a => Color -> a -> a
color Color
col ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
done' Char
'■'
, Color -> ShowS
forall a. Pretty a => Color -> a -> a
color Color
col ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
remained' Char
' '
, String
" "
]
status :: Text
status
| Int
pTotal Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Text
""
| Int
pErrors Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Style -> Text -> Text
forall a. Pretty a => Style -> a -> a
style Style
Faint (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Color -> Text -> Text
forall a. Pretty a => Color -> a -> a
color Color
White Text
"✓"
| Bool
otherwise = Color -> Text -> Text
forall a. Pretty a => Color -> a -> a
color Color
Red Text
"!"
data RewriteCtx = RewriteCtx
{ RewriteCtx -> IORef Int
rMaxPrintedSize :: IORef Int
}
data Rewrite
= Rewrite RewriteCtx
| RewriteDisabled
allowRewrite :: (MonadIO m, MonadMask m) => Bool -> (Rewrite -> m a) -> m a
allowRewrite :: Bool -> (Rewrite -> m a) -> m a
allowRewrite Bool
enabled Rewrite -> m a
action =
m Rewrite -> (Rewrite -> m ()) -> (Rewrite -> m a) -> m a
forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket m Rewrite
prepare Rewrite -> m ()
forall (m :: * -> *). MonadIO m => Rewrite -> m ()
erase Rewrite -> m a
action
where
prepare :: m Rewrite
prepare
| Bool
enabled = do
IORef Int
rMaxPrintedSize <- Int -> m (IORef Int)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Int
0
Rewrite -> m Rewrite
forall (m :: * -> *) a. Monad m => a -> m a
return (Rewrite -> m Rewrite) -> Rewrite -> m Rewrite
forall a b. (a -> b) -> a -> b
$ RewriteCtx -> Rewrite
Rewrite RewriteCtx :: IORef Int -> RewriteCtx
RewriteCtx{IORef Int
rMaxPrintedSize :: IORef Int
rMaxPrintedSize :: IORef Int
..}
| Bool
otherwise =
Rewrite -> m Rewrite
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rewrite
RewriteDisabled
erase :: Rewrite -> m ()
erase (Rewrite RewriteCtx{IORef Int
rMaxPrintedSize :: IORef Int
rMaxPrintedSize :: RewriteCtx -> IORef Int
..}) = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
Int
maxPrintedSize <- IORef Int -> IO Int
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef Int
rMaxPrintedSize
Handle -> String -> IO ()
forall a (m :: * -> *). (Print a, MonadIO m) => Handle -> a -> m ()
hPutStr Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Char
'\r' Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
maxPrintedSize Char
' ' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\r"
Time (1 :% 1000) -> IO ()
forall (unit :: Rat) (m :: * -> *).
(KnownDivRat unit Microsecond, MonadIO m) =>
Time unit -> m ()
threadDelay (RatioNat -> Time Millisecond
ms RatioNat
100)
erase Rewrite
RewriteDisabled = m ()
forall (f :: * -> *). Applicative f => f ()
pass
putTextRewrite :: MonadIO m => Rewrite -> Text -> m ()
putTextRewrite :: Rewrite -> Text -> m ()
putTextRewrite (Rewrite RewriteCtx{IORef Int
rMaxPrintedSize :: IORef Int
rMaxPrintedSize :: RewriteCtx -> IORef Int
..}) Text
msg = do
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
forall a (m :: * -> *). (Print a, MonadIO m) => Handle -> a -> m ()
hPutStr Handle
stderr (Char
'\r' Char -> ShowS
forall a. a -> [a] -> [a]
: Text -> String
forall a. ToString a => a -> String
toString Text
msg)
IORef Int -> (Int -> (Int, ())) -> m ()
forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef Int
rMaxPrintedSize ((Int -> (Int, ())) -> m ()) -> (Int -> (Int, ())) -> m ()
forall a b. (a -> b) -> a -> b
$ \Int
maxPrinted ->
(Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
maxPrinted (Text -> Int
forall t. Container t => t -> Int
length Text
msg), ())
putTextRewrite Rewrite
RewriteDisabled Text
_ = m ()
forall (f :: * -> *). Applicative f => f ()
pass