{-# LANGUAGE RecordWildCards, CPP, ViewPatterns, ForeignFunctionInterface, TupleSections #-}
module Development.Shake.Internal.Progress(
progress,
progressSimple, progressDisplay, progressTitlebar, progressProgram,
ProgressEntry(..), progressReplay, writeProgressReport
) where
import Control.Applicative
import Data.Tuple.Extra
import Control.Exception.Extra
import Control.Monad.Extra
import System.Directory
import System.Process
import System.FilePath
import Data.Char
import Data.IORef
import Data.List
import Data.Maybe
import Development.Shake.Internal.Options
import Development.Shake.Internal.Core.Types
import Development.Shake.Internal.Core.Database
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as LBS
import Numeric.Extra
import General.Template
import General.EscCodes
import General.Extra
import Development.Shake.Internal.Paths
import System.Time.Extra
#ifdef mingw32_HOST_OS
import Foreign.C.String
#ifdef x86_64_HOST_ARCH
#define CALLCONV ccall
#else
#define CALLCONV stdcall
#endif
foreign import CALLCONV "Windows.h SetConsoleTitleW" c_setConsoleTitleW :: CWString -> IO Bool
#endif
progress :: Database -> Step -> IO Progress
progress :: Database -> Step -> IO Progress
progress Database
db Step
step = do
[(Key, Status)]
xs <- forall k v. DatabasePoly k v -> IO [(k, v)]
getKeyValues Database
db
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Progress -> Status -> Progress
f forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Key, Status)]
xs
where
g :: Float -> Double
g = Float -> Double
floatToDouble
f :: Progress -> Status -> Progress
f Progress
s (Ready Result{Float
[Depends]
[Trace]
(Value, OneShot BS_Store)
Step
traces :: forall a. Result a -> [Trace]
execution :: forall a. Result a -> Float
depends :: forall a. Result a -> [Depends]
changed :: forall a. Result a -> Step
built :: forall a. Result a -> Step
result :: forall a. Result a -> a
traces :: [Trace]
execution :: Float
depends :: [Depends]
changed :: Step
built :: Step
result :: (Value, OneShot BS_Store)
..}) = if Step
step forall a. Eq a => a -> a -> Bool
== Step
built
then Progress
s{countBuilt :: Int
countBuilt = Progress -> Int
countBuilt Progress
s forall a. Num a => a -> a -> a
+ Int
1, timeBuilt :: Double
timeBuilt = Progress -> Double
timeBuilt Progress
s forall a. Num a => a -> a -> a
+ Float -> Double
g Float
execution}
else Progress
s{countSkipped :: Int
countSkipped = Progress -> Int
countSkipped Progress
s forall a. Num a => a -> a -> a
+ Int
1, timeSkipped :: Double
timeSkipped = Progress -> Double
timeSkipped Progress
s forall a. Num a => a -> a -> a
+ Float -> Double
g Float
execution}
f Progress
s (Loaded Result{Float
[Depends]
[Trace]
OneShot BS_Store
Step
traces :: [Trace]
execution :: Float
depends :: [Depends]
changed :: Step
built :: Step
result :: OneShot BS_Store
traces :: forall a. Result a -> [Trace]
execution :: forall a. Result a -> Float
depends :: forall a. Result a -> [Depends]
changed :: forall a. Result a -> Step
built :: forall a. Result a -> Step
result :: forall a. Result a -> a
..}) = Progress
s{countUnknown :: Int
countUnknown = Progress -> Int
countUnknown Progress
s forall a. Num a => a -> a -> a
+ Int
1, timeUnknown :: Double
timeUnknown = Progress -> Double
timeUnknown Progress
s forall a. Num a => a -> a -> a
+ Float -> Double
g Float
execution}
f Progress
s (Running NoShow
(Either SomeException (Result (Value, OneShot BS_Store))
-> Locked ())
_ Maybe (Result (OneShot BS_Store))
r) =
let (Double
d,Int
c) = Progress -> (Double, Int)
timeTodo Progress
s
t :: (Double, Int)
t | Just Result{Float
[Depends]
[Trace]
OneShot BS_Store
Step
traces :: [Trace]
execution :: Float
depends :: [Depends]
changed :: Step
built :: Step
result :: OneShot BS_Store
traces :: forall a. Result a -> [Trace]
execution :: forall a. Result a -> Float
depends :: forall a. Result a -> [Depends]
changed :: forall a. Result a -> Step
built :: forall a. Result a -> Step
result :: forall a. Result a -> a
..} <- Maybe (Result (OneShot BS_Store))
r = let d2 :: Double
d2 = Double
d forall a. Num a => a -> a -> a
+ Float -> Double
g Float
execution in Double
d2 seq :: forall a b. a -> b -> b
`seq` (Double
d2,Int
c)
| Bool
otherwise = let c2 :: Int
c2 = Int
c forall a. Num a => a -> a -> a
+ Int
1 in Int
c2 seq :: forall a b. a -> b -> b
`seq` (Double
d,Int
c2)
in Progress
s{countTodo :: Int
countTodo = Progress -> Int
countTodo Progress
s forall a. Num a => a -> a -> a
+ Int
1, timeTodo :: (Double, Int)
timeTodo = (Double, Int)
t}
f Progress
s Status
_ = Progress
s
newtype Mealy i a = Mealy {forall i a. Mealy i a -> i -> (a, Mealy i a)
runMealy :: i -> (a, Mealy i a)}
instance Functor (Mealy i) where
fmap :: forall a b. (a -> b) -> Mealy i a -> Mealy i b
fmap a -> b
f (Mealy i -> (a, Mealy i a)
m) = forall i a. (i -> (a, Mealy i a)) -> Mealy i a
Mealy forall a b. (a -> b) -> a -> b
$ \i
i -> case i -> (a, Mealy i a)
m i
i of
(a
x, Mealy i a
m) -> (a -> b
f a
x, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Mealy i a
m)
instance Applicative (Mealy i) where
pure :: forall a. a -> Mealy i a
pure a
x = let r :: Mealy i a
r = forall i a. (i -> (a, Mealy i a)) -> Mealy i a
Mealy (forall a b. a -> b -> a
const (a
x, Mealy i a
r)) in forall {i}. Mealy i a
r
Mealy i -> (a -> b, Mealy i (a -> b))
mf <*> :: forall a b. Mealy i (a -> b) -> Mealy i a -> Mealy i b
<*> Mealy i -> (a, Mealy i a)
mx = forall i a. (i -> (a, Mealy i a)) -> Mealy i a
Mealy forall a b. (a -> b) -> a -> b
$ \i
i -> case i -> (a -> b, Mealy i (a -> b))
mf i
i of
(a -> b
f, Mealy i (a -> b)
mf) -> case i -> (a, Mealy i a)
mx i
i of
(a
x, Mealy i a
mx) -> (a -> b
f a
x, Mealy i (a -> b)
mf forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mealy i a
mx)
echoMealy :: Mealy i i
echoMealy :: forall i. Mealy i i
echoMealy = forall i a. (i -> (a, Mealy i a)) -> Mealy i a
Mealy (,forall i. Mealy i i
echoMealy)
scanMealy :: (a -> b -> a) -> a -> Mealy i b -> Mealy i a
scanMealy :: forall a b i. (a -> b -> a) -> a -> Mealy i b -> Mealy i a
scanMealy a -> b -> a
f a
z (Mealy i -> (b, Mealy i b)
m) = forall i a. (i -> (a, Mealy i a)) -> Mealy i a
Mealy forall a b. (a -> b) -> a -> b
$ \i
i -> case i -> (b, Mealy i b)
m i
i of
(b
x, Mealy i b
m) -> let z2 :: a
z2 = a -> b -> a
f a
z b
x in (a
z2, forall a b i. (a -> b -> a) -> a -> Mealy i b -> Mealy i a
scanMealy a -> b -> a
f a
z2 Mealy i b
m)
oldMealy :: a -> Mealy i a -> Mealy i (a,a)
oldMealy :: forall a i. a -> Mealy i a -> Mealy i (a, a)
oldMealy a
old = forall a b i. (a -> b -> a) -> a -> Mealy i b -> Mealy i a
scanMealy (\(a
_,a
old) a
new -> (a
old,a
new)) (a
old,a
old)
latch :: Mealy i (Bool, a) -> Mealy i a
latch :: forall i a. Mealy i (Bool, a) -> Mealy i a
latch Mealy i (Bool, a)
s = forall a. Partial => Maybe a -> a
fromJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b i. (a -> b -> a) -> a -> Mealy i b -> Mealy i a
scanMealy forall {a}. Maybe a -> (Bool, a) -> Maybe a
f forall a. Maybe a
Nothing Mealy i (Bool, a)
s
where f :: Maybe a -> (Bool, a) -> Maybe a
f Maybe a
old (Bool
b,a
v) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ if Bool
b then forall a. a -> Maybe a -> a
fromMaybe a
v Maybe a
old else a
v
iff :: Mealy i Bool -> Mealy i a -> Mealy i a -> Mealy i a
iff :: forall i a. Mealy i Bool -> Mealy i a -> Mealy i a -> Mealy i a
iff Mealy i Bool
c Mealy i a
t Mealy i a
f = (\Bool
c a
t a
f -> if Bool
c then a
t else a
f) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mealy i Bool
c forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mealy i a
t forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mealy i a
f
decay :: Double -> Mealy i Double -> Mealy i Double -> Mealy i Double
decay :: forall i.
Double -> Mealy i Double -> Mealy i Double -> Mealy i Double
decay Double
f Mealy i Double
a Mealy i Double
b = forall a b i. (a -> b -> a) -> a -> Mealy i b -> Mealy i a
scanMealy Double -> ((Double, Double), (Double, Double)) -> Double
step Double
0 forall a b. (a -> b) -> a -> b
$ (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a i. a -> Mealy i a -> Mealy i (a, a)
oldMealy Double
0 Mealy i Double
a forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a i. a -> Mealy i a -> Mealy i (a, a)
oldMealy Double
0 Mealy i Double
b
where step :: Double -> ((Double, Double), (Double, Double)) -> Double
step Double
r ((Double
a,Double
a'),(Double
b,Double
b')) = if forall a. RealFloat a => a -> Bool
isNaN Double
r then Double
a' forall a. Fractional a => a -> a -> a
/ Double
b' else ((Double
rforall a. Num a => a -> a -> a
*Double
b) forall a. Num a => a -> a -> a
+ Double
fforall a. Num a => a -> a -> a
*(Double
a'forall a. Num a => a -> a -> a
-Double
a)) forall a. Fractional a => a -> a -> a
/ (Double
b forall a. Num a => a -> a -> a
+ Double
fforall a. Num a => a -> a -> a
*(Double
b'forall a. Num a => a -> a -> a
-Double
b))
formatMessage :: Double -> Double -> String
formatMessage :: Double -> Double -> [Char]
formatMessage Double
secs Double
perc =
(if forall a. RealFloat a => a -> Bool
isNaN Double
secs Bool -> Bool -> Bool
|| Double
secs forall a. Ord a => a -> a -> Bool
< Double
0 then [Char]
"??s" else Int -> [Char]
showMinSec forall a b. (a -> b) -> a -> b
$ forall a b. (RealFrac a, Integral b) => a -> b
ceiling Double
secs) forall a. [a] -> [a] -> [a]
++ [Char]
" (" forall a. [a] -> [a] -> [a]
++
(if forall a. RealFloat a => a -> Bool
isNaN Double
perc Bool -> Bool -> Bool
|| Double
perc forall a. Ord a => a -> a -> Bool
< Double
0 Bool -> Bool -> Bool
|| Double
perc forall a. Ord a => a -> a -> Bool
> Double
100 then [Char]
"??" else forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall a b. (RealFrac a, Integral b) => a -> b
floor Double
perc) forall a. [a] -> [a] -> [a]
++ [Char]
"%)"
showMinSec :: Int -> String
showMinSec :: Int -> [Char]
showMinSec Int
secs = (if Int
m forall a. Eq a => a -> a -> Bool
== Int
0 then [Char]
"" else forall a. Show a => a -> [Char]
show Int
m forall a. [a] -> [a] -> [a]
++ [Char]
"m" forall a. [a] -> [a] -> [a]
++ [Char
'0' | Int
s forall a. Ord a => a -> a -> Bool
< Int
10]) forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
s forall a. [a] -> [a] -> [a]
++ [Char]
"s"
where (Int
m,Int
s) = forall a. Integral a => a -> a -> (a, a)
divMod Int
secs Int
60
liftA2' :: Applicative m => m a -> m b -> (a -> b -> c) -> m c
liftA2' :: forall (m :: * -> *) a b c.
Applicative m =>
m a -> m b -> (a -> b -> c) -> m c
liftA2' m a
a m b
b a -> b -> c
f = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> b -> c
f m a
a m b
b
message :: Mealy (Double, Progress) (Double, Progress) -> Mealy (Double, Progress) (Double, Double, String)
message :: Mealy (Double, Progress) (Double, Progress)
-> Mealy (Double, Progress) (Double, Double, [Char])
message Mealy (Double, Progress) (Double, Progress)
input = forall (f :: * -> *) a b c d.
Applicative f =>
(a -> b -> c -> d) -> f a -> f b -> f c -> f d
liftA3 (,,) Mealy (Double, Progress) Double
time Mealy (Double, Progress) Double
perc Mealy (Double, Progress) [Char]
debug
where
progress :: Mealy (Double, Progress) Progress
progress = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mealy (Double, Progress) (Double, Progress)
input
secs :: Mealy (Double, Progress) Double
secs = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mealy (Double, Progress) (Double, Progress)
input
debug :: Mealy (Double, Progress) [Char]
debug = (\Double
donePerSec Double
ruleTime (Double
todoKnown,Int
todoUnknown) ->
[Char]
"Progress: " forall a. [a] -> [a] -> [a]
++
[Char]
"((known=" forall a. [a] -> [a] -> [a]
++ forall a. RealFloat a => Int -> a -> [Char]
showDP Int
2 Double
todoKnown forall a. [a] -> [a] -> [a]
++ [Char]
"s) + " forall a. [a] -> [a] -> [a]
++
[Char]
"(unknown=" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
todoUnknown forall a. [a] -> [a] -> [a]
++ [Char]
" * time=" forall a. [a] -> [a] -> [a]
++ forall a. RealFloat a => Int -> a -> [Char]
showDP Int
2 Double
ruleTime forall a. [a] -> [a] -> [a]
++ [Char]
"s)) " forall a. [a] -> [a] -> [a]
++
[Char]
"(rate=" forall a. [a] -> [a] -> [a]
++ forall a. RealFloat a => Int -> a -> [Char]
showDP Int
2 Double
donePerSec forall a. [a] -> [a] -> [a]
++ [Char]
"))")
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mealy (Double, Progress) Double
donePerSec forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mealy (Double, Progress) Double
ruleTime forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Progress -> (Double, Int)
timeTodo forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mealy (Double, Progress) Progress
progress)
done :: Mealy (Double, Progress) Double
done = Progress -> Double
timeBuilt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mealy (Double, Progress) Progress
progress
donePerSec :: Mealy (Double, Progress) Double
donePerSec = forall i a. Mealy i Bool -> Mealy i a -> Mealy i a -> Mealy i a
iff (forall a. Eq a => a -> a -> Bool
(==) Double
0 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mealy (Double, Progress) Double
done) (forall (f :: * -> *) a. Applicative f => a -> f a
pure Double
1) Mealy (Double, Progress) Double
perSecStable
where perSecStable :: Mealy (Double, Progress) Double
perSecStable = forall i a. Mealy i (Bool, a) -> Mealy i a
latch forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Eq a => a -> a -> Bool
(==) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a i. a -> Mealy i a -> Mealy i (a, a)
oldMealy Double
0 Mealy (Double, Progress) Double
done) Mealy (Double, Progress) Double
perSecRaw
perSecRaw :: Mealy (Double, Progress) Double
perSecRaw = forall i.
Double -> Mealy i Double -> Mealy i Double -> Mealy i Double
decay Double
1.2 Mealy (Double, Progress) Double
done Mealy (Double, Progress) Double
secs
ruleTime :: Mealy (Double, Progress) Double
ruleTime = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (Int, Double) -> (Int, Double) -> Double
weightedAverage
(forall {b} {b}.
(Mealy (Double, Progress) b
-> Mealy (Double, Progress) Double -> Mealy (Double, Progress) b)
-> (Progress -> b)
-> (Progress -> Int)
-> Mealy (Double, Progress) (Int, b)
f (forall i.
Double -> Mealy i Double -> Mealy i Double -> Mealy i Double
decay Double
10) Progress -> Double
timeBuilt Progress -> Int
countBuilt)
(forall {b} {b}.
(Mealy (Double, Progress) b
-> Mealy (Double, Progress) Double -> Mealy (Double, Progress) b)
-> (Progress -> b)
-> (Progress -> Int)
-> Mealy (Double, Progress) (Int, b)
f (forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall a. Fractional a => a -> a -> a
(/)) (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. Progress -> (Double, Int)
timeTodo) (\Progress{Double
Int
Maybe [Char]
(Double, Int)
isFailure :: Progress -> Maybe [Char]
timeTodo :: (Double, Int)
timeUnknown :: Double
timeBuilt :: Double
timeSkipped :: Double
countTodo :: Int
countUnknown :: Int
countBuilt :: Int
countSkipped :: Int
isFailure :: Maybe [Char]
countTodo :: Progress -> Int
timeTodo :: Progress -> (Double, Int)
timeUnknown :: Progress -> Double
countUnknown :: Progress -> Int
timeSkipped :: Progress -> Double
countSkipped :: Progress -> Int
timeBuilt :: Progress -> Double
countBuilt :: Progress -> Int
..} -> Int
countTodo forall a. Num a => a -> a -> a
- forall a b. (a, b) -> b
snd (Double, Int)
timeTodo))
where
weightedAverage :: (Int, Double) -> (Int, Double) -> Double
weightedAverage (Int
w1,Double
x1) (Int
w2,Double
x2)
| Int
w1 forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Int
w2 forall a. Eq a => a -> a -> Bool
== Int
0 = Double
0
| Bool
otherwise = ((Int
w1 Int -> Double -> Double
*. Double
x1) forall a. Num a => a -> a -> a
+ (Int
w2 Int -> Double -> Double
*. Double
x2)) forall a. Fractional a => a -> a -> a
/ Int -> Double
intToDouble (Int
w1forall a. Num a => a -> a -> a
+Int
w2)
where Int
i *. :: Int -> Double -> Double
*. Double
d = if Int
i forall a. Eq a => a -> a -> Bool
== Int
0 then Double
0 else Int -> Double
intToDouble Int
i forall a. Num a => a -> a -> a
* Double
d
f :: (Mealy (Double, Progress) b
-> Mealy (Double, Progress) Double -> Mealy (Double, Progress) b)
-> (Progress -> b)
-> (Progress -> Int)
-> Mealy (Double, Progress) (Int, b)
f Mealy (Double, Progress) b
-> Mealy (Double, Progress) Double -> Mealy (Double, Progress) b
divide Progress -> b
time Progress -> Int
count = let xs :: Mealy (Double, Progress) Int
xs = Progress -> Int
count forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mealy (Double, Progress) Progress
progress in forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) Mealy (Double, Progress) Int
xs forall a b. (a -> b) -> a -> b
$ Mealy (Double, Progress) b
-> Mealy (Double, Progress) Double -> Mealy (Double, Progress) b
divide (Progress -> b
time forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mealy (Double, Progress) Progress
progress) (Int -> Double
intToDouble forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mealy (Double, Progress) Int
xs)
todo :: Mealy (Double, Progress) Double
todo = Progress -> Double -> Double
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mealy (Double, Progress) Progress
progress forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mealy (Double, Progress) Double
ruleTime
where f :: Progress -> Double -> Double
f Progress{Double
Int
Maybe [Char]
(Double, Int)
timeTodo :: (Double, Int)
timeUnknown :: Double
timeBuilt :: Double
timeSkipped :: Double
countTodo :: Int
countUnknown :: Int
countBuilt :: Int
countSkipped :: Int
isFailure :: Maybe [Char]
isFailure :: Progress -> Maybe [Char]
countTodo :: Progress -> Int
timeTodo :: Progress -> (Double, Int)
timeUnknown :: Progress -> Double
countUnknown :: Progress -> Int
timeSkipped :: Progress -> Double
countSkipped :: Progress -> Int
timeBuilt :: Progress -> Double
countBuilt :: Progress -> Int
..} Double
ruleTime = forall a b. (a, b) -> a
fst (Double, Int)
timeTodo forall a. Num a => a -> a -> a
+ (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a b. (a, b) -> b
snd (Double, Int)
timeTodo) forall a. Num a => a -> a -> a
* Double
ruleTime)
time :: Mealy (Double, Progress) Double
time = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall a. Fractional a => a -> a -> a
(/) Mealy (Double, Progress) Double
todo Mealy (Double, Progress) Double
donePerSec
perc :: Mealy (Double, Progress) Double
perc = forall i a. Mealy i Bool -> Mealy i a -> Mealy i a -> Mealy i a
iff (forall a. Eq a => a -> a -> Bool
(==) Double
0 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mealy (Double, Progress) Double
done) (forall (f :: * -> *) a. Applicative f => a -> f a
pure Double
0) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a b c.
Applicative m =>
m a -> m b -> (a -> b -> c) -> m c
liftA2' Mealy (Double, Progress) Double
done Mealy (Double, Progress) Double
todo forall a b. (a -> b) -> a -> b
$ \Double
done Double
todo -> Double
100 forall a. Num a => a -> a -> a
* Double
done forall a. Fractional a => a -> a -> a
/ (Double
done forall a. Num a => a -> a -> a
+ Double
todo)
progressDisplay :: Double -> (String -> IO ()) -> IO Progress -> IO ()
progressDisplay :: Double -> ([Char] -> IO ()) -> IO Progress -> IO ()
progressDisplay Double
sample [Char] -> IO ()
disp IO Progress
prog = do
[Char] -> IO ()
disp [Char]
"Starting..."
IO Double
time <- IO (IO Double)
offsetTime
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> (b -> IO a) -> IO a
catchJust (\AsyncException
x -> if AsyncException
x forall a. Eq a => a -> a -> Bool
== AsyncException
ThreadKilled then forall a. a -> Maybe a
Just () else forall a. Maybe a
Nothing)
(IO Double
-> Mealy (Double, Progress) (Double, Double, [Char]) -> IO ()
loop IO Double
time forall a b. (a -> b) -> a -> b
$ Mealy (Double, Progress) (Double, Progress)
-> Mealy (Double, Progress) (Double, Double, [Char])
message forall i. Mealy i i
echoMealy)
(forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ do Double
t <- IO Double
time; [Char] -> IO ()
disp forall a b. (a -> b) -> a -> b
$ [Char]
"Finished in " forall a. [a] -> [a] -> [a]
++ Double -> [Char]
showDuration Double
t)
where
loop :: IO Double -> Mealy (Double, Progress) (Double, Double, String) -> IO ()
loop :: IO Double
-> Mealy (Double, Progress) (Double, Double, [Char]) -> IO ()
loop IO Double
time Mealy (Double, Progress) (Double, Double, [Char])
mealy = do
Double -> IO ()
sleep Double
sample
Progress
p <- IO Progress
prog
Double
t <- IO Double
time
((Double
secs,Double
perc,[Char]
_debug), Mealy (Double, Progress) (Double, Double, [Char])
mealy)<- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall i a. Mealy i a -> i -> (a, Mealy i a)
runMealy Mealy (Double, Progress) (Double, Double, [Char])
mealy (Double
t, Progress
p)
let done :: Int
done = Progress -> Int
countSkipped Progress
p forall a. Num a => a -> a -> a
+ Progress -> Int
countBuilt Progress
p
let todo :: Int
todo = Int
done forall a. Num a => a -> a -> a
+ Progress -> Int
countUnknown Progress
p forall a. Num a => a -> a -> a
+ Progress -> Int
countTodo Progress
p
[Char] -> IO ()
disp forall a b. (a -> b) -> a -> b
$
[Char]
"Running for " forall a. [a] -> [a] -> [a]
++ Double -> [Char]
showDurationSecs Double
t forall a. [a] -> [a] -> [a]
++ [Char]
" [" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
done forall a. [a] -> [a] -> [a]
++ [Char]
"/" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
todo forall a. [a] -> [a] -> [a]
++ [Char]
"]" forall a. [a] -> [a] -> [a]
++
[Char]
", predicted " forall a. [a] -> [a] -> [a]
++ Double -> Double -> [Char]
formatMessage Double
secs Double
perc forall a. [a] -> [a] -> [a]
++
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" ([Char]
", Failure! " forall a. [a] -> [a] -> [a]
++) (Progress -> Maybe [Char]
isFailure Progress
p)
IO Double
-> Mealy (Double, Progress) (Double, Double, [Char]) -> IO ()
loop IO Double
time Mealy (Double, Progress) (Double, Double, [Char])
mealy
data ProgressEntry = ProgressEntry
{ProgressEntry -> Double
idealSecs :: Double, ProgressEntry -> Double
idealPerc :: Double
,ProgressEntry -> Double
actualSecs :: Double, ProgressEntry -> Double
actualPerc :: Double
}
isInvalid :: ProgressEntry -> Bool
isInvalid :: ProgressEntry -> Bool
isInvalid ProgressEntry{Double
actualPerc :: Double
actualSecs :: Double
idealPerc :: Double
idealSecs :: Double
actualPerc :: ProgressEntry -> Double
actualSecs :: ProgressEntry -> Double
idealPerc :: ProgressEntry -> Double
idealSecs :: ProgressEntry -> Double
..} = forall a. RealFloat a => a -> Bool
isNaN Double
actualSecs Bool -> Bool -> Bool
|| forall a. RealFloat a => a -> Bool
isNaN Double
actualPerc
progressReplay :: [(Double, Progress)] -> [ProgressEntry]
progressReplay :: [(Double, Progress)] -> [ProgressEntry]
progressReplay [] = []
progressReplay [(Double, Progress)]
ps = forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL forall {b} {c}.
Mealy (Double, b) (Double, Double, c)
-> (Double, b)
-> (Mealy (Double, b) (Double, Double, c), ProgressEntry)
f (Mealy (Double, Progress) (Double, Progress)
-> Mealy (Double, Progress) (Double, Double, [Char])
message forall i. Mealy i i
echoMealy) [(Double, Progress)]
ps
where
end :: Double
end = forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last [(Double, Progress)]
ps
f :: Mealy (Double, b) (Double, Double, c)
-> (Double, b)
-> (Mealy (Double, b) (Double, Double, c), ProgressEntry)
f Mealy (Double, b) (Double, Double, c)
a (Double
time,b
p) = (Mealy (Double, b) (Double, Double, c)
a2, Double -> Double -> Double -> Double -> ProgressEntry
ProgressEntry (Double
end forall a. Num a => a -> a -> a
- Double
time) (Double
time forall a. Num a => a -> a -> a
* Double
100 forall a. Fractional a => a -> a -> a
/ Double
end) Double
secs Double
perc)
where ((Double
secs,Double
perc,c
_),Mealy (Double, b) (Double, Double, c)
a2) = forall i a. Mealy i a -> i -> (a, Mealy i a)
runMealy Mealy (Double, b) (Double, Double, c)
a (Double
time,b
p)
writeProgressReport :: FilePath -> [(FilePath, [(Double, Progress)])] -> IO ()
writeProgressReport :: [Char] -> [([Char], [(Double, Progress)])] -> IO ()
writeProgressReport [Char]
out (forall a b. (a -> b) -> [a] -> [b]
map (forall b b' a. (b -> b') -> (a, b) -> (a, b')
second [(Double, Progress)] -> [ProgressEntry]
progressReplay) -> [([Char], [ProgressEntry])]
xs)
| ([Char]
bad,[ProgressEntry]
_):[([Char], [ProgressEntry])]
_ <- forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ProgressEntry -> Bool
isInvalid forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [([Char], [ProgressEntry])]
xs = forall a. Partial => [Char] -> IO a
errorIO forall a b. (a -> b) -> a -> b
$ [Char]
"Progress generates NaN for " forall a. [a] -> [a] -> [a]
++ [Char]
bad
| [Char] -> [Char]
takeExtension [Char]
out forall a. Eq a => a -> a -> Bool
== [Char]
".js" = [Char] -> [Char] -> IO ()
writeFile [Char]
out forall a b. (a -> b) -> a -> b
$ [Char]
"var shake = \n" forall a. [a] -> [a] -> [a]
++ [([Char], [ProgressEntry])] -> [Char]
generateJSON [([Char], [ProgressEntry])]
xs
| [Char] -> [Char]
takeExtension [Char]
out forall a. Eq a => a -> a -> Bool
== [Char]
".json" = [Char] -> [Char] -> IO ()
writeFile [Char]
out forall a b. (a -> b) -> a -> b
$ [([Char], [ProgressEntry])] -> [Char]
generateJSON [([Char], [ProgressEntry])]
xs
| [Char]
out forall a. Eq a => a -> a -> Bool
== [Char]
"-" = [Char] -> IO ()
putStr forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines forall a b. (a -> b) -> a -> b
$ [([Char], [ProgressEntry])] -> [[Char]]
generateSummary [([Char], [ProgressEntry])]
xs
| Bool
otherwise = [Char] -> ByteString -> IO ()
LBS.writeFile [Char]
out forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [([Char], [ProgressEntry])] -> IO ByteString
generateHTML [([Char], [ProgressEntry])]
xs
generateSummary :: [(FilePath, [ProgressEntry])] -> [String]
generateSummary :: [([Char], [ProgressEntry])] -> [[Char]]
generateSummary [([Char], [ProgressEntry])]
xs = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [([Char], [ProgressEntry])]
xs forall a b. (a -> b) -> a -> b
$ \([Char]
file,[ProgressEntry]
xs) ->
[[Char]
"# " forall a. [a] -> [a] -> [a]
++ [Char]
file, forall {a} {a}.
RealFrac a =>
[a] -> [Char] -> (a -> a) -> (a -> a) -> [Char]
f [ProgressEntry]
xs [Char]
"Seconds" ProgressEntry -> Double
idealSecs ProgressEntry -> Double
actualSecs, forall {a} {a}.
RealFrac a =>
[a] -> [Char] -> (a -> a) -> (a -> a) -> [Char]
f [ProgressEntry]
xs [Char]
"Percent" ProgressEntry -> Double
idealPerc ProgressEntry -> Double
actualPerc]
where
levels :: [Int]
levels = [Int
100,Int
90,Int
80,Int
50]
f :: [a] -> [Char] -> (a -> a) -> (a -> a) -> [Char]
f [a]
xs [Char]
lbl a -> a
ideal a -> a
actual = [Char]
lbl forall a. [a] -> [a] -> [a]
++ [Char]
": " forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", "
[forall a. Show a => a -> [Char]
show Int
l forall a. [a] -> [a] -> [a]
++ [Char]
"% within " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall a b. (RealFrac a, Integral b) => a -> b
ceiling forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall a b. (a -> b) -> a -> b
$ a
0 forall a. a -> [a] -> [a]
: forall a. Int -> [a] -> [a]
take ((forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs forall a. Num a => a -> a -> a
* Int
l) forall a. Integral a => a -> a -> a
`div` Int
100) [a]
diff) | Int
l <- [Int]
levels]
where diff :: [a]
diff = forall a. Ord a => [a] -> [a]
sort [forall a. Num a => a -> a
abs forall a b. (a -> b) -> a -> b
$ a -> a
ideal a
x forall a. Num a => a -> a -> a
- a -> a
actual a
x | a
x <- [a]
xs]
generateHTML :: [(FilePath, [ProgressEntry])] -> IO LBS.ByteString
generateHTML :: [([Char], [ProgressEntry])] -> IO ByteString
generateHTML [([Char], [ProgressEntry])]
xs = do
ByteString
report <- [Char] -> IO ByteString
readDataFileHTML [Char]
"progress.html"
let f :: [Char] -> f ByteString
f [Char]
"data/progress-data.js" = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString
LBS.pack forall a b. (a -> b) -> a -> b
$ [Char]
"var progress =\n" forall a. [a] -> [a] -> [a]
++ [([Char], [ProgressEntry])] -> [Char]
generateJSON [([Char], [ProgressEntry])]
xs
([Char] -> IO ByteString) -> ByteString -> IO ByteString
runTemplate forall {f :: * -> *}. Applicative f => [Char] -> f ByteString
f ByteString
report
generateJSON :: [(FilePath, [ProgressEntry])] -> String
generateJSON :: [([Char], [ProgressEntry])] -> [Char]
generateJSON = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [[Char]]
jsonList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ((forall a. [a] -> [a] -> [a]
++[Char]
"}") forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [Char]
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char], [ProgressEntry]) -> [[Char]]
f)
where
f :: ([Char], [ProgressEntry]) -> [[Char]]
f ([Char]
file,[ProgressEntry]
ps) =
([Char]
"{\"name\":" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show ([Char] -> [Char]
takeFileName [Char]
file) forall a. [a] -> [a] -> [a]
++ [Char]
", \"values\":") forall a. a -> [a] -> [a]
:
[[Char]] -> [[Char]]
indent ([[Char]] -> [[Char]]
jsonList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ProgressEntry -> [Char]
g [ProgressEntry]
ps)
shw :: Double -> [Char]
shw = forall a. RealFloat a => Int -> a -> [Char]
showDP Int
1
g :: ProgressEntry -> [Char]
g ProgressEntry{Double
actualPerc :: Double
actualSecs :: Double
idealPerc :: Double
idealSecs :: Double
actualPerc :: ProgressEntry -> Double
actualSecs :: ProgressEntry -> Double
idealPerc :: ProgressEntry -> Double
idealSecs :: ProgressEntry -> Double
..} = forall {a}. Show a => [(a, [Char])] -> [Char]
jsonObject
[([Char]
"idealSecs",Double -> [Char]
shw Double
idealSecs),([Char]
"idealPerc",Double -> [Char]
shw Double
idealPerc)
,([Char]
"actualSecs",Double -> [Char]
shw Double
actualSecs),([Char]
"actualPerc",Double -> [Char]
shw Double
actualPerc)]
indent :: [[Char]] -> [[Char]]
indent = forall a b. (a -> b) -> [a] -> [b]
map ([Char]
" "forall a. [a] -> [a] -> [a]
++)
jsonList :: [[Char]] -> [[Char]]
jsonList [[Char]]
xs = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (:) (Char
'['forall a. a -> [a] -> [a]
:forall a. a -> [a]
repeat Char
',') [[Char]]
xs forall a. [a] -> [a] -> [a]
++ [[Char]
"]"]
jsonObject :: [(a, [Char])] -> [Char]
jsonObject [(a, [Char])]
xs = [Char]
"{" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " [forall a. Show a => a -> [Char]
show a
a forall a. [a] -> [a] -> [a]
++ [Char]
":" forall a. [a] -> [a] -> [a]
++ [Char]
b | (a
a,[Char]
b) <- [(a, [Char])]
xs] forall a. [a] -> [a] -> [a]
++ [Char]
"}"
progressTitlebar :: String -> IO ()
progressTitlebar :: [Char] -> IO ()
progressTitlebar [Char]
x = forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM IO Bool
win IO ()
lin
where
#ifdef mingw32_HOST_OS
win = withCWString x c_setConsoleTitleW
#else
win :: IO Bool
win = forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
#endif
lin :: IO ()
lin = forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM IO Bool
checkEscCodes forall a b. (a -> b) -> a -> b
$ OneShot BS_Store -> IO ()
BS.putStr forall a b. (a -> b) -> a -> b
$ [Char] -> OneShot BS_Store
BS.pack forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
escWindowTitle [Char]
x
progressProgram :: IO (String -> IO ())
progressProgram :: IO ([Char] -> IO ())
progressProgram = do
Maybe [Char]
exe <- [Char] -> IO (Maybe [Char])
findExecutable [Char]
"shake-progress"
case Maybe [Char]
exe of
Maybe [Char]
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just [Char]
exe -> do
IORef (Maybe [[Char]])
lastArgs <- forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ \[Char]
msg -> do
let failure :: Bool
failure = [Char]
" Failure! " forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` [Char]
msg
let perc :: [Char]
perc = let ([Char]
a,[Char]
b) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
'%') [Char]
msg
in if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
b then [Char]
"" else forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isDigit forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [Char]
a
let state :: [Char]
state | [Char]
perc forall a. Eq a => a -> a -> Bool
== [Char]
"" = [Char]
"NoProgress"
| Bool
failure = [Char]
"Error"
| Bool
otherwise = [Char]
"Normal"
let args :: [[Char]]
args = [[Char]
"--title=" forall a. [a] -> [a] -> [a]
++ [Char]
msg, [Char]
"--state=" forall a. [a] -> [a] -> [a]
++ [Char]
state] forall a. [a] -> [a] -> [a]
++ [[Char]
"--value=" forall a. [a] -> [a] -> [a]
++ [Char]
perc | [Char]
perc forall a. Eq a => a -> a -> Bool
/= [Char]
""]
Bool
same <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (Maybe [[Char]])
lastArgs forall a b. (a -> b) -> a -> b
$ \Maybe [[Char]]
old -> (forall a. a -> Maybe a
Just [[Char]]
args, Maybe [[Char]]
old forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just [[Char]]
args)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
same forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]] -> IO ExitCode
rawSystem [Char]
exe [[Char]]
args
progressSimple :: IO Progress -> IO ()
progressSimple :: IO Progress -> IO ()
progressSimple IO Progress
p = do
[Char] -> IO ()
program <- IO ([Char] -> IO ())
progressProgram
Double -> ([Char] -> IO ()) -> IO Progress -> IO ()
progressDisplay Double
5 (\[Char]
s -> [Char] -> IO ()
progressTitlebar [Char]
s forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Char] -> IO ()
program [Char]
s) IO Progress
p