{-# LANGUAGE RecordWildCards, CPP, ViewPatterns, ForeignFunctionInterface, TupleSections #-}

-- | Progress tracking
module Development.Shake.Internal.Progress(
    progress,
    progressSimple, progressDisplay, progressTitlebar, progressProgram,
    ProgressEntry(..), progressReplay, writeProgressReport -- INTERNAL USE ONLY
    ) 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

progress :: Database -> Step -> IO Progress
progress :: Database -> Step -> IO Progress
progress Database
db Step
step = do
    [(Key, Status)]
xs <- Database -> IO [(Key, Status)]
forall k v. DatabasePoly k v -> IO [(k, v)]
getKeyValues Database
db
    Progress -> IO Progress
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Progress -> IO Progress) -> Progress -> IO Progress
forall a b. (a -> b) -> a -> b
$! (Progress -> Status -> Progress)
-> Progress -> [Status] -> Progress
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Progress -> Status -> Progress
f Progress
forall a. Monoid a => a
mempty ([Status] -> Progress) -> [Status] -> Progress
forall a b. (a -> b) -> a -> b
$ ((Key, Status) -> Status) -> [(Key, Status)] -> [Status]
forall a b. (a -> b) -> [a] -> [b]
map (Key, Status) -> Status
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 Step -> Step -> Bool
forall a. Eq a => a -> a -> Bool
== Step
built
            then Progress
s{countBuilt :: Int
countBuilt = Progress -> Int
countBuilt Progress
s Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, timeBuilt :: Double
timeBuilt = Progress -> Double
timeBuilt Progress
s Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Float -> Double
g Float
execution}
            else Progress
s{countSkipped :: Int
countSkipped = Progress -> Int
countSkipped Progress
s Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, timeSkipped :: Double
timeSkipped = Progress -> Double
timeSkipped Progress
s Double -> Double -> Double
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, timeUnknown :: Double
timeUnknown = Progress -> Double
timeUnknown Progress
s Double -> Double -> Double
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 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Float -> Double
g Float
execution in Double
d2 Double -> (Double, Int) -> (Double, Int)
`seq` (Double
d2,Int
c)
                  | Bool
otherwise = let c2 :: Int
c2 = Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 in Int
c2 Int -> (Double, Int) -> (Double, Int)
`seq` (Double
d,Int
c2)
            in Progress
s{countTodo :: Int
countTodo = Progress -> Int
countTodo Progress
s Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, timeTodo :: (Double, Int)
timeTodo = (Double, Int)
t}
        f Progress
s Status
_ = Progress
s



---------------------------------------------------------------------
-- MEALY TYPE - for writing the progress functions
-- See <https://hackage.haskell.org/package/machines-0.2.3.1/docs/Data-Machine-Mealy.html>

-- | A machine that takes inputs and produces outputs
newtype Mealy i a = Mealy {Mealy i a -> i -> (a, Mealy i a)
runMealy :: i -> (a, Mealy i a)}

instance Functor (Mealy i) where
    fmap :: (a -> b) -> Mealy i a -> Mealy i b
fmap a -> b
f (Mealy i -> (a, Mealy i a)
m) = (i -> (b, Mealy i b)) -> Mealy i b
forall i a. (i -> (a, Mealy i a)) -> Mealy i a
Mealy ((i -> (b, Mealy i b)) -> Mealy i b)
-> (i -> (b, Mealy i b)) -> Mealy i b
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, (a -> b) -> Mealy i a -> Mealy i b
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 :: a -> Mealy i a
pure a
x = let r :: Mealy b a
r = (b -> (a, Mealy b a)) -> Mealy b a
forall i a. (i -> (a, Mealy i a)) -> Mealy i a
Mealy ((a, Mealy b a) -> b -> (a, Mealy b a)
forall a b. a -> b -> a
const (a
x, Mealy b a
r)) in Mealy i a
forall b. Mealy b a
r
    Mealy i -> (a -> b, Mealy i (a -> b))
mf <*> :: Mealy i (a -> b) -> Mealy i a -> Mealy i b
<*> Mealy i -> (a, Mealy i a)
mx = (i -> (b, Mealy i b)) -> Mealy i b
forall i a. (i -> (a, Mealy i a)) -> Mealy i a
Mealy ((i -> (b, Mealy i b)) -> Mealy i b)
-> (i -> (b, Mealy i b)) -> Mealy i b
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 Mealy i (a -> b) -> Mealy i a -> Mealy i b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mealy i a
mx)

echoMealy :: Mealy i i
echoMealy :: Mealy i i
echoMealy = (i -> (i, Mealy i i)) -> Mealy i i
forall i a. (i -> (a, Mealy i a)) -> Mealy i a
Mealy (,Mealy i i
forall i. Mealy i i
echoMealy)

scanMealy :: (a -> b -> a) -> a -> Mealy i b -> Mealy i a
scanMealy :: (a -> b -> a) -> a -> Mealy i b -> Mealy i a
scanMealy a -> b -> a
f a
z (Mealy i -> (b, Mealy i b)
m) = (i -> (a, Mealy i a)) -> Mealy i a
forall i a. (i -> (a, Mealy i a)) -> Mealy i a
Mealy ((i -> (a, Mealy i a)) -> Mealy i a)
-> (i -> (a, Mealy i a)) -> Mealy i a
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, (a -> b -> a) -> a -> Mealy i b -> Mealy i a
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)


