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

-- | Printing progress bars.
module Xrefcheck.Progress
  ( -- * Task timestamp
    TaskTimestamp (..)

    -- * Progress
  , Progress
  , initProgress
  , initProgressWitnessed
  , reportSuccess
  , reportError
  , reportRetry
  , getTaskTimestamp
  , setTaskTimestamp
  , removeTaskTimestamp
  , checkTaskTimestamp
  , sameProgress
  , showProgress

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

import Universum

import Data.Ratio ((%))
import Data.Reflection (Given)
import Data.Set qualified as S
import Time (Second, Time, sec, unTime, (-:-))

import Xrefcheck.Util

-----------------------------------------------------------
-- Task timestamp
-----------------------------------------------------------

-- | Data type defining a point in time when an anonymous task had started
-- and its time to completion.
data TaskTimestamp = TaskTimestamp
  { TaskTimestamp -> Time Second
ttTimeToCompletion :: Time Second
    -- ^ The amount of time required for the task to be completed.
  , TaskTimestamp -> Time Second
ttStart :: Time Second
    -- ^ The timestamp of when the task had started, represented by the number of seconds
    -- since the Unix epoch.
  } deriving stock (Int -> TaskTimestamp -> ShowS
[TaskTimestamp] -> ShowS
TaskTimestamp -> String
(Int -> TaskTimestamp -> ShowS)
-> (TaskTimestamp -> String)
-> ([TaskTimestamp] -> ShowS)
-> Show TaskTimestamp
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TaskTimestamp -> ShowS
showsPrec :: Int -> TaskTimestamp -> ShowS
$cshow :: TaskTimestamp -> String
show :: TaskTimestamp -> String
$cshowList :: [TaskTimestamp] -> ShowS
showList :: [TaskTimestamp] -> ShowS
Show)

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

-- | Processing progress of any thing, measured with type @a@, where progress units have witnesses
-- of type @w@ that can be retried.
--
-- The () type can be used as a trivial witness if the retry logic is not going to be used.
data Progress a w = Progress
  { forall a w. Progress a w -> a
pTotal :: !a
    -- ^ Overall amount of work.
  , forall a w. Progress a w -> a
pSuccess :: !a
    -- ^ How much has been completed with success.
  , forall a w. Progress a w -> a
pError :: !a
    -- ^ How much has been completed with error.
  , forall a w. Progress a w -> Set w
pRetrying :: !(S.Set w)
    -- ^ Witnesses of items that have been completed with error but are being retried.
  , forall a w. Progress a w -> Maybe TaskTimestamp
pTaskTimestamp :: !(Maybe TaskTimestamp)
    -- ^ A timestamp of an anonymous timer task, where its time to completion is
    -- the time needed to pass for the action to be retried immediately after.
  } deriving stock (Int -> Progress a w -> ShowS
[Progress a w] -> ShowS
Progress a w -> String
(Int -> Progress a w -> ShowS)
-> (Progress a w -> String)
-> ([Progress a w] -> ShowS)
-> Show (Progress a w)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a w. (Show a, Show w) => Int -> Progress a w -> ShowS
forall a w. (Show a, Show w) => [Progress a w] -> ShowS
forall a w. (Show a, Show w) => Progress a w -> String
$cshowsPrec :: forall a w. (Show a, Show w) => Int -> Progress a w -> ShowS
showsPrec :: Int -> Progress a w -> ShowS
$cshow :: forall a w. (Show a, Show w) => Progress a w -> String
show :: Progress a w -> String
$cshowList :: forall a w. (Show a, Show w) => [Progress a w] -> ShowS
showList :: [Progress a w] -> ShowS
Show)

-- | Initialise null progress.
initProgress :: Num a => a -> Progress a w
initProgress :: forall a w. Num a => a -> Progress a w
initProgress a
a = Progress
  { pTotal :: a
pTotal = a
a
  , pSuccess :: a
pSuccess = a
0
  , pError :: a
pError = a
0
  , pRetrying :: Set w
pRetrying = Set w
forall a. Set a
S.empty
  , pTaskTimestamp :: Maybe TaskTimestamp
pTaskTimestamp = Maybe TaskTimestamp
forall a. Maybe a
Nothing
  }

-- | Initialise null progress from a given list of witnesses.
--
-- This just initializes it with as many work to do as witnesses are in the list, so you can be
-- more confident regarding the progress initialization because you actualy provided data that
-- represents each unit of work to do.
initProgressWitnessed :: [w] -> Progress Int w
initProgressWitnessed :: forall w. [w] -> Progress Int w
initProgressWitnessed [w]
ws = Progress
  { pTotal :: Int
pTotal = [w] -> Int
forall t. Container t => t -> Int
length [w]
ws
  , pSuccess :: Int
pSuccess = Int
0
  , pError :: Int
pError = Int
0
  , pRetrying :: Set w
pRetrying = Set w
forall a. Set a
S.empty
  , pTaskTimestamp :: Maybe TaskTimestamp
pTaskTimestamp = Maybe TaskTimestamp
forall a. Maybe a
Nothing
  }

-- | Report a unit of success with witness @item@.
reportSuccess :: (Num a, Ord w) => w -> Progress a w -> Progress a w
reportSuccess :: forall a w. (Num a, Ord w) => w -> Progress a w -> Progress a w
reportSuccess w
item Progress{a
Maybe TaskTimestamp
Set w
pTotal :: forall a w. Progress a w -> a
pSuccess :: forall a w. Progress a w -> a
pError :: forall a w. Progress a w -> a
pRetrying :: forall a w. Progress a w -> Set w
pTaskTimestamp :: forall a w. Progress a w -> Maybe TaskTimestamp
pTotal :: a
pSuccess :: a
pError :: a
pRetrying :: Set w
pTaskTimestamp :: Maybe TaskTimestamp
..} = Progress
  { pSuccess :: a
pSuccess = a
pSuccess a -> a -> a
forall a. Num a => a -> a -> a
+ a
1
  , pRetrying :: Set w
pRetrying = w -> Set w -> Set w
forall a. Ord a => a -> Set a -> Set a
S.delete w
item Set w
pRetrying
  , a
Maybe TaskTimestamp
pTotal :: a
pError :: a
pTaskTimestamp :: Maybe TaskTimestamp
pTotal :: a
pError :: a
pTaskTimestamp :: Maybe TaskTimestamp
..
  }

-- | Report a unit of failure with witness @item@.
reportError :: (Num a, Ord w) => w -> Progress a w -> Progress a w
reportError :: forall a w. (Num a, Ord w) => w -> Progress a w -> Progress a w
reportError w
item Progress{a
Maybe TaskTimestamp
Set w
pTotal :: forall a w. Progress a w -> a
pSuccess :: forall a w. Progress a w -> a
pError :: forall a w. Progress a w -> a
pRetrying :: forall a w. Progress a w -> Set w
pTaskTimestamp :: forall a w. Progress a w -> Maybe TaskTimestamp
pTotal :: a
pSuccess :: a
pError :: a
pRetrying :: Set w
pTaskTimestamp :: Maybe TaskTimestamp
..} = Progress
  { pError :: a
pError = a
pError a -> a -> a
forall a. Num a => a -> a -> a
+ a
1
  , pRetrying :: Set w
pRetrying = w -> Set w -> Set w
forall a. Ord a => a -> Set a -> Set a
S.delete w
item Set w
pRetrying
  , a
Maybe TaskTimestamp
pTotal :: a
pSuccess :: a
pTaskTimestamp :: Maybe TaskTimestamp
pTotal :: a
pSuccess :: a
pTaskTimestamp :: Maybe TaskTimestamp
..
  }

-- | Report a unit of failure and retry intention with witness @item@.
reportRetry :: Ord w => w -> Progress a w -> Progress a w
reportRetry :: forall w a. Ord w => w -> Progress a w -> Progress a w
reportRetry w
item Progress{a
Maybe TaskTimestamp
Set w
pTotal :: forall a w. Progress a w -> a
pSuccess :: forall a w. Progress a w -> a
pError :: forall a w. Progress a w -> a
pRetrying :: forall a w. Progress a w -> Set w
pTaskTimestamp :: forall a w. Progress a w -> Maybe TaskTimestamp
pTotal :: a
pSuccess :: a
pError :: a
pRetrying :: Set w
pTaskTimestamp :: Maybe TaskTimestamp
..} = Progress
  { pRetrying :: Set w
pRetrying = w -> Set w -> Set w
forall a. Ord a => a -> Set a -> Set a
S.insert w
item Set w
pRetrying
  , a
Maybe TaskTimestamp
pTotal :: a
pSuccess :: a
pError :: a
pTaskTimestamp :: Maybe TaskTimestamp
pTotal :: a
pSuccess :: a
pError :: a
pTaskTimestamp :: Maybe TaskTimestamp
..
  }

-- | Set the current `TaskTimestamp`.
--
-- It does require a witness because, although the `TaskTimestamp` is
-- anonymous, at this point an actual task should be responsible for
-- registering this timestamp.
setTaskTimestamp :: w -> Time Second -> Time Second -> Progress a w -> Progress a w
setTaskTimestamp :: forall w a.
w -> Time Second -> Time Second -> Progress a w -> Progress a w
setTaskTimestamp w
_ Time Second
ttc Time Second
startTime Progress{a
Maybe TaskTimestamp
Set w
pTotal :: forall a w. Progress a w -> a
pSuccess :: forall a w. Progress a w -> a
pError :: forall a w. Progress a w -> a
pRetrying :: forall a w. Progress a w -> Set w
pTaskTimestamp :: forall a w. Progress a w -> Maybe TaskTimestamp
pTotal :: a
pSuccess :: a
pError :: a
pRetrying :: Set w
pTaskTimestamp :: Maybe TaskTimestamp
..} = Progress
  { pTaskTimestamp :: Maybe TaskTimestamp
pTaskTimestamp = TaskTimestamp -> Maybe TaskTimestamp
forall a. a -> Maybe a
Just (Time Second -> Time Second -> TaskTimestamp
TaskTimestamp Time Second
ttc Time Second
startTime)
  , a
Set w
pTotal :: a
pSuccess :: a
pError :: a
pRetrying :: Set w
pTotal :: a
pSuccess :: a
pError :: a
pRetrying :: Set w
..
  }

-- | Get the current `TaskTimestamp`.
--
-- It does not require a witness because the `TaskTimestamp` is anonymous
-- and anyone should be able to observe it.
getTaskTimestamp :: Progress a w -> Maybe TaskTimestamp
getTaskTimestamp :: forall a w. Progress a w -> Maybe TaskTimestamp
getTaskTimestamp = Progress a w -> Maybe TaskTimestamp
forall a w. Progress a w -> Maybe TaskTimestamp
pTaskTimestamp

removeTaskTimestamp :: Progress a w -> Progress a w
removeTaskTimestamp :: forall a w. Progress a w -> Progress a w
removeTaskTimestamp Progress{a
Maybe TaskTimestamp
Set w
pTotal :: forall a w. Progress a w -> a
pSuccess :: forall a w. Progress a w -> a
pError :: forall a w. Progress a w -> a
pRetrying :: forall a w. Progress a w -> Set w
pTaskTimestamp :: forall a w. Progress a w -> Maybe TaskTimestamp
pTotal :: a
pSuccess :: a
pError :: a
pRetrying :: Set w
pTaskTimestamp :: Maybe TaskTimestamp
..} = Progress
  { pTaskTimestamp :: Maybe TaskTimestamp
pTaskTimestamp = Maybe TaskTimestamp
forall a. Maybe a
Nothing
  , a
Set w
pTotal :: a
pSuccess :: a
pError :: a
pRetrying :: Set w
pTotal :: a
pSuccess :: a
pError :: a
pRetrying :: Set w
..
  }

checkTaskTimestamp :: Time Second -> Progress a w -> Progress a w
checkTaskTimestamp :: forall a w. Time Second -> Progress a w -> Progress a w
checkTaskTimestamp Time Second
posixTime p :: Progress a w
p@Progress{a
Maybe TaskTimestamp
Set w
pTotal :: forall a w. Progress a w -> a
pSuccess :: forall a w. Progress a w -> a
pError :: forall a w. Progress a w -> a
pRetrying :: forall a w. Progress a w -> Set w
pTaskTimestamp :: forall a w. Progress a w -> Maybe TaskTimestamp
pTotal :: a
pSuccess :: a
pError :: a
pRetrying :: Set w
pTaskTimestamp :: Maybe TaskTimestamp
..} =
  case Maybe TaskTimestamp
pTaskTimestamp of
    Maybe TaskTimestamp
Nothing -> Progress a w
p
    Just TaskTimestamp{Time Second
ttTimeToCompletion :: TaskTimestamp -> Time Second
ttStart :: TaskTimestamp -> Time Second
ttTimeToCompletion :: Time Second
ttStart :: Time Second
..} ->
      if Time Second
Time (1 :% 1)
ttTimeToCompletion Time (1 :% 1) -> Time (1 :% 1) -> Bool
forall a. Ord a => a -> a -> Bool
>= Time Second
Time (1 :% 1)
posixTime Time (1 :% 1) -> Time (1 :% 1) -> Time (1 :% 1)
forall (unitResult :: Rat) (unitLeft :: Rat).
KnownDivRat unitLeft unitResult =>
Time unitLeft -> Time unitResult -> Time unitResult
-:- Time Second
Time (1 :% 1)
ttStart
      then Progress a w
p
      else Progress a w -> Progress a w
forall a w. Progress a w -> Progress a w
removeTaskTimestamp Progress a w
p

-- | Check whether the two @Progress@ values are equal up to similarity of their essential
-- components, ignoring the comparison of @pTaskTimestamp@s, which is done to prevent test
-- failures when comparing the resulting progress, gotten from running the link
-- verification algorithm, with the expected one, where @pTaskTimestamp@ is hardcoded
-- as @Nothing@.
sameProgress :: (Eq a, Eq w) => Progress a w -> Progress a w -> Bool
sameProgress :: forall a w. (Eq a, Eq w) => Progress a w -> Progress a w -> Bool
sameProgress Progress a w
p1 Progress a w
p2 = [Bool] -> Bool
forall t. (Container t, Element t ~ Bool) => t -> Bool
and
  [ (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(==) (a -> a -> Bool)
-> (Progress a w -> a) -> Progress a w -> Progress a w -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Progress a w -> a
forall a w. Progress a w -> a
pTotal) Progress a w
p1 Progress a w
p2
  , (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(==) (a -> a -> Bool)
-> (Progress a w -> a) -> Progress a w -> Progress a w -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Progress a w -> a
forall a w. Progress a w -> a
pSuccess) Progress a w
p1 Progress a w
p2
  , (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(==) (a -> a -> Bool)
-> (Progress a w -> a) -> Progress a w -> Progress a w -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Progress a w -> a
forall a w. Progress a w -> a
pError) Progress a w
p1 Progress a w
p2
  , (Set w -> Set w -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Set w -> Set w -> Bool)
-> (Progress a w -> Set w) -> Progress a w -> Progress a w -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Progress a w -> Set w
forall a w. Progress a w -> Set w
pRetrying) Progress a w
p1 Progress a w
p2
  ]

