{- SPDX-FileCopyrightText: 2019 Serokell <https://serokell.io>
 -
 - SPDX-License-Identifier: MPL-2.0
 -}

-- | Printing progress bars.
module Xrefcheck.Progress
    ( -- * Progress
      Progress (..)
    , initProgress
    , incProgress
    , incProgressErrors
    , showProgress

      -- * Printing
    , Rewrite
    , allowRewrite
    , putTextRewrite
    ) where

import Data.Ratio ((%))
import System.Console.Pretty (Color (..), Style (..), color, style)
import Time (ms, threadDelay)

-----------------------------------------------------------
-- Progress
-----------------------------------------------------------

-- | Processing progress of any thing.
data Progress a = Progress
    { Progress a -> a
pCurrent :: a
      -- ^ How much has been completed.
    , Progress a -> a
pTotal   :: a
      -- ^ Overall amount of work.
    , Progress a -> a
pErrors  :: !a
      -- ^ How many of the completed work finished with an error.
    } 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)

-- | Initialise null progress.
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 }

-- | Increase progress amount.
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
.. }

-- | Increase errors amount.
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
.. }

-- | Visualise progress bar.
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
"!"

-----------------------------------------------------------
-- Rewritable output
-----------------------------------------------------------

-- | Rewrites state.
data RewriteCtx = RewriteCtx
    { RewriteCtx -> IORef Int
rMaxPrintedSize :: IORef Int
    }

-- | Passing this object allows returning 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 RewriteCtx
    -- ^ Default value.
  | RewriteDisabled
    -- ^ Do not print anything which will be rewritten.
    -- Useful when terminal does not interpret caret returns as expected.

-- | Provide context for rewrite operations.
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"
        -- prevent our output to interleave with further outputs
        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

-- | Return caret and print the given text.
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