-- | 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 String -> [String] -> [String]
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 = (String, String, Seconds)
-> [Maybe (String, String, Seconds)]
-> [Maybe (String, String, Seconds)]
forall a. a -> [Maybe a] -> [Maybe a]
insert (String
key,String
msg,Seconds
time) ([Maybe (String, String, Seconds)]
 -> [Maybe (String, String, Seconds)])
-> [Maybe (String, String, Seconds)]
-> [Maybe (String, String, Seconds)]
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 = ((String, String, Seconds) -> Bool)
-> [Maybe (String, String, Seconds)]
-> [Maybe (String, String, Seconds)]
forall a. (a -> Bool) -> [Maybe a] -> [Maybe a]
remove (\(String
a,String
b,Seconds
_) -> String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
key Bool -> Bool -> Bool
&& String
b String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
msg) ([Maybe (String, String, Seconds)]
 -> [Maybe (String, String, Seconds)])
-> [Maybe (String, String, Seconds)]
-> [Maybe (String, String, Seconds)]
forall a b. (a -> b) -> a -> b
$ S -> [Maybe (String, String, Seconds)]
sTraces S
s}
    where
        insert :: a -> [Maybe a] -> [Maybe a]
insert a
v (Maybe a
Nothing:[Maybe a]
xs) = a -> Maybe a
forall a. a -> Maybe a
Just a
vMaybe a -> [Maybe a] -> [Maybe a]
forall a. a -> [a] -> [a]
:[Maybe a]
xs
        insert a
v (Maybe a
x:[Maybe a]
xs) = Maybe a
x Maybe a -> [Maybe a] -> [Maybe a]
forall a. a -> [a] -> [a]
: a -> [Maybe a] -> [Maybe a]
insert a
v [Maybe a]
xs
        insert a
v [] = [a -> Maybe a
forall a. a -> Maybe a
Just a
v]

        remove :: (a -> Bool) -> [Maybe a] -> [Maybe a]
remove a -> Bool
f (Just a
x:[Maybe a]
xs) | a -> Bool
f a
x = Maybe a
forall a. Maybe a
NothingMaybe a -> [Maybe a] -> [Maybe a]
forall a. a -> [a] -> [a]
:[Maybe a]
xs
        remove a -> Bool
f (Maybe a
x:[Maybe a]
xs) = Maybe a
x Maybe a -> [Maybe a] -> [Maybe a]
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=[String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
post}, Int -> String
escCursorUp (S -> Int
sUnwind S
s) String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
pad ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [String]
pre [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
post))
    where
        pre :: [String]
pre = S -> [String]
sOutput S
s
        post :: [String]
post = String
"" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (Color -> String
escForeground Color
Green String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Status: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ S -> String
sProgress S
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
escNormal) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (Maybe (String, String, Seconds) -> String)
-> [Maybe (String, String, Seconds)] -> [String]
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 String -> String -> String
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
" * " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
k String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Seconds -> String -> String
g (Seconds
time Seconds -> Seconds -> Seconds
forall a. Num a => a -> a -> a
- Seconds
t) String
m String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"

        g :: Seconds -> String -> String
g Seconds
i String
m | Seconds -> String
showDurationSecs Seconds
i String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"0s" = String
m
              | Seconds
i Seconds -> Seconds -> Bool
forall a. Ord a => a -> a -> Bool
< Seconds
10 = String
s
              | Bool
otherwise = Color -> String
escForeground (if Seconds
i Seconds -> Seconds -> Bool
forall a. Ord a => a -> a -> Bool
> Seconds
20 then Color
Red else Color
Yellow) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
escNormal
            where s :: String
s = String
m String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> 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
    IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM IO Bool
checkEscCodes (IO () -> IO ()) -> IO () -> IO ()
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 <- S -> IO (IORef S)
forall a. a -> IO (IORef a)
newIORef S
emptyS
    let tweak :: (S -> S) -> IO ()
tweak = IORef S -> (S -> S) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef_ IORef S
ref
    IO Seconds
time <- IO (IO Seconds)
offsetTime
    ShakeOptions
opts <- ShakeOptions -> IO ShakeOptions
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShakeOptions -> IO ShakeOptions)
-> ShakeOptions -> IO ShakeOptions
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 (Verbosity -> String -> S -> S
forall p. p -> String -> S -> S
addOutput Verbosity
a String
b)
        ,shakeProgress :: IO Progress -> IO ()
shakeProgress = \IO Progress
x -> IO ((), ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ((), ()) -> IO ()) -> IO ((), ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Seconds -> (String -> IO ()) -> IO Progress -> IO ()
progressDisplay Seconds
1 ((S -> S) -> IO ()
tweak ((S -> S) -> IO ()) -> (String -> S -> S) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> S -> S
addProgress) IO Progress
x IO () -> IO () -> IO ((), ())
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] [CmdOption] -> [CmdOption] -> [CmdOption]
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; IO () -> IO ()
forall a. IO a -> IO a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr (String -> IO ()) -> IO String -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef S -> (S -> (S, String)) -> IO String
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef S
ref (Seconds -> S -> (S, String)
display Seconds
t)
    (ShakeOptions, IO ()) -> IO (ShakeOptions, IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShakeOptions
opts, IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO ()
tick IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Seconds -> IO ()
sleep Seconds
0.4) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` IO ()
tick)