-- | Visualise progress bar.
showProgress :: Given ColorMode => Text -> Int -> Color -> Time Second -> Progress Int w -> Text
showProgress :: forall w.
Given ColorMode =>
Text -> Int -> Color -> Time Second -> Progress Int w -> Text
showProgress Text
name Int
width Color
col Time Second
posixTime Progress{Int
Maybe TaskTimestamp
Set w
pTotal :: forall a w. Progress a w -> a
pSuccess :: forall a w. Progress a w -> a
pError :: forall a w. Progress a w -> a
pRetrying :: forall a w. Progress a w -> Set w
pTaskTimestamp :: forall a w. Progress a w -> Maybe TaskTimestamp
pTotal :: Int
pSuccess :: Int
pError :: Int
pRetrying :: Set w
pTaskTimestamp :: Maybe TaskTimestamp
..} = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
  [ Color -> Text -> Text
forall a. (Pretty a, Given ColorMode) => Color -> a -> a
colorIfNeeded 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
  , Text
timer
  , Color -> Text -> Text
forall a. (Pretty a, Given ColorMode) => Color -> a -> a
colorIfNeeded Color
col Text
"]"
  , Text
status
  ]
  where
    -- Each of the following values represents the number of the progress bar cells
    -- corresponding to the respective "class" of processed references: the valid ones,
    -- the ones containing an unfixable error (a.k.a. the invalid ones), and the ones
    -- containing a fixable error.
    --
    -- The current overall number of proccessed errors.
    done :: Int