---------------------------------------------------------------------
-- MEALY UTILITIES

oldMealy :: a -> Mealy i a -> Mealy i (a,a)
oldMealy :: a -> Mealy i a -> Mealy i (a, a)
oldMealy a
old = ((a, a) -> a -> (a, a)) -> (a, a) -> Mealy i a -> Mealy i (a, a)
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 :: Mealy i (Bool, a) -> Mealy i a
latch Mealy i (Bool, a)
s = Maybe a -> a
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe a -> a) -> Mealy i (Maybe a) -> Mealy i a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe a -> (Bool, a) -> Maybe a)
-> Maybe a -> Mealy i (Bool, a) -> Mealy i (Maybe a)
forall a b i. (a -> b -> a) -> a -> Mealy i b -> Mealy i a
scanMealy Maybe a -> (Bool, a) -> Maybe a
forall a. Maybe a -> (Bool, a) -> Maybe a
f Maybe a
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) = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ if Bool
b then a -> Maybe a -> a
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 :: 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) (Bool -> a -> a -> a) -> Mealy i Bool -> Mealy i (a -> a -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mealy i Bool
c Mealy i (a -> a -> a) -> Mealy i a -> Mealy i (a -> a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mealy i a
t Mealy i (a -> a) -> Mealy i a -> Mealy i a
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mealy i a
f

-- decay'd division, compute a/b, with a decay of f
-- r' is the new result, r is the last result
-- r' ~= a' / b'
-- r' = r*b + f*(a'-a)
--      -------------
--      b + f*(b'-b)
-- when f == 1, r == r'
--
-- both streams must only ever increase
decay :: Double -> Mealy i Double -> Mealy i Double -> Mealy i Double
decay :: Double -> Mealy i Double -> Mealy i Double -> Mealy i Double
decay Double
f Mealy i Double
a Mealy i Double
b = (Double -> ((Double, Double), (Double, Double)) -> Double)
-> Double
-> Mealy i ((Double, Double), (Double, Double))
-> Mealy i Double
forall a b i. (a -> b -> a) -> a -> Mealy i b -> Mealy i a
scanMealy Double -> ((Double, Double), (Double, Double)) -> Double
step Double
0 (Mealy i ((Double, Double), (Double, Double)) -> Mealy i Double)
-> Mealy i ((Double, Double), (Double, Double)) -> Mealy i Double
forall a b. (a -> b) -> a -> b
$ (,) ((Double, Double)
 -> (Double, Double) -> ((Double, Double), (Double, Double)))
-> Mealy i (Double, Double)
-> Mealy
     i ((Double, Double) -> ((Double, Double), (Double, Double)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Double -> Mealy i Double -> Mealy i (Double, Double)
forall a i. a -> Mealy i a -> Mealy i (a, a)
oldMealy Double
0 Mealy i Double
a Mealy i ((Double, Double) -> ((Double, Double), (Double, Double)))
-> Mealy i (Double, Double)
-> Mealy i ((Double, Double), (Double, Double))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Double -> Mealy i Double -> Mealy i (Double, Double)
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 Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
r then Double
a' Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
b' else ((Double
rDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
b) Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
fDouble -> Double -> Double
forall a. Num a => a -> a -> a
*(Double
a'Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
a)) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Double
b Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
fDouble -> Double -> Double
forall a. Num a => a -> a -> a
*(Double
b'Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
b))


---------------------------------------------------------------------
-- MESSAGE GENERATOR

formatMessage :: Double -> Double -> String
formatMessage :: Double -> Double -> String
formatMessage Double
secs Double
perc =
    (if Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
secs Bool -> Bool -> Bool
|| Double
secs Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0 then String
"??s" else Int -> String
showMinSec (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
ceiling Double
secs) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++
    (if Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
perc Bool -> Bool -> Bool
|| Double
perc Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0 Bool -> Bool -> Bool
|| Double
perc Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
100 then String
"??" else Integer -> String
forall a. Show a => a -> String
show (Integer -> String) -> Integer -> String
forall a b. (a -> b) -> a -> b
$ Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
floor Double
perc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"%)"

showMinSec :: Int -> String
showMinSec :: Int -> String
showMinSec Int
secs = (if Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then String
"" else Int -> String
forall a. Show a => a -> String
show Int
m String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"m" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
'0' | Int
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
10]) String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"s"
    where (Int
m,Int
s) = Int -> Int -> (Int, Int)
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' :: m a -> m b -> (a -> b -> c) -> m c
liftA2' m a
a m b
b a -> b -> c
f = (a -> b -> c) -> m a -> m b -> m c
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


-- | return (number of seconds, percentage, explanation)
message :: Mealy (Double, Progress) (Double, Progress) -> Mealy (Double, Progress) (Double, Double, String)
message :: Mealy (Double, Progress) (Double, Progress)
-> Mealy (Double, Progress) (Double, Double, String)
message Mealy (Double, Progress) (Double, Progress)
input = (Double -> Double -> String -> (Double, Double, String))
-> Mealy (Double, Progress) Double
-> Mealy (Double, Progress) Double
-> Mealy (Double, Progress) String
-> Mealy (Double, Progress) (Double, Double, String)
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) String
debug
    where
        progress :: Mealy (Double, Progress) Progress
progress = (Double, Progress) -> Progress
forall a b. (a, b) -> b
snd ((Double, Progress) -> Progress)
-> Mealy (Double, Progress) (Double, Progress)
-> Mealy (Double, Progress) Progress
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mealy (Double, Progress) (Double, Progress)
input
        secs :: Mealy (Double, Progress) Double
secs = (Double, Progress) -> Double
forall a b. (a, b) -> a
fst ((Double, Progress) -> Double)
-> Mealy (Double, Progress) (Double, Progress)
-> Mealy (Double, Progress) Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mealy (Double, Progress) (Double, Progress)
input
        debug :: Mealy (Double, Progress) String
debug = (\Double
donePerSec Double
ruleTime (Double
todoKnown,Int
todoUnknown) ->
            String
"Progress: " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                String
"((known=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Double -> String
forall a. RealFloat a => Int -> a -> String
showDP Int
2 Double
todoKnown String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"s) + " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                String
"(unknown=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
todoUnknown String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" * time=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Double -> String
forall a. RealFloat a => Int -> a -> String
showDP Int
2 Double
ruleTime String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"s)) " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                String
"(rate=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Double -> String
forall a. RealFloat a => Int -> a -> String
showDP Int
2 Double
donePerSec String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"))")
            (Double -> Double -> (Double, Int) -> String)
-> Mealy (Double, Progress) Double
-> Mealy (Double, Progress) (Double -> (Double, Int) -> String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mealy (Double, Progress) Double
donePerSec Mealy (Double, Progress) (Double -> (Double, Int) -> String)
-> Mealy (Double, Progress) Double
-> Mealy (Double, Progress) ((Double, Int) -> String)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mealy (Double, Progress) Double
ruleTime Mealy (Double, Progress) ((Double, Int) -> String)
-> Mealy (Double, Progress) (Double, Int)
-> Mealy (Double, Progress) String
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Progress -> (Double, Int)
timeTodo (Progress -> (Double, Int))
-> Mealy (Double, Progress) Progress
-> Mealy (Double, Progress) (Double, Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mealy (Double, Progress) Progress
progress)

        -- Number of seconds work completed in this build run
        -- Ignores timeSkipped which would be more truthful, but it makes the % drop sharply
        -- which isn't what users want
        done :: Mealy (Double, Progress) Double
done = Progress -> Double
timeBuilt (Progress -> Double)
-> Mealy (Double, Progress) Progress
-> Mealy (Double, Progress) Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mealy (Double, Progress) Progress
progress

        -- Work done per second, don't divide by 0 and don't update if 'done' doesn't change
        donePerSec :: Mealy (Double, Progress) Double
donePerSec = Mealy (Double, Progress) Bool
-> Mealy (Double, Progress) Double
-> Mealy (Double, Progress) Double
-> Mealy (Double, Progress) Double
forall i a. Mealy i Bool -> Mealy i a -> Mealy i a -> Mealy i a
iff (Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
(==) Double
0 (Double -> Bool)
-> Mealy (Double, Progress) Double -> Mealy (Double, Progress) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mealy (Double, Progress) Double
done) (Double -> Mealy (Double, Progress) Double
forall (f :: * -> *) a. Applicative f => a -> f a
pure Double
1) Mealy (Double, Progress) Double
perSecStable
            where perSecStable :: Mealy (Double, Progress) Double
perSecStable = Mealy (Double, Progress) (Bool, Double)
-> Mealy (Double, Progress) Double
forall i a. Mealy i (Bool, a) -> Mealy i a
latch (Mealy (Double, Progress) (Bool, Double)
 -> Mealy (Double, Progress) Double)
-> Mealy (Double, Progress) (Bool, Double)
-> Mealy (Double, Progress) Double
forall a b. (a -> b) -> a -> b
$ (Bool -> Double -> (Bool, Double))
-> Mealy (Double, Progress) Bool
-> Mealy (Double, Progress) Double
-> Mealy (Double, Progress) (Bool, Double)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) ((Double -> Double -> Bool) -> (Double, Double) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
(==) ((Double, Double) -> Bool)
-> Mealy (Double, Progress) (Double, Double)
-> Mealy (Double, Progress) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Double
-> Mealy (Double, Progress) Double
-> Mealy (Double, Progress) (Double, Double)
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 = Double
-> Mealy (Double, Progress) Double
-> Mealy (Double, Progress) Double
-> Mealy (Double, Progress) Double
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

        -- Predicted build time for a rule that has never been built before
        -- The high decay means if a build goes in "phases" - lots of source files, then lots of compiling
        -- we reach a reasonable number fairly quickly, without bouncing too much
        ruleTime :: Mealy (Double, Progress) Double
ruleTime = ((Int, Double) -> (Int, Double) -> Double)
-> Mealy (Double, Progress) (Int, Double)
-> Mealy (Double, Progress) (Int, Double)
-> Mealy (Double, Progress) Double
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (Int, Double) -> (Int, Double) -> Double
weightedAverage
            ((Mealy (Double, Progress) Double
 -> Mealy (Double, Progress) Double
 -> Mealy (Double, Progress) Double)
-> (Progress -> Double)
-> (Progress -> Int)
-> Mealy (Double, Progress) (Int, Double)
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 (Double
-> Mealy (Double, Progress) Double
-> Mealy (Double, Progress) Double
-> Mealy (Double, Progress) Double
forall i.
Double -> Mealy i Double -> Mealy i Double -> Mealy i Double
decay Double
10) Progress -> Double
timeBuilt Progress -> Int
countBuilt)
            ((Mealy (Double, Progress) Double
 -> Mealy (Double, Progress) Double
 -> Mealy (Double, Progress) Double)
-> (Progress -> Double)
-> (Progress -> Int)
-> Mealy (Double, Progress) (Int, Double)
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 ((Double -> Double -> Double)
-> Mealy (Double, Progress) Double
-> Mealy (Double, Progress) Double
-> Mealy (Double, Progress) Double
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
(/)) ((Double, Int) -> Double
forall a b. (a, b) -> a
fst ((Double, Int) -> Double)
-> (Progress -> (Double, Int)) -> Progress -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Progress -> (Double, Int)
timeTodo) (\Progress{Double
Int
Maybe String
(Double, Int)
isFailure :: Progress -> Maybe String
timeTodo :: (Double, Int)
timeUnknown :: Double
timeBuilt :: Double
timeSkipped :: Double
countTodo :: Int
countUnknown :: Int
countBuilt :: Int
countSkipped :: Int
isFailure :: Maybe String
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Double, Int) -> Int
forall a b. (a, b) -> b
snd (Double, Int)
timeTodo))
            -- don't call decay on todo, since it goes up and down (as things get done)
            where
                weightedAverage :: (Int, Double) -> (Int, Double) -> Double
weightedAverage (Int
w1,Double
x1) (Int
w2,Double
x2)
                    | Int
w1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Int
w2 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Double
0
                    | Bool
otherwise = ((Int
w1 Int -> Double -> Double
*. Double
x1) Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (Int
w2 Int -> Double -> Double
*. Double
x2)) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
intToDouble (Int
w1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
w2)
                    where Int
i *. :: Int -> Double -> Double
*. Double
d = if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Double
0 else Int -> Double
intToDouble Int
i Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
d -- since d might be NaN

                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 (Progress -> Int)
-> Mealy (Double, Progress) Progress
-> Mealy (Double, Progress) Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mealy (Double, Progress) Progress
progress in (Int -> b -> (Int, b))
-> Mealy (Double, Progress) Int
-> Mealy (Double, Progress) b
-> Mealy (Double, Progress) (Int, b)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) Mealy (Double, Progress) Int
xs (Mealy (Double, Progress) b -> Mealy (Double, Progress) (Int, b))
-> Mealy (Double, Progress) b -> Mealy (Double, Progress) (Int, b)
forall a b. (a -> b) -> a -> b
$ Mealy (Double, Progress) b
-> Mealy (Double, Progress) Double -> Mealy (Double, Progress) b
divide (Progress -> b
time (Progress -> b)
-> Mealy (Double, Progress) Progress -> Mealy (Double, Progress) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mealy (Double, Progress) Progress
progress) (Int -> Double
intToDouble (Int -> Double)
-> Mealy (Double, Progress) Int -> Mealy (Double, Progress) Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mealy (Double, Progress) Int
xs)

        -- Number of seconds work remaining, ignoring multiple threads
        todo :: Mealy (Double, Progress) Double
todo = Progress -> Double -> Double
f (Progress -> Double -> Double)
-> Mealy (Double, Progress) Progress
-> Mealy (Double, Progress) (Double -> Double)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mealy (Double, Progress) Progress
progress Mealy (Double, Progress) (Double -> Double)
-> Mealy (Double, Progress) Double
-> Mealy (Double, Progress) Double
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 String
(Double, Int)
timeTodo :: (Double, Int)
timeUnknown :: Double
timeBuilt :: Double
timeSkipped :: Double
countTodo :: Int
countUnknown :: Int
countBuilt :: Int
countSkipped :: Int
isFailure :: Maybe String
isFailure :: Progress -> Maybe String
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 = (Double, Int) -> Double
forall a b. (a, b) -> a
fst (Double, Int)
timeTodo Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Double, Int) -> Int
forall a b. (a, b) -> b
snd (Double, Int)
timeTodo) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
ruleTime)

        -- Display information
        time :: Mealy (Double, Progress) Double
