    {-# LANGUAGE Safe #-}

    {-
    Copyright (c) 2006-2011 John Goerzen <jgoerzen@complete.org>

    All rights reserved.

    For license and copyright information, see the file LICENSE
    -}

    {- |
       Module     : Data.Progress.Meter
       Copyright  : Copyright (C) 2006-2011 John Goerzen
       SPDX-License-Identifier: BSD-3-Clause

       Stability  : stable
       Portability: portable

    Tool for maintaining a status bar, supporting multiple simultaneous tasks,
    as a layer atop "Data.Progress.Tracker".

    Written by John Goerzen, jgoerzen\@complete.org -}

    module Data.Progress.Meter (-- * Types
                                   ProgressMeter,
                                   -- * Creation and Configuration
                                   simpleNewMeter,
                                   newMeter,
                                   setComponents,
                                   addComponent,
                                   removeComponent,
                                   setWidth,

                                   -- * Rendering and Output
                                   renderMeter,
                                   displayMeter,
                                   clearMeter,
                                   writeMeterString,
                                   autoDisplayMeter,
                                   killAutoDisplayMeter
                                   ) where

    import safe Data.Progress.Tracker
        ( ProgressStatuses(..),
          Progress,
          ProgressStatus(totalUnits, completedUnits, trackerName),
          getSpeed,
          getETR )
    import safe Control.Concurrent
        ( modifyMVar_,
          withMVar,
          newMVar,
          MVar,
          threadDelay,
          forkIO,
          myThreadId,
          yield,
          ThreadId )
    import Control.Monad (when)
    import Data.String.Utils (join)
    import System.Time.Utils (renderSecs)
    import Data.Quantity (renderNums, binaryOpts)
    import safe System.IO ( Handle, hFlush, hPutStr )
    import Control.Monad (filterM)

    {- | The main data type for the progress meter. -}
    data ProgressMeterR =
        ProgressMeterR {ProgressMeterR -> Progress
    masterP :: Progress, -- ^ The master 'Progress' object for overall status
                        ProgressMeterR -> [Progress]
    components :: [Progress], -- ^ Individual component statuses
                        ProgressMeterR -> Int
    width :: Int, -- ^ Width of the meter
                        ProgressMeterR -> String
    unit :: String, -- ^ Units of display
                        ProgressMeterR -> [Integer] -> [String]
    renderer :: [Integer] -> [String], -- ^ Function to render numbers
                        ProgressMeterR -> [ThreadId]
    autoDisplayers :: [ThreadId] -- ^ Auto-updating display
                       }

    type ProgressMeter = MVar ProgressMeterR

    {- | Set up a new status bar using defaults:

    * The given tracker

    * Width 80

    * Data.Quantity.renderNums binaryOpts 1

    * Unit inticator @"B"@

    -}
    simpleNewMeter :: Progress -> IO ProgressMeter
    simpleNewMeter :: Progress -> IO ProgressMeter
    simpleNewMeter Progress
    pt = Progress
    -> String -> Int -> ([Integer] -> [String]) -> IO ProgressMeter
    newMeter Progress
    pt String
    "B" Int
    80 (SizeOpts -> Int -> [Integer] -> [String]
    forall a. (Ord a, Real a) => SizeOpts -> Int -> [a] -> [String]
    renderNums SizeOpts
    binaryOpts Int
    1)

    {- | Set up a new status bar. -}
    newMeter :: Progress           -- ^ The top-level 'Progress'
             -> String              -- ^ Unit indicator string
              -> Int                -- ^ Width of the terminal -- usually 80
              -> ([Integer] -> [String])-- ^ A function to render sizes
              -> IO ProgressMeter
    newMeter :: Progress
    -> String -> Int -> ([Integer] -> [String]) -> IO ProgressMeter
    newMeter Progress
    tracker String
    u Int
    w [Integer] -> [String]
    rfunc =
        ProgressMeterR -> IO ProgressMeter
    forall a. a -> IO (MVar a)
    newMVar (ProgressMeterR -> IO ProgressMeter)
    -> ProgressMeterR -> IO ProgressMeter
    forall a b. (a -> b) -> a -> b
    $ ProgressMeterR {masterP :: Progress
    masterP = Progress
    tracker, components :: [Progress]
    components = [],
                             width :: Int
    width = Int
    w, renderer :: [Integer] -> [String]
    renderer = [Integer] -> [String]
    rfunc, autoDisplayers :: [ThreadId]
    autoDisplayers = [],
                             unit :: String
    unit = String
    u}

    {- | Adjust the list of components of this 'ProgressMeter'. -}
    setComponents :: ProgressMeter -> [Progress] -> IO ()
    setComponents :: ProgressMeter -> [Progress] -> IO ()
    setComponents ProgressMeter
    meter [Progress]
    componentlist = ProgressMeter -> (ProgressMeterR -> IO ProgressMeterR) -> IO ()
    forall a. MVar a -> (a -> IO a) -> IO ()
    modifyMVar_ ProgressMeter
    meter (\ProgressMeterR
    m -> ProgressMeterR -> IO ProgressMeterR
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ProgressMeterR -> IO ProgressMeterR)
    -> ProgressMeterR -> IO ProgressMeterR
    forall a b. (a -> b) -> a -> b
    $ ProgressMeterR
    m {components = componentlist})

    {- | Add a new component to the list of components. -}
    addComponent :: ProgressMeter -> Progress -> IO ()
    addComponent :: ProgressMeter -> Progress -> IO ()
    addComponent ProgressMeter
    meter Progress
    component =
        ProgressMeter -> (ProgressMeterR -> IO ProgressMeterR) -> IO ()
    forall a. MVar a -> (a -> IO a) -> IO ()
    modifyMVar_ ProgressMeter
    meter (\ProgressMeterR
    m -> ProgressMeterR -> IO ProgressMeterR
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ProgressMeterR -> IO ProgressMeterR)
    -> ProgressMeterR -> IO ProgressMeterR
    forall a b. (a -> b) -> a -> b
    $ ProgressMeterR
    m {components = component : components m})

    {- | Remove a component by name. -}
    removeComponent :: ProgressMeter -> String -> IO ()
    removeComponent :: ProgressMeter -> String -> IO ()
    removeComponent ProgressMeter
    meter String
    componentname = ProgressMeter -> (ProgressMeterR -> IO ProgressMeterR) -> IO ()
    forall a. MVar a -> (a -> IO a) -> IO ()
    modifyMVar_ ProgressMeter
    meter ((ProgressMeterR -> IO ProgressMeterR) -> IO ())
    -> (ProgressMeterR -> IO ProgressMeterR) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ \ProgressMeterR
    m ->
       do newc <- (Progress -> IO Bool) -> [Progress] -> IO [Progress]
    forall (m :: * -> *) a.
    Applicative m =>
    (a -> m Bool) -> [a] -> m [a]
    filterM (\Progress
    x -> Progress -> (ProgressStatus -> IO Bool) -> IO Bool
    forall a b. ProgressStatuses a b => a -> (ProgressStatus -> b) -> b
    withStatus Progress
    x (\ProgressStatus
    y -> Bool -> IO Bool
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool -> IO Bool) -> Bool -> IO Bool
    forall a b. (a -> b) -> a -> b
    $ ProgressStatus -> String
    trackerName ProgressStatus
    y String -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    /= String
    componentname))
                  (ProgressMeterR -> [Progress]
    components ProgressMeterR
    m)
          return $ m {components = newc}

    {- | Adjusts the width of this 'ProgressMeter'. -}
    setWidth :: ProgressMeter -> Int -> IO ()
    setWidth :: ProgressMeter -> Int -> IO ()
    setWidth ProgressMeter
    meter Int
    w = ProgressMeter -> (ProgressMeterR -> IO ProgressMeterR) -> IO ()
    forall a. MVar a -> (a -> IO a) -> IO ()
    modifyMVar_ ProgressMeter
    meter (\ProgressMeterR
    m -> ProgressMeterR -> IO ProgressMeterR
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ProgressMeterR -> IO ProgressMeterR)
    -> ProgressMeterR -> IO ProgressMeterR
    forall a b. (a -> b) -> a -> b
    $ ProgressMeterR
    m {width = w})

    {- | Like renderMeter, but prints it to the screen instead of returning it.

    This function will output CR, then the meter.

    Pass stdout as the handle for regular display to the screen. -}
    displayMeter :: Handle -> ProgressMeter -> IO ()
    displayMeter :: Handle -> ProgressMeter -> IO ()
    displayMeter Handle
    h ProgressMeter
    r = ProgressMeter -> (ProgressMeterR -> IO ()) -> IO ()
    forall a b. MVar a -> (a -> IO b) -> IO b
    withMVar ProgressMeter
    r ((ProgressMeterR -> IO ()) -> IO ())
    -> (ProgressMeterR -> IO ()) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ \ProgressMeterR
    meter ->
        do s <- ProgressMeterR -> IO String
    renderMeterR ProgressMeterR
    meter
           hPutStr h ("\r" ++ s)
           hFlush h
           -- By placing this whole thing under withMVar, we can effectively
           -- lock the IO and prevent IO from stomping on each other.

    {- | Clears the meter -- outputs CR, spaces equal to the width - 1,
    then another CR.

    Pass stdout as the handle for regular display to the screen. -}
    clearMeter :: Handle -> ProgressMeter -> IO ()
    clearMeter :: Handle -> ProgressMeter -> IO ()
    clearMeter Handle
    h ProgressMeter
    pm = ProgressMeter -> (ProgressMeterR -> IO ()) -> IO ()
    forall a b. MVar a -> (a -> IO b) -> IO b
    withMVar ProgressMeter
    pm ((ProgressMeterR -> IO ()) -> IO ())
    -> (ProgressMeterR -> IO ()) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ \ProgressMeterR
    m ->
                         do Handle -> String -> IO ()
    hPutStr Handle
    h (ProgressMeterR -> String
    clearmeterstr ProgressMeterR
    m)
                            Handle -> IO ()
    hFlush Handle
    h

    {- | Clears the meter, writes the given string, then restores the meter.
    The string is assumed to contain a trailing newline.

    Pass stdout as the handle for regular display to the screen. -}
    writeMeterString :: Handle -> ProgressMeter -> String -> IO ()
    writeMeterString :: Handle -> ProgressMeter -> String -> IO ()
    writeMeterString Handle
    h ProgressMeter
    pm String
    msg = ProgressMeter -> (ProgressMeterR -> IO ()) -> IO ()
    forall a b. MVar a -> (a -> IO b) -> IO b
    withMVar ProgressMeter
    pm ((ProgressMeterR -> IO ()) -> IO ())
    -> (ProgressMeterR -> IO ()) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ \ProgressMeterR
    meter ->
                                do s <- ProgressMeterR -> IO String
    renderMeterR ProgressMeterR
    meter
                                   hPutStr h (clearmeterstr meter)
                                   hPutStr h msg
                                   hPutStr h s
                                   hFlush h

    clearmeterstr :: ProgressMeterR -> String
    clearmeterstr :: ProgressMeterR -> String
    clearmeterstr ProgressMeterR
    m = String
    "\r" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> Char -> String
    forall a. Int -> a -> [a]
    replicate (ProgressMeterR -> Int
    width ProgressMeterR
    m Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1) Char
    ' ' String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "\r"

    {- | Starts a thread that updates the meter every n seconds by calling
    the specified function.  Note: @displayMeter stdout@
    is an ideal function here.

    Save this threadID and use it later to call 'stopAutoDisplayMeter'.
    -}
    autoDisplayMeter :: ProgressMeter -- ^ The meter to display
                     -> Int         -- ^ Update interval in seconds
                     -> (ProgressMeter -> IO ()) -- ^ Function to display it
                     -> IO ThreadId -- ^ Resulting thread id
    autoDisplayMeter :: ProgressMeter -> Int -> (ProgressMeter -> IO ()) -> IO ThreadId
    autoDisplayMeter ProgressMeter
    pm Int
    delay ProgressMeter -> IO ()
    displayfunc =
        do thread <- IO () -> IO ThreadId
    forkIO IO ()
    workerthread
           modifyMVar_ pm (\ProgressMeterR
    p -> ProgressMeterR -> IO ProgressMeterR
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ProgressMeterR -> IO ProgressMeterR)
    -> ProgressMeterR -> IO ProgressMeterR
    forall a b. (a -> b) -> a -> b
    $ ProgressMeterR
    p {autoDisplayers = thread : autoDisplayers p})
           return thread
        where workerthread :: IO ()
    workerthread = do tid <- IO ThreadId
    myThreadId
                                -- Help fix a race condition so that the above
                                -- modifyMVar can run before a check ever does
                                yield
                                loop tid
              loop :: ThreadId -> IO ()
    loop ThreadId
    tid = do ProgressMeter -> IO ()
    displayfunc ProgressMeter
    pm
                            Int -> IO ()
    threadDelay (Int
    delay Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    1000000)
                            c <- ThreadId -> IO Bool
    doIContinue ThreadId
    tid
                            when c (loop tid)
              doIContinue :: ThreadId -> IO Bool
    doIContinue ThreadId
    tid = ProgressMeter -> (ProgressMeterR -> IO Bool) -> IO Bool
    forall a b. MVar a -> (a -> IO b) -> IO b
    withMVar ProgressMeter
    pm ((ProgressMeterR -> IO Bool) -> IO Bool)
    -> (ProgressMeterR -> IO Bool) -> IO Bool
    forall a b. (a -> b) -> a -> b
    $ \ProgressMeterR
    p ->
                                   if ThreadId
    tid ThreadId -> [ThreadId] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` ProgressMeterR -> [ThreadId]
    autoDisplayers ProgressMeterR
    p
                                      then Bool -> IO Bool
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    True
                                      else Bool -> IO Bool
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    False

    {- | Stops the specified meter from displaying.

    You should probably call 'clearMeter' after a call to this. -}
    killAutoDisplayMeter :: ProgressMeter -> ThreadId -> IO ()
    killAutoDisplayMeter :: ProgressMeter -> ThreadId -> IO ()
    killAutoDisplayMeter ProgressMeter
    pm ThreadId
    t =
        ProgressMeter -> (ProgressMeterR -> IO ProgressMeterR) -> IO ()
    forall a. MVar a -> (a -> IO a) -> IO ()
    modifyMVar_ ProgressMeter
    pm (\ProgressMeterR
    p -> ProgressMeterR -> IO ProgressMeterR
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ProgressMeterR -> IO ProgressMeterR)
    -> ProgressMeterR -> IO ProgressMeterR
    forall a b. (a -> b) -> a -> b
    $ ProgressMeterR
    p {autoDisplayers = filter (/= t) (autoDisplayers p)})

    {- | Render the current status. -}
    renderMeter :: ProgressMeter -> IO String
    renderMeter :: ProgressMeter -> IO String
    renderMeter ProgressMeter
    r = ProgressMeter -> (ProgressMeterR -> IO String) -> IO String
    forall a b. MVar a -> (a -> IO b) -> IO b
    withMVar ProgressMeter
    r ((ProgressMeterR -> IO String) -> IO String)
    -> (ProgressMeterR -> IO String) -> IO String
    forall a b. (a -> b) -> a -> b
    $ ProgressMeterR -> IO String
    renderMeterR

    renderMeterR :: ProgressMeterR -> IO String
    renderMeterR :: ProgressMeterR -> IO String
    renderMeterR ProgressMeterR
    meter =
        do overallpct <- Progress -> IO String
    forall {a} {m :: * -> *}.
    (ProgressStatuses a (m String), Monad m) =>
    a -> m String
    renderpct (Progress -> IO String) -> Progress -> IO String
    forall a b. (a -> b) -> a -> b
    $ ProgressMeterR -> Progress
    masterP ProgressMeterR
    meter
           compnnts <- mapM (rendercomponent $ renderer meter)
                         (components meter)
           let componentstr = case String -> [String] -> String
    forall a. [a] -> [[a]] -> [a]
    join String
    " " [String]
    compnnts of
                                [] -> String
    ""
                                String
    x -> String
    x String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " "
           rightpart <- renderoverall (renderer meter) (masterP meter)
           let leftpart = String
    overallpct String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    componentstr
           let padwidth = (ProgressMeterR -> Int
    width ProgressMeterR
    meter) Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - (String -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length String
    leftpart) Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - (String -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length String
    rightpart)
           if padwidth < 1
              then return $ take (width meter - 1) $ leftpart ++ rightpart
              else return $ leftpart ++ replicate padwidth ' ' ++ rightpart

        where
          u :: String
    u = ProgressMeterR -> String
    unit ProgressMeterR
    meter
          renderpct :: a -> m String
    renderpct a
    pt =
                  a -> (ProgressStatus -> m String) -> m String
    forall a b. ProgressStatuses a b => a -> (ProgressStatus -> b) -> b
    withStatus a
    pt ProgressStatus -> m String
    forall {m :: * -> *}. Monad m => ProgressStatus -> m String
    renderpctpts
          renderpctpts :: ProgressStatus -> m String
    renderpctpts ProgressStatus
    pts =
                      if (ProgressStatus -> Integer
    totalUnits ProgressStatus
    pts Integer -> Integer -> Bool
    forall a. Eq a => a -> a -> Bool
    == Integer
    0)
                         then String -> m String
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return String
    "0%"
                         else String -> m String
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (String -> m String) -> String -> m String
    forall a b. (a -> b) -> a -> b
    $ Integer -> String
    forall a. Show a => a -> String
    show (((ProgressStatus -> Integer
    completedUnits ProgressStatus
    pts) Integer -> Integer -> Integer
    forall a. Num a => a -> a -> a
    * Integer
    100) Integer -> Integer -> Integer
    forall a. Integral a => a -> a -> a
    `div` (ProgressStatus -> Integer
    totalUnits ProgressStatus
    pts)) String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "%"
          rendercomponent :: ([Integer] -> [String]) -> Progress -> IO String
          rendercomponent :: ([Integer] -> [String]) -> Progress -> IO String
    rendercomponent [Integer] -> [String]
    rfunc Progress
    pt = Progress -> (ProgressStatus -> IO String) -> IO String
    forall a b. ProgressStatuses a b => a -> (ProgressStatus -> b) -> b
    withStatus Progress
    pt ((ProgressStatus -> IO String) -> IO String)
    -> (ProgressStatus -> IO String) -> IO String
    forall a b. (a -> b) -> a -> b
    $ \ProgressStatus
    pts ->
                  do pct <- ProgressStatus -> IO String
    forall {m :: * -> *}. Monad m => ProgressStatus -> m String
    renderpctpts ProgressStatus
    pts
                     let renders = [Integer] -> [String]
    rfunc [ProgressStatus -> Integer
    totalUnits ProgressStatus
    pts, ProgressStatus -> Integer
    completedUnits ProgressStatus
    pts]
                     return $ "[" ++ trackerName pts ++ " " ++
                         (renders !! 1) ++ u ++ "/" ++
                         head renders ++ u ++ " " ++ pct ++ "]"

          renderoverall :: (ProgressStatuses a (IO [Char])) => ([Integer] -> [[Char]]) -> a -> IO [Char]
          renderoverall :: forall a.
    ProgressStatuses a (IO String) =>
    ([Integer] -> [String]) -> a -> IO String
    renderoverall [Integer] -> [String]
    rfunc a
    pt = a -> (ProgressStatus -> IO String) -> IO String
    forall a b. ProgressStatuses a b => a -> (ProgressStatus -> b) -> b
    withStatus a
    pt ((ProgressStatus -> IO String) -> IO String)
    -> (ProgressStatus -> IO String) -> IO String
    forall a b. (a -> b) -> a -> b
    $ \ProgressStatus
    pts ->
                                             do etr <- ProgressStatus -> IO Integer
    forall a.
    (ProgressStatuses a (IO Integer),
     ProgressStatuses a (IO Rational)) =>
    a -> IO Integer
    getETR ProgressStatus
    pts
                                                speed <- getSpeed pts
                                                return $ head (rfunc [floor (speed :: Double)]) ++ u ++
                                                           "/s " ++ renderSecs etr