-- | Provide a Buck/Bazel style UI.
module Development.Shake.Internal.CompactUI(
    compactUI
    ) where

import Development.Shake.Internal.CmdOption
import Development.Shake.Internal.Options
import Development.Shake.Internal.Progress

import System.Time.Extra
import General.Extra
import Control.Exception
import General.Thread
import General.EscCodes
import Data.IORef.Extra
import Control.Monad.Extra


data S = S
    {S -> [String]
sOutput :: [String] -- ^ Messages that haven't yet been printed, in reverse.
    ,S -> String
sProgress :: String -- ^ Last progress message.
    ,S -> [Maybe (String, String, Seconds)]
sTraces :: [Maybe (String, String, Seconds)] -- ^ the traced items, in the order we display them
    ,S -> Int
sUnwind :: Int -- ^ Number of lines we used last time around
    }

emptyS :: S
emptyS = [String] -> String -> [Maybe (String, String, Seconds)] -> Int -> S
S [] String
"Starting..." [] Int
0

addOutput :: p -> String -> S -> S
addOutput p
pri String
msg S
s = S
s{sOutput :: [String]
sOutput = String
msg forall a. a -> [a] -> [a]
: S -> [String]
sOutput S
s}
addProgress :: String -> S -> S
addProgress String
x S
s = S
s{sProgress :: String
sProgress = String
x}

addTrace :: String -> String -> Bool -> Seconds -> S -> S
addTrace String
key String
msg Bool
start Seconds
time S
s
    | Bool
start = S
s{sTraces :: [Maybe (String, String, Seconds)]
sTraces = forall {t}. t -> [Maybe t] -> [Maybe t]
insert (String
key,String
msg,Seconds
time) forall a b. (a -> b) -> a -> b
$ S -> [Maybe (String, String, Seconds)]
sTraces S
s}
    | Bool
otherwise = S
s{sTraces :: [Maybe (String, String, Seconds)]
sTraces = forall {a}. (a -> Bool) -> [Maybe a] -> [Maybe a]
remove (\(String
a,String
b,Seconds
_) -> String
a forall a. Eq a => a -> a -> Bool
== String
key Bool -> Bool -> Bool
&& String
b forall a. Eq a => a -> a -> Bool
== String
msg) forall a b. (a -> b) -> a -> b
$ S -> [Maybe (String, String, Seconds)]
sTraces S
s}
    where
        insert :: t -> [Maybe t] -> [Maybe t]
insert t
v (Maybe t
Nothing:[Maybe t]
xs) = forall a. a -> Maybe a
Just t
vforall a. a -> [a] -> [a]
:[Maybe t]
xs
        insert t
v (Maybe t
x:[Maybe t]
xs) = Maybe t
x forall a. a -> [a] -> [a]
: t -> [Maybe t] -> [Maybe t]
insert t
v [Maybe t]
xs
        insert t
v [] = [forall a. a -> Maybe a
Just t
v]

        remove :: (a -> Bool) -> [Maybe a] -> [Maybe a]
remove a -> Bool
f (Just a
x:[Maybe a]
xs) | a -> Bool
f a
x = forall a. Maybe a
Nothingforall a. a -> [a] -> [a]
:[Maybe a]
xs
        remove a -> Bool
f (Maybe a
x:[Maybe a]
xs) = Maybe a
x forall a. a -> [a] -> [a]
: (a -> Bool) -> [Maybe a] -> [Maybe a]
remove a -> Bool
f [Maybe a]
xs
        remove a -> Bool
f [] = []


display :: Seconds -> S -> (S, String)
display :: Seconds -> S -> (S, String)
display Seconds
time S
s = (S
s{sOutput :: [String]
sOutput=[], sUnwind :: Int
sUnwind=forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
post}, Int -> String
escCursorUp (S -> Int
sUnwind S
s) forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines (forall a b. (a -> b) -> [a] -> [b]
map String -> String
pad forall a b. (a -> b) -> a -> b
$ [String]
pre forall a. [a] -> [a] -> [a]
++ [String]
post))
    where
        pre :: [String]
pre = S -> [String]
sOutput S
s
        post :: [String]