time = (Double -> Double -> Double)
-> Mealy (Double, Progress) Double
-> Mealy (Double, Progress) Double
-> Mealy (Double, Progress) Double
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
(/) Mealy (Double, Progress) Double
todo Mealy (Double, Progress) Double
donePerSec
        perc :: Mealy (Double, Progress) Double
perc = Mealy (Double, Progress) Bool
-> Mealy (Double, Progress) Double
-> Mealy (Double, Progress) Double
-> Mealy (Double, Progress) Double
forall i a. Mealy i Bool -> Mealy i a -> Mealy i a -> Mealy i a
iff (Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
(==) Double
0 (Double -> Bool)
-> Mealy (Double, Progress) Double -> Mealy (Double, Progress) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mealy (Double, Progress) Double
done) (Double -> Mealy (Double, Progress) Double
forall (f :: * -> *) a. Applicative f => a -> f a
pure Double
0) (Mealy (Double, Progress) Double
 -> Mealy (Double, Progress) Double)
-> Mealy (Double, Progress) Double
-> Mealy (Double, Progress) Double
forall a b. (a -> b) -> a -> b
$
            Mealy (Double, Progress) Double
-> Mealy (Double, Progress) Double
-> (Double -> Double -> Double)
-> Mealy (Double, Progress) Double
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 ((Double -> Double -> Double) -> Mealy (Double, Progress) Double)
-> (Double -> Double -> Double) -> Mealy (Double, Progress) Double
forall a b. (a -> b) -> a -> b
$ \Double
done Double
todo -> Double
100 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
done Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Double
done Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
todo)


