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]
,S -> String
sProgress :: String
,S -> [Maybe (String, String, Seconds)]
sTraces :: [Maybe (String, String, Seconds)]
,S -> Int
sUnwind :: Int
}
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
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)