done = Ratio Int -> Int
forall b. Integral b => Ratio Int -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Ratio Int -> Int) -> Ratio Int -> Int
forall a b. (a -> b) -> a -> b
$ (Int
current 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
* forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int @(Ratio Int) Int
width

    -- The current number of the invalid references.
    errsU :: Int
errsU = Ratio Int -> Int
forall b. Integral b => Ratio Int -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Ratio Int -> Int) -> Ratio Int -> Int
forall a b. (a -> b) -> a -> b
$ (Int
pError 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
* forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int @(Ratio Int) Int
width

    -- The current number of (fixable) errors that may be eliminated during further
    -- verification.
    -- Notice!
    --   1. Both this and the previous values use @ceiling@ as the rounding function.
    --      This is done to ensure that as soon as at least 1 faulty reference occurs during
    --      the verification, the cell of its respective color is mathematically guaranteed
    --      to be visible in the progress bar visualization.
    --   2. @errsF@ is bounded from above by @width - errsU@ to prevent an overflow in the
    --      number of the progress bar cells that could be caused by the two @ceilings@s.
    errsF :: Int
errsF = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
errsU) (Int -> Int) -> (Ratio Int -> Int) -> Ratio Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ratio Int -> Int
forall b. Integral b => Ratio Int -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Ratio Int -> Int) -> Ratio Int -> Int
forall a b. (a -> b) -> a -> b
$ (Int
fixable 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
*
      forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int @(Ratio Int) Int
width

    -- The number of valid references.
    -- The value is bounded from below by 0 to ensure the number never gets negative.
    -- This situation is plausible due to the different rounding functions used for each value:
    -- @floor@ for the minuend @done@, @ceiling@ for the two subtrahends @errsU@ & @errsF@.
    successful :: Int
successful = 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
errsU Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
errsF

    -- The remaining number of references to be verified.
    remaining :: Int
remaining = Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
successful Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
errsU Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
errsF

    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, Given ColorMode) => Color -> a -> a