---------------------------------------------------------------------
-- EXPOSED FUNCTIONS

-- | Given a sampling interval (in seconds) and a way to display the status message,
--   produce a function suitable for using as 'Development.Shake.shakeProgress'.
--   This function polls the progress information every /n/ seconds, produces a status
--   message and displays it using the display function.
--
--   Typical status messages will take the form of @1m25s (15%)@, indicating that the build
--   is predicted to complete in 1 minute 25 seconds (85 seconds total), and 15% of the necessary build time has elapsed.
--   This function uses past observations to predict future behaviour, and as such, is only
--   guessing. The time is likely to go up as well as down, and will be less accurate from a
--   clean build (as the system has fewer past observations).
--
--   The current implementation is to predict the time remaining (based on 'timeTodo') and the
--   work already done ('timeBuilt'). The percentage is then calculated as @remaining / (done + remaining)@,
--   while time left is calculated by scaling @remaining@ by the observed work rate in this build,
--   roughly @done / time_elapsed@.
progressDisplay :: Double -> (String -> IO ()) -> IO Progress -> IO ()
progressDisplay :: Double -> (String -> IO ()) -> IO Progress -> IO ()
progressDisplay Double
sample String -> IO ()
disp IO Progress
prog = do
    String -> IO ()
disp String
"Starting..." -- no useful info at this stage
    IO Double
time <- IO (IO Double)
offsetTime
    (AsyncException -> Maybe ()) -> IO () -> (() -> IO ()) -> IO ()
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> (b -> IO a) -> IO a
catchJust (\AsyncException
x -> if AsyncException
x AsyncException -> AsyncException -> Bool
forall a. Eq a => a -> a -> Bool
== AsyncException
ThreadKilled then () -> Maybe ()
forall a. a -> Maybe a
Just () else Maybe ()
forall a. Maybe a
Nothing)
        (IO Double
-> Mealy (Double, Progress) (Double, Double, String) -> IO ()
loop IO Double
time (Mealy (Double, Progress) (Double, Double, String) -> IO ())
-> Mealy (Double, Progress) (Double, Double, String) -> IO ()
forall a b. (a -> b) -> a -> b
$ Mealy (Double, Progress) (Double, Progress)
-> Mealy (Double, Progress) (Double, Double, String)
message Mealy (Double, Progress) (Double, Progress)
forall i. Mealy i i
echoMealy)
        (IO () -> () -> IO ()
forall a b. a -> b -> a
const (IO () -> () -> IO ()) -> IO () -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ do Double
t <- IO Double
time; String -> IO ()
disp (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Finished in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Double -> String
showDuration Double
t)
    where
        loop :: IO Double -> Mealy (Double, Progress) (Double, Double, String) -> IO ()
        loop :: IO Double
-> Mealy (Double, Progress) (Double, Double, String) -> IO ()
loop IO Double
time Mealy (Double, Progress) (Double, Double, String)
mealy = do
            Double -> IO ()
sleep Double
sample
            Progress
p <- IO Progress
prog
            Double
t <- IO Double
time
            ((Double
secs,Double
perc,String
_debug), Mealy (Double, Progress) (Double, Double, String)
mealy)<- ((Double, Double, String),
 Mealy (Double, Progress) (Double, Double, String))
-> IO
     ((Double, Double, String),
      Mealy (Double, Progress) (Double, Double, String))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((Double, Double, String),
  Mealy (Double, Progress) (Double, Double, String))
 -> IO
      ((Double, Double, String),
       Mealy (Double, Progress) (Double, Double, String)))
-> ((Double, Double, String),
    Mealy (Double, Progress) (Double, Double, String))
-> IO
     ((Double, Double, String),
      Mealy (Double, Progress) (Double, Double, String))
forall a b. (a -> b) -> a -> b
$ Mealy (Double, Progress) (Double, Double, String)
-> (Double, Progress)
-> ((Double, Double, String),
    Mealy (Double, Progress) (Double, Double, String))
forall i a. Mealy i a -> i -> (a, Mealy i a)
runMealy Mealy (Double, Progress) (Double, Double, String)
mealy (Double
t, Progress
p)
            -- putStrLn _debug
            let done :: Int
done = Progress -> Int
countSkipped Progress
p Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Progress -> Int
countBuilt Progress
p
            let todo :: Int
todo = Int
done Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Progress -> Int
countUnknown Progress
p Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Progress -> Int
countTodo Progress
p
            String -> IO ()
disp (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
                String
"Running for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Double -> String
showDurationSecs Double
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" [" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
done String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
todo String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                String
", predicted " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Double -> Double -> String
formatMessage Double
secs Double
perc String -> String -> String
forall a. [a] -> [a] -> [a]
++
                String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (String
", Failure! " String -> String -> String
forall a. [a] -> [a] -> [a]
++) (Progress -> Maybe String
isFailure Progress
p)
            IO Double
-> Mealy (Double, Progress) (Double, Double, String) -> IO ()
loop IO Double
time Mealy (Double, Progress) (Double, Double, String)
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
..} = Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
actualSecs Bool -> Bool -> Bool
|| Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
actualPerc


-- | Given a list of progress inputs, what would you have suggested (seconds, percentage)
progressReplay :: [(Double, Progress)] -> [ProgressEntry]
progressReplay :: [(Double, Progress)] -> [ProgressEntry]
progressReplay [] = []
progressReplay [(Double, Progress)]
ps = (Mealy (Double, Progress) (Double, Double, String),
 [ProgressEntry])
-> [ProgressEntry]
forall a b. (a, b) -> b
snd ((Mealy (Double, Progress) (Double, Double, String),
  [ProgressEntry])
 -> [ProgressEntry])
-> (Mealy (Double, Progress) (Double, Double, String),
    [ProgressEntry])
-> [ProgressEntry]
forall a b. (a -> b) -> a -> b
$ (Mealy (Double, Progress) (Double, Double, String)
 -> (Double, Progress)
 -> (Mealy (Double, Progress) (Double, Double, String),
     ProgressEntry))
-> Mealy (Double, Progress) (Double, Double, String)
-> [(Double, Progress)]
-> (Mealy (Double, Progress) (Double, Double, String),
    [ProgressEntry])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL Mealy (Double, Progress) (Double, Double, String)
-> (Double, Progress)
-> (Mealy (Double, Progress) (Double, Double, String),
    ProgressEntry)
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, String)
message Mealy (Double, Progress) (Double, Progress)
forall i. Mealy i i
echoMealy) [(Double, Progress)]
ps
    where
        end :: Double
end = (Double, Progress) -> Double
forall a b. (a, b) -> a
fst ((Double, Progress) -> Double) -> (Double, Progress) -> Double
forall a b. (a -> b) -> a -> b
$ [(Double, Progress)] -> (Double, Progress)
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 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
time) (Double
time Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
100 Double -> Double -> Double
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) = Mealy (Double, b) (Double, Double, c)
-> (Double, b)
-> ((Double, Double, c), Mealy (Double, b) (Double, Double, c))
forall i a. Mealy i a -> i -> (a, Mealy i a)
runMealy Mealy (Double, b) (Double, Double, c)
a (Double
time,b
p)


-- | Given a trace, display information about how well we did
writeProgressReport :: FilePath -> [(FilePath, [(Double, Progress)])] -> IO ()
writeProgressReport :: String -> [(String, [(Double, Progress)])] -> IO ()
writeProgressReport String
out (((String, [(Double, Progress)]) -> (String, [ProgressEntry]))
-> [(String, [(Double, Progress)])] -> [(String, [ProgressEntry])]
forall a b. (a -> b) -> [a] -> [b]
map (([(Double, Progress)] -> [ProgressEntry])
-> (String, [(Double, Progress)]) -> (String, [ProgressEntry])
forall b b' a. (b -> b') -> (a, b) -> (a, b')
second [(Double, Progress)] -> [ProgressEntry]
progressReplay) -> [(String, [ProgressEntry])]
xs)
    | (String
bad,[ProgressEntry]
_):[(String, [ProgressEntry])]
_ <- ((String, [ProgressEntry]) -> Bool)
-> [(String, [ProgressEntry])] -> [(String, [ProgressEntry])]
forall a. (a -> Bool) -> [a] -> [a]
filter ((ProgressEntry -> Bool) -> [ProgressEntry] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ProgressEntry -> Bool
isInvalid ([ProgressEntry] -> Bool)
-> ((String, [ProgressEntry]) -> [ProgressEntry])
-> (String, [ProgressEntry])
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, [ProgressEntry]) -> [ProgressEntry]
forall a b. (a, b) -> b
snd) [(String, [ProgressEntry])]
xs = String -> IO ()
forall a. HasCallStack => String -> IO a
errorIO (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Progress generates NaN for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
bad
    | String -> String
takeExtension String
out String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".js" = String -> String -> IO ()
writeFile String
out (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"var shake = \n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [(String, [ProgressEntry])] -> String
generateJSON [(String, [ProgressEntry])]
xs
    | String -> String
takeExtension String
out String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".json" = String -> String -> IO ()
writeFile String
out (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [(String, [ProgressEntry])] -> String
generateJSON [(String, [ProgressEntry])]
xs
    | String
out String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"-" = String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [(String, [ProgressEntry])] -> [String]
generateSummary [(String, [ProgressEntry])]
xs
    | Bool
otherwise = String -> ByteString -> IO ()
LBS.writeFile String
out (ByteString -> IO ()) -> IO ByteString -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [(String, [ProgressEntry])] -> IO ByteString
generateHTML [(String, [ProgressEntry])]
xs


generateSummary :: [(FilePath, [ProgressEntry])] -> [String]
generateSummary :: [(String, [ProgressEntry])] -> [String]
generateSummary [(String, [ProgressEntry])]
xs = (((String, [ProgressEntry]) -> [String])
 -> [(String, [ProgressEntry])] -> [String])
-> [(String, [ProgressEntry])]
-> ((String, [ProgressEntry]) -> [String])
-> [String]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((String, [ProgressEntry]) -> [String])
-> [(String, [ProgressEntry])] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [(String, [ProgressEntry])]
xs (((String, [ProgressEntry]) -> [String]) -> [String])
-> ((String, [ProgressEntry]) -> [String]) -> [String]
forall a b. (a -> b) -> a -> b
$ \(String
file,[ProgressEntry]
xs) ->
    [String
"# " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
file, [ProgressEntry]
-> String
-> (ProgressEntry -> Double)
-> (ProgressEntry -> Double)
-> String
forall a t.
RealFrac a =>
[t] -> String -> (t -> a) -> (t -> a) -> String
f [ProgressEntry]
xs String
"Seconds" ProgressEntry -> Double
idealSecs ProgressEntry -> Double
actualSecs, [ProgressEntry]
-> String
-> (ProgressEntry -> Double)
-> (ProgressEntry -> Double)
-> String
forall a t.
RealFrac a =>
[t] -> String -> (t -> a) -> (t -> a) -> String
f [ProgressEntry]
xs String
"Percent" ProgressEntry -> Double
idealPerc ProgressEntry -> Double
actualPerc]
    where
        levels :: [Int]
levels = [Int
100,Int
90,Int
80,Int
50]
        f :: [t] -> String -> (t -> a) -> (t -> a) -> String
f [t]
xs String
lbl t -> a
ideal t -> a
actual = String
lbl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", "
            [Int -> String
forall a. Show a => a -> String
show Int
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"% within " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show (a -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (a -> Integer) -> a -> Integer
forall a b. (a -> b) -> a -> b
$ [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([a] -> a) -> [a] -> a
forall a b. (a -> b) -> a -> b
$ a
0 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take (([t] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [t]
xs Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
l) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
100) [a]
diff) | Int
l <- [Int]
levels]
            where diff :: [a]
diff = [a] -> [a]
forall a. Ord a => [a] -> [a]
sort [a -> a
forall a. Num a => a -> a
abs (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ t -> a
ideal t
x a -> a -> a
forall a. Num a => a -> a -> a
- t -> a
actual t
x | t
x <- [t]
xs]


generateHTML :: [(FilePath, [ProgressEntry])] -> IO LBS.ByteString
generateHTML :: [(String, [ProgressEntry])] -> IO ByteString
generateHTML [(String, [ProgressEntry])]
xs = do
    ByteString
report <- String -> IO ByteString
readDataFileHTML String
"progress.html"
    let f :: String -> f ByteString
f String
"data/progress-data.js" = ByteString -> f ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> f ByteString) -> ByteString -> f ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
LBS.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String
"var progress =\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [(String, [ProgressEntry])] -> String
generateJSON [(String, [ProgressEntry])]
xs
    (String -> IO ByteString) -> ByteString -> IO ByteString
runTemplate String -> IO ByteString
forall (f :: * -> *). Applicative f => String -> f ByteString
f ByteString
report

generateJSON :: [(FilePath, [ProgressEntry])] -> String
generateJSON :: [(String, [ProgressEntry])] -> String
generateJSON = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String)
-> ([(String, [ProgressEntry])] -> [String])
-> [(String, [ProgressEntry])]
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
jsonList ([String] -> [String])
-> ([(String, [ProgressEntry])] -> [String])
-> [(String, [ProgressEntry])]
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, [ProgressEntry]) -> String)
-> [(String, [ProgressEntry])] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"}") (String -> String)
-> ((String, [ProgressEntry]) -> String)
-> (String, [ProgressEntry])
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> String)
-> ((String, [ProgressEntry]) -> [String])
-> (String, [ProgressEntry])
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, [ProgressEntry]) -> [String]
f)
    where
        f :: (String, [ProgressEntry]) -> [String]
f (String
file,[ProgressEntry]
ps) =
            (String
"{\"name\":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show (String -> String
takeFileName String
file) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", \"values\":") String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
            [String] -> [String]
indent ([String] -> [String]
jsonList ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (ProgressEntry -> String) -> [ProgressEntry] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ProgressEntry -> String
g [ProgressEntry]
ps)

        shw :: Double -> String
shw = Int -> Double -> String
forall a. RealFloat a => Int -> a -> String
showDP Int
1
        g :: ProgressEntry -> String
g ProgressEntry{Double
actualPerc :: Double
actualSecs :: Double
idealPerc :: Double
idealSecs :: Double
actualPerc :: ProgressEntry -> Double
actualSecs :: ProgressEntry -> Double
idealPerc :: ProgressEntry -> Double
idealSecs :: ProgressEntry -> Double
..} = [(String, String)] -> String
forall a. Show a => [(a, String)] -> String
jsonObject
            [(String
"idealSecs",Double -> String
shw Double
idealSecs),(String
"idealPerc",Double -> String
shw Double
idealPerc)
            ,(String
"actualSecs",Double -> String
shw Double
actualSecs),(String
"actualPerc",Double -> String
shw Double
actualPerc)]