post = String
"" forall a. a -> [a] -> [a]
: (Color -> String
escForeground Color
Green forall a. [a] -> [a] -> [a]
++ String
"Status: " forall a. [a] -> [a] -> [a]
++ S -> String
sProgress S
s forall a. [a] -> [a] -> [a]
++ String
escNormal) forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map Maybe (String, String, Seconds) -> String
f (S -> [Maybe (String, String, Seconds)]
sTraces S
s)

        pad :: String -> String
pad String
x = String
x forall a. [a] -> [a] -> [a]
++ String
escClearLine
        f :: Maybe (String, String, Seconds) -> String
f Maybe (String, String, Seconds)
Nothing = String
" *"
        f (Just (String
k,String
m,Seconds
t)) = String
" * " forall a. [a] -> [a] -> [a]
++ String
k forall a. [a] -> [a] -> [a]
++ String
" (" forall a. [a] -> [a] -> [a]
++ Seconds -> String -> String
g (Seconds
time forall a. Num a => a -> a -> a
- Seconds
t) String
m forall a. [a] -> [a] -> [a]
++ String
")"

        g :: Seconds -> String -> String
g Seconds
i String
m | Seconds -> String
showDurationSecs Seconds
i forall a. Eq a => a -> a -> Bool
== String
"0s" = String
m
              | Seconds
i forall a. Ord a => a -> a -> Bool
< Seconds
10 = String
s
              | Bool
otherwise = Color -> String
escForeground (if Seconds
i forall a. Ord a => a -> a -> Bool
> Seconds
20 then Color
Red else Color
Yellow) forall a. [a] -> [a] -> [a]
++ String
s forall a. [a] -> [a] -> [a]
++ String
escNormal
            where s :: String
s = String
m forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ Seconds -> String
showDurationSecs Seconds
i


-- | Run a compact UI, with the ShakeOptions modifier, combined with
compactUI :: ShakeOptions -> IO (ShakeOptions, IO ())
compactUI :: ShakeOptions -> IO (ShakeOptions, IO ())
compactUI ShakeOptions
opts = do
    forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM IO Bool
checkEscCodes forall a b. (a -> b) -> a -> b
$
        String -> IO ()
putStrLn String
"Your terminal does not appear to support escape codes, --compact mode may not work"
    IORef S
ref <- forall a. a -> IO (IORef a)
newIORef S
emptyS
    let tweak :: (S -> S) -> IO ()
tweak = forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef_ IORef S
ref
    IO Seconds
time <- IO (IO Seconds)
offsetTime
    ShakeOptions
opts <- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ShakeOptions
opts
        {shakeTrace :: String -> String -> Bool -> IO ()
shakeTrace = \String
a String
b Bool
c -> do Seconds
t <- IO Seconds
time; (S -> S) -> IO ()
tweak (String -> String -> Bool -> Seconds -> S -> S
addTrace String
a String
b Bool
c Seconds
t)
        ,shakeOutput :: Verbosity -> String -> IO ()
shakeOutput = \Verbosity
a String
b -> (S -> S) -> IO ()
tweak (forall {p}. p -> String -> S -> S
addOutput Verbosity
a String
b)
        ,shakeProgress :: IO Progress -> IO ()
shakeProgress = \IO Progress
x -> forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Seconds -> (String -> IO ()) -> IO Progress -> IO ()
progressDisplay Seconds
1 ((S -> S) -> IO ()
tweak forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> S -> S
addProgress) IO Progress
x forall a b. IO a -> IO b -> IO (a, b)
`withThreadsBoth` ShakeOptions -> IO Progress -> IO ()
shakeProgress ShakeOptions
opts IO Progress
x
        ,shakeCommandOptions :: [CmdOption]
shakeCommandOptions = [Bool -> CmdOption
EchoStdout Bool
False, Bool -> CmdOption
EchoStderr Bool
False] forall a. [a] -> [a] -> [a]
++ ShakeOptions -> [CmdOption]
shakeCommandOptions ShakeOptions
opts
        ,shakeVerbosity :: Verbosity
shakeVerbosity = Verbosity
Error
        }
    let tick :: IO ()
tick = do Seconds
t <- IO Seconds
time; forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef S
ref (Seconds -> S -> (S, String)
display Seconds
t)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShakeOptions
opts, forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO ()
tick forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Seconds -> IO ()
sleep Seconds
0.4) forall a b. IO a -> IO b -> IO a
`finally` IO ()
tick)