colorIfNeeded Color
Blue ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
errsF Char
'■'
          , Color -> ShowS
forall a. (Pretty a, Given ColorMode) => Color -> a -> a
colorIfNeeded Color
Red ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
errsU Char
'■'
          , Color -> ShowS
forall a. (Pretty a, Given ColorMode) => Color -> a -> a
colorIfNeeded Color
col ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
successful Char
'■'
          , Color -> ShowS
forall a. (Pretty a, Given ColorMode) => Color -> a -> a
colorIfNeeded Color
col ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
remaining Char
' '
          , String
" "
          ]
    timer :: Text
timer = case Maybe TaskTimestamp
pTaskTimestamp of
      Maybe TaskTimestamp
Nothing -> Text
""
      Just TaskTimestamp{Time Second
ttTimeToCompletion :: TaskTimestamp -> Time Second
ttStart :: TaskTimestamp -> Time Second
ttTimeToCompletion :: Time Second
ttStart :: Time Second
..} -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
        [ Color -> Text -> Text
forall a. (Pretty a, Given ColorMode) => Color -> a -> a
colorIfNeeded Color
col Text
"|"
        , Color -> Text -> Text
forall a. (Pretty a, Given ColorMode) => Color -> a -> a
colorIfNeeded Color
Blue (Text -> Text) -> (Time (1 :% 1) -> Text) -> Time (1 :% 1) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Time (1 :% 1) -> Text
forall b a. (Show a, IsString b) => a -> b
show (Time (1 :% 1) -> Text)
-> (Time (1 :% 1) -> Time (1 :% 1)) -> Time (1 :% 1) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Time Second -> Time Second
Time (1 :% 1) -> Time (1 :% 1)
timeSecondCeiling
        (Time (1 :% 1) -> Text) -> Time (1 :% 1) -> Text
forall a b. (a -> b) -> a -> b
$ Time Second
Time (1 :% 1)
ttTimeToCompletion Time (1 :% 1) -> Time (1 :% 1) -> Time (1 :% 1)
forall (unitResult :: Rat) (unitLeft :: Rat).
KnownDivRat unitLeft unitResult =>
Time unitLeft -> Time unitResult -> Time unitResult
-:- (Time Second
Time (1 :% 1)
posixTime Time (1 :% 1) -> Time (1 :% 1) -> Time (1 :% 1)
forall (unitResult :: Rat) (unitLeft :: Rat).
KnownDivRat unitLeft unitResult =>
Time unitLeft -> Time unitResult -> Time unitResult
-:- Time Second
Time (1 :% 1)
ttStart)
        ]
    status :: Text
status = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
      [ if Int
current Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
pTotal Bool -> Bool -> Bool
&& Int
fixable Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Int
pError Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
        then Style -> Text -> Text
forall a. (Pretty a, Given ColorMode) => Style -> a -> a
styleIfNeeded Style
Faint (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Color -> Text -> Text
forall a. (Pretty a, Given ColorMode) => Color -> a -> a
colorIfNeeded Color
White Text
"✓"
        else Text
""
      , if Int
fixable Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 then Color -> Text -> Text
forall a. (Pretty a, Given ColorMode) => Color -> a -> a
colorIfNeeded Color
Blue Text
"!" else Text
""
      , if Int
pError Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 then Color -> Text -> Text
forall a. (Pretty a, Given ColorMode) => Color -> a -> a
colorIfNeeded Color
Red Text
"!" else Text
""
      ]

    timeSecondCeiling :: Time Second -> Time Second
    timeSecondCeiling :: Time Second -> Time Second
timeSecondCeiling = RatioNat -> Time Second
RatioNat -> Time (1 :% 1)
sec (RatioNat -> Time (1 :% 1))
-> (Time (1 :% 1) -> RatioNat) -> Time (1 :% 1) -> Time (1 :% 1)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> RatioNat
forall a. Num a => Integer -> a
fromInteger (Integer -> RatioNat)
-> (Time (1 :% 1) -> Integer) -> Time (1 :% 1) -> RatioNat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RatioNat -> Integer
forall b. Integral b => RatioNat -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (RatioNat -> Integer)
-> (Time (1 :% 1) -> RatioNat) -> Time (1 :% 1) -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Time (1 :% 1) -> RatioNat
forall (rat :: Rat). Time rat -> RatioNat
unTime

    fixable :: Int
    fixable :: Int
fixable = Set w -> Int
forall a. Set a -> Int
S.size Set w
pRetrying

    current :: Int
    current :: Int
current = Int
pSuccess Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
pError Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
fixable

-----------------------------------------------------------
-- 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 :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Bool -> (Rewrite -> m a) -> m a
allowRewrite Bool
enabled = m Rewrite -> (Rewrite -> m ()) -> (Rewrite -> m a) -> m a
forall (m :: * -> *) a b c.
(HasCallStack, 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
  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 a. a -> m a
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
rMaxPrintedSize :: IORef Int
rMaxPrintedSize :: IORef Int
..}
      | Bool
otherwise = Rewrite -> m Rewrite
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rewrite
RewriteDisabled
    erase :: Rewrite -> m ()
erase (Rewrite RewriteCtx{IORef Int
rMaxPrintedSize :: RewriteCtx -> IORef Int
rMaxPrintedSize :: IORef Int
..}) = IO () -> m ()
forall a. IO a -> m a
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"
    erase Rewrite
RewriteDisabled = m ()
forall (f :: * -> *). Applicative f => f ()
pass

-- | Return caret and print the given text.
putTextRewrite :: MonadIO m => Rewrite -> Text -> m ()
putTextRewrite :: forall (m :: * -> *). MonadIO m => Rewrite -> Text -> m ()
putTextRewrite Rewrite
RewriteDisabled Text
_ = m ()
forall (f :: * -> *). Applicative f => f ()
pass
putTextRewrite (Rewrite RewriteCtx{IORef Int
rMaxPrintedSize :: RewriteCtx -> IORef Int
rMaxPrintedSize :: IORef Int
..}) Text
msg = do
  IO () -> m ()
forall a. IO a -> m a
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 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fill)
  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), ())
  where
    -- The maximum possible difference between two progress text representations,
    -- including the timer & the status, is 9 characters. This is a temporary
    -- solution to the problem of re-printing a smaller string on top of another
    -- that'll leave some of the trailing characters in the original string
    -- untouched, and is most likely going to be either replaced by an adequate
    -- workaround or by another way to form a text representation of a progress and
    -- its respective rewriting logic.
    fill :: String
fill = Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
9 Char
' '