indent :: [String] -> [String]
indent = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"  "String -> String -> String
forall a. [a] -> [a] -> [a]
++)
jsonList :: [String] -> [String]
jsonList [String]
xs = (Char -> String -> String) -> String -> [String] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (:) (Char
'['Char -> String -> String
forall a. a -> [a] -> [a]
:Char -> String
forall a. a -> [a]
repeat Char
',') [String]
xs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"]"]
jsonObject :: [(a, String)] -> String
jsonObject [(a, String)]
xs = String
"{" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [a -> String
forall a. Show a => a -> String
show a
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
b | (a
a,String
b) <- [(a, String)]
xs] String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"}"


-- | Set the title of the current console window to the given text. If the
--   environment variable @$TERM@ is set to @xterm@ this uses xterm escape sequences.
--   On Windows, if not detected as an xterm, this function uses the @SetConsoleTitle@ API.
progressTitlebar :: String -> IO ()
progressTitlebar :: String -> IO ()
progressTitlebar String
x = IO Bool -> IO () -> IO ()
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 = Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
#endif

        lin :: IO ()
lin = IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM IO Bool
checkEscCodes (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ OneShot BS_Store -> IO ()
BS.putStr (OneShot BS_Store -> IO ()) -> OneShot BS_Store -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> OneShot BS_Store
BS.pack (String -> OneShot BS_Store) -> String -> OneShot BS_Store
forall a b. (a -> b) -> a -> b
$ String -> String
escWindowTitle String
x


-- | Call the program @shake-progress@ if it is on the @$PATH@. The program is called with
--   the following arguments:
--
-- * @--title=string@ - the string passed to @progressProgram@.
--
-- * @--state=Normal@, or one of @NoProgress@, @Normal@, or @Error@ to indicate
--   what state the progress bar should be in.
--
-- * @--value=25@ - the percent of the build that has completed, if not in @NoProgress@ state.
--
--   The program will not be called consecutively with the same @--state@ and @--value@ options.
--
--   Windows 7 or higher users can get taskbar progress notifications by placing the following
--   program in their @$PATH@: <https://github.com/ndmitchell/shake/releases>.
progressProgram :: IO (String -> IO ())
progressProgram :: IO (String -> IO ())
progressProgram = do
    Maybe String
exe <- String -> IO (Maybe String)
findExecutable String
"shake-progress"
    case Maybe String
exe of
        Maybe String
Nothing -> (String -> IO ()) -> IO (String -> IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((String -> IO ()) -> IO (String -> IO ()))
-> (String -> IO ()) -> IO (String -> IO ())
forall a b. (a -> b) -> a -> b
$ IO () -> String -> IO ()
forall a b. a -> b -> a
const (IO () -> String -> IO ()) -> IO () -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just String
exe -> do
            IORef (Maybe [String])
lastArgs <- Maybe [String] -> IO (IORef (Maybe [String]))
forall a. a -> IO (IORef a)
newIORef Maybe [String]
forall a. Maybe a
Nothing -- the arguments we passed to shake-progress last time
            (String -> IO ()) -> IO (String -> IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((String -> IO ()) -> IO (String -> IO ()))
-> (String -> IO ()) -> IO (String -> IO ())
forall a b. (a -> b) -> a -> b
$ \String
msg -> do
                let failure :: Bool
failure = String
" Failure! " String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
msg
                let perc :: String
perc = let (String
a,String
b) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'%') String
msg
                           in if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
b then String
"" else String -> String
forall a. [a] -> [a]
reverse (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isDigit (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
reverse String
a
                let state :: String
state | String
perc String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" = String
"NoProgress"
                          | Bool
failure = String
"Error"
                          | Bool
otherwise = String
"Normal"
                let args :: [String]
args = [String
"--title=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg, String
"--state=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
state] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"--value=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
perc | String
perc String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
""]
                Bool
same <- IORef (Maybe [String])
-> (Maybe [String] -> (Maybe [String], Bool)) -> IO Bool
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (Maybe [String])
lastArgs ((Maybe [String] -> (Maybe [String], Bool)) -> IO Bool)
-> (Maybe [String] -> (Maybe [String], Bool)) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \Maybe [String]
old -> ([String] -> Maybe [String]
forall a. a -> Maybe a
Just [String]
args, Maybe [String]
old Maybe [String] -> Maybe [String] -> Bool
forall a. Eq a => a -> a -> Bool
== [String] -> Maybe [String]
forall a. a -> Maybe a
Just [String]
args)
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
same (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO ExitCode -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ExitCode -> IO ()) -> IO ExitCode -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> [String] -> IO ExitCode
rawSystem String
exe [String]
args


-- | A simple method for displaying progress messages, suitable for using as 'Development.Shake.shakeProgress'.
--   This function writes the current progress to the titlebar every five seconds using 'progressTitlebar',
--   and calls any @shake-progress@ program on the @$PATH@ using 'progressProgram'.
progressSimple :: IO Progress -> IO ()
progressSimple :: IO Progress -> IO ()
progressSimple IO Progress
p = do
    String -> IO ()
program <- IO (String -> IO ())
progressProgram
    Double -> (String -> IO ()) -> IO Progress -> IO ()
progressDisplay Double
5 (\String
s -> String -> IO ()
progressTitlebar String
s IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
program String
s) IO Progress
p