content: {- 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
    { ttTimeToCompletion :: Time Second
      -- ^ The amount of time required for the task to be completed.
    , ttStart :: Time Second
      -- ^ The timestamp of when the task had started, represented by the number of seconds
      -- since the Unix epoch.
    } deriving stock (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
    { pTotal :: !a
      -- ^ Overall amount of work.
    , pSuccess :: !a
      -- ^ How much has been completed with success.
    , pError :: !a
      -- ^ How much has been completed with error.
    , pRetrying :: !(S.Set w)
      -- ^ Witnesses of items that have been completed with error but are being retried.
    , 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 (Show)
  
  -- | Initialise null progress.
  initProgress :: Num a => a -> Progress a w
  initProgress a = Progress
    { pTotal = a
    , pSuccess = 0
    , pError = 0
    , pRetrying = S.empty
    , pTaskTimestamp = 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 ws = Progress
    { pTotal = length ws
    , pSuccess = 0
    , pError = 0
    , pRetrying = S.empty
    , pTaskTimestamp = Nothing
    }
  
  -- | Report a unit of success with witness @item@.
  reportSuccess :: (Num a, Ord w) => w -> Progress a w -> Progress a w
  reportSuccess item Progress{..} = Progress
    { pSuccess = pSuccess + 1
    , pRetrying = S.delete item pRetrying
    , ..
    }
  
  -- | Report a unit of failure with witness @item@.
  reportError :: (Num a, Ord w) => w -> Progress a w -> Progress a w
  reportError item Progress{..} = Progress
    { pError = pError + 1
    , pRetrying = S.delete item pRetrying
    , ..
    }
  
  -- | Report a unit of failure and retry intention with witness @item@.
  reportRetry :: Ord w => w -> Progress a w -> Progress a w
  reportRetry item Progress{..} = Progress
    { pRetrying = S.insert item pRetrying
    , ..
    }
  
  -- | 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 _ ttc startTime Progress{..} = Progress
    { pTaskTimestamp = Just (TaskTimestamp ttc startTime)
    , ..
    }
  
  -- | 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 = pTaskTimestamp
  
  removeTaskTimestamp :: Progress a w -> Progress a w
  removeTaskTimestamp Progress{..} = Progress
    { pTaskTimestamp = Nothing
    , ..
    }
  
  checkTaskTimestamp :: Time Second -> Progress a w -> Progress a w
  checkTaskTimestamp posixTime p@Progress{..} =
    case pTaskTimestamp of
      Nothing -> p
      Just TaskTimestamp{..} ->
        if ttTimeToCompletion >= posixTime -:- ttStart
        then p
        else removeTaskTimestamp 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 p1 p2 = and
    [ ((==) `on` pTotal) p1 p2
    , ((==) `on` pSuccess) p1 p2
    , ((==) `on` pError) p1 p2
    , ((==) `on` pRetrying) p1 p2
    ]
  
  -- | Visualise progress bar.
  showProgress :: Given ColorMode => Text -> Int -> Color -> Time Second -> Progress Int w -> Text
  showProgress name width col posixTime Progress{..} = mconcat
    [ colorIfNeeded col (name <> ": [")
    , toText bar
    , timer
    , colorIfNeeded col "]"
    , 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 = floor $ (current % pTotal) * fromIntegral @Int @(Ratio Int) width
  
      -- The current number of the invalid references.
      errsU = ceiling $ (pError % pTotal) * fromIntegral @Int @(Ratio 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 = min (width - errsU) . ceiling $ (fixable % pTotal) *
        fromIntegral @Int @(Ratio 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 = max 0 $ done - errsU - errsF
  
      -- The remaining number of references to be verified.
      remaining = width - successful - errsU - errsF
  
      bar
        | pTotal == 0 = replicate width '-'
        | otherwise = mconcat
            [ colorIfNeeded Blue $ replicate errsF '■'
            , colorIfNeeded Red $ replicate errsU '■'
            , colorIfNeeded col $ replicate successful '■'
            , colorIfNeeded col $ replicate remaining ' '
            , " "
            ]
      timer = case pTaskTimestamp of
        Nothing -> ""
        Just TaskTimestamp{..} -> mconcat
          [ colorIfNeeded col "|"
          , colorIfNeeded Blue . show . timeSecondCeiling
          $ ttTimeToCompletion -:- (posixTime -:- ttStart)
          ]
      status = mconcat
        [ if current == pTotal && fixable == 0 && pError == 0
          then styleIfNeeded Faint $ colorIfNeeded White "✓"
          else ""
        , if fixable /= 0 then colorIfNeeded Blue "!" else ""
        , if pError /= 0 then colorIfNeeded Red "!" else ""
        ]
  
      timeSecondCeiling :: Time Second -> Time Second
      timeSecondCeiling = sec . fromInteger . ceiling . unTime
  
      fixable :: Int
      fixable = S.size pRetrying
  
      current :: Int
      current = pSuccess + pError + fixable
  
  -----------------------------------------------------------
  -- Rewritable output
  -----------------------------------------------------------
  
  -- | Rewrites state.
  data RewriteCtx = RewriteCtx
    { 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 enabled = bracket prepare erase
    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"
      erase RewriteDisabled = pass
  
  -- | Return caret and print the given text.
  putTextRewrite :: MonadIO m => Rewrite -> Text -> m ()
  putTextRewrite RewriteDisabled _ = pass
  putTextRewrite (Rewrite RewriteCtx{..}) msg = do
    liftIO $ hPutStr stderr ('\r' : toString msg ++ fill)
    atomicModifyIORef' rMaxPrintedSize $ \maxPrinted ->
      (max maxPrinted (length 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 = replicate 9 ' '
  