{-# LANGUAGE DeriveDataTypeable, RecordWildCards, CPP, ViewPatterns, ForeignFunctionInterface #-}
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
import System.Environment.Extra
import System.Directory
import System.Process
import System.FilePath
import Data.Char
import Data.Data
import Data.IORef
import Data.List
import Data.Maybe
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as LBS
import Numeric.Extra
import General.Template
import System.IO.Unsafe
import Development.Shake.Internal.Paths
import System.Time.Extra
import Data.Semigroup (Semigroup (..))
import Data.Monoid hiding ((<>))
import Prelude
#ifdef mingw32_HOST_OS
import Foreign
import Foreign.C.Types
#ifdef x86_64_HOST_ARCH
#define CALLCONV ccall
#else
#define CALLCONV stdcall
#endif
foreign import CALLCONV "Windows.h SetConsoleTitleA" c_setConsoleTitle :: Ptr CChar -> IO Bool
#endif
data Progress = Progress
{Progress -> Maybe String
isFailure :: !(Maybe String)
,Progress -> Int
countSkipped :: {-# UNPACK #-} !Int
,Progress -> Int
countBuilt :: {-# UNPACK #-} !Int
,Progress -> Int
countUnknown :: {-# UNPACK #-} !Int
,Progress -> Int
countTodo :: {-# UNPACK #-} !Int
,Progress -> Double
timeSkipped :: {-# UNPACK #-} !Double
,Progress -> Double
timeBuilt :: {-# UNPACK #-} !Double
,Progress -> Double
timeUnknown :: {-# UNPACK #-} !Double
,Progress -> (Double, Int)
timeTodo :: {-# UNPACK #-} !(Double,Int)
}
deriving (Progress -> Progress -> Bool
(Progress -> Progress -> Bool)
-> (Progress -> Progress -> Bool) -> Eq Progress
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Progress -> Progress -> Bool
$c/= :: Progress -> Progress -> Bool
== :: Progress -> Progress -> Bool
$c== :: Progress -> Progress -> Bool
Eq,Eq Progress
Eq Progress =>
(Progress -> Progress -> Ordering)
-> (Progress -> Progress -> Bool)
-> (Progress -> Progress -> Bool)
-> (Progress -> Progress -> Bool)
-> (Progress -> Progress -> Bool)
-> (Progress -> Progress -> Progress)
-> (Progress -> Progress -> Progress)
-> Ord Progress
Progress -> Progress -> Bool
Progress -> Progress -> Ordering
Progress -> Progress -> Progress
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Progress -> Progress -> Progress
$cmin :: Progress -> Progress -> Progress
max :: Progress -> Progress -> Progress
$cmax :: Progress -> Progress -> Progress
>= :: Progress -> Progress -> Bool
$c>= :: Progress -> Progress -> Bool
> :: Progress -> Progress -> Bool
$c> :: Progress -> Progress -> Bool
<= :: Progress -> Progress -> Bool
$c<= :: Progress -> Progress -> Bool
< :: Progress -> Progress -> Bool
$c< :: Progress -> Progress -> Bool
compare :: Progress -> Progress -> Ordering
$ccompare :: Progress -> Progress -> Ordering
$cp1Ord :: Eq Progress
Ord,Int -> Progress -> ShowS
[Progress] -> ShowS
Progress -> String
(Int -> Progress -> ShowS)
-> (Progress -> String) -> ([Progress] -> ShowS) -> Show Progress
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Progress] -> ShowS
$cshowList :: [Progress] -> ShowS
show :: Progress -> String
$cshow :: Progress -> String
showsPrec :: Int -> Progress -> ShowS
$cshowsPrec :: Int -> Progress -> ShowS
Show,ReadPrec [Progress]
ReadPrec Progress
Int -> ReadS Progress
ReadS [Progress]
(Int -> ReadS Progress)
-> ReadS [Progress]
-> ReadPrec Progress
-> ReadPrec [Progress]
-> Read Progress
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Progress]
$creadListPrec :: ReadPrec [Progress]
readPrec :: ReadPrec Progress
$creadPrec :: ReadPrec Progress
readList :: ReadS [Progress]
$creadList :: ReadS [Progress]
readsPrec :: Int -> ReadS Progress
$creadsPrec :: Int -> ReadS Progress
Read,Typeable Progress
Constr
DataType
Typeable Progress =>
(forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Progress -> c Progress)
-> (forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Progress)
-> (Progress -> Constr)
-> (Progress -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Progress))
-> (forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Progress))
-> ((forall b. Data b => b -> b) -> Progress -> Progress)
-> (forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Progress -> r)
-> (forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Progress -> r)
-> (forall u. (forall d. Data d => d -> u) -> Progress -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> Progress -> u)
-> (forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Progress -> m Progress)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Progress -> m Progress)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Progress -> m Progress)
-> Data Progress
Progress -> Constr
Progress -> DataType
(forall b. Data b => b -> b) -> Progress -> Progress
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Progress -> c Progress
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Progress
forall a.
Typeable a =>
(forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> Progress -> u
forall u. (forall d. Data d => d -> u) -> Progress -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Progress -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Progress -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Progress -> m Progress
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Progress -> m Progress
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Progress
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Progress -> c Progress
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Progress)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Progress)
$cProgress :: Constr
$tProgress :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> Progress -> m Progress
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Progress -> m Progress
gmapMp :: (forall d. Data d => d -> m d) -> Progress -> m Progress
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Progress -> m Progress
gmapM :: (forall d. Data d => d -> m d) -> Progress -> m Progress
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Progress -> m Progress
gmapQi :: Int -> (forall d. Data d => d -> u) -> Progress -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Progress -> u
gmapQ :: (forall d. Data d => d -> u) -> Progress -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> Progress -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Progress -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Progress -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Progress -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Progress -> r
gmapT :: (forall b. Data b => b -> b) -> Progress -> Progress
$cgmapT :: (forall b. Data b => b -> b) -> Progress -> Progress
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Progress)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Progress)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c Progress)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Progress)
dataTypeOf :: Progress -> DataType
$cdataTypeOf :: Progress -> DataType
toConstr :: Progress -> Constr
$ctoConstr :: Progress -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Progress
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Progress
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Progress -> c Progress
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Progress -> c Progress
$cp1Data :: Typeable Progress
Data,Typeable)
instance Semigroup Progress where
a :: Progress
a <> :: Progress -> Progress -> Progress
<> b :: Progress
b = $WProgress :: Maybe String
-> Int
-> Int
-> Int
-> Int
-> Double
-> Double
-> Double
-> (Double, Int)
-> Progress
Progress
{isFailure :: Maybe String
isFailure = Progress -> Maybe String
isFailure Progress
a Maybe String -> Maybe String -> Maybe String
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Progress -> Maybe String
isFailure Progress
b
,countSkipped :: Int
countSkipped = Progress -> Int
countSkipped Progress
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Progress -> Int
countSkipped Progress
b
,countBuilt :: Int
countBuilt = Progress -> Int
countBuilt Progress
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Progress -> Int
countBuilt Progress
b
,countUnknown :: Int
countUnknown = Progress -> Int
countUnknown Progress
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Progress -> Int
countUnknown Progress
b
,countTodo :: Int
countTodo = Progress -> Int
countTodo Progress
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Progress -> Int
countTodo Progress
b
,timeSkipped :: Double
timeSkipped = Progress -> Double
timeSkipped Progress
a Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Progress -> Double
timeSkipped Progress
b
,timeBuilt :: Double
timeBuilt = Progress -> Double
timeBuilt Progress
a Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Progress -> Double
timeBuilt Progress
b
,timeUnknown :: Double
timeUnknown = Progress -> Double
timeUnknown Progress
a Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Progress -> Double
timeUnknown Progress
b
,timeTodo :: (Double, Int)
timeTodo = let (a1 :: Double
a1,a2 :: Int
a2) = Progress -> (Double, Int)
timeTodo Progress
a; (b1 :: Double
b1,b2 :: Int
b2) = Progress -> (Double, Int)
timeTodo Progress
b
x1 :: Double
x1 = Double
a1 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
b1; x2 :: Int
x2 = Int
a2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
b2
in Double
x1 Double -> (Double, Int) -> (Double, Int)
forall a b. a -> b -> b
`seq` Int
x2 Int -> (Double, Int) -> (Double, Int)
forall a b. a -> b -> b
`seq` (Double
x1,Int
x2)
}
instance Monoid Progress where
mempty :: Progress
mempty = Maybe String
-> Int
-> Int
-> Int
-> Int
-> Double
-> Double
-> Double
-> (Double, Int)
-> Progress
Progress Maybe String
forall a. Maybe a
Nothing 0 0 0 0 0 0 0 (0,0)
mappend :: Progress -> Progress -> Progress
mappend = Progress -> Progress -> Progress
forall a. Semigroup a => a -> a -> a
(<>)
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 f :: a -> b
f (Mealy m :: 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
i -> case i -> (a, Mealy i a)
m i
i of
(x :: a
x, m :: 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 x :: 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 mf :: i -> (a -> b, Mealy i (a -> b))
mf <*> :: Mealy i (a -> b) -> Mealy i a -> Mealy i b
<*> Mealy mx :: 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
i -> case i -> (a -> b, Mealy i (a -> b))
mf i
i of
(f :: a -> b
f, mf :: Mealy i (a -> b)
mf) -> case i -> (a, Mealy i a)
mx i
i of
(x :: a
x, mx :: 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 ((i -> (i, Mealy i i)) -> Mealy i i)
-> (i -> (i, Mealy i i)) -> Mealy i i
forall a b. (a -> b) -> a -> b
$ \i :: i
i -> (i
i, 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 f :: a -> b -> a
f z :: a
z (Mealy m :: 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
i -> case i -> (b, Mealy i b)
m i
i of
(x :: b
x, m :: 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)
oldMealy :: a -> Mealy i a -> Mealy i (a,a)
oldMealy :: a -> Mealy i a -> Mealy i (a, a)
oldMealy old :: 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 (\(_,old :: a
old) new :: 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 s :: 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 old :: Maybe a
old (b :: Bool
b,v :: 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 c :: Mealy i Bool
c t :: Mealy i a
t f :: Mealy i a
f = (\c :: Bool
c t :: a
t f :: 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 :: Double -> Mealy i Double -> Mealy i Double -> Mealy i Double
decay :: Double -> Mealy i Double -> Mealy i Double -> Mealy i Double
decay f :: Double
f a :: Mealy i Double
a b :: 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 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 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 0 Mealy i Double
b
where step :: Double -> ((Double, Double), (Double, Double)) -> Double
step r :: Double
r ((a :: Double
a,a' :: Double
a'),(b :: Double
b,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))
formatMessage :: Double -> Double -> String
formatMessage :: Double -> Double -> String
formatMessage secs :: Double
secs perc :: 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
< 0 then "??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 -> ShowS
forall a. [a] -> [a] -> [a]
++ " (" String -> ShowS
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
< 0 Bool -> Bool -> Bool
|| Double
perc Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> 100 then "??" 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 -> ShowS
forall a. [a] -> [a] -> [a]
++ "%)"
showMinSec :: Int -> String
showMinSec :: Int -> String
showMinSec secs :: Int
secs = (if Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 then "" else Int -> String
forall a. Show a => a -> String
show Int
m String -> ShowS
forall a. [a] -> [a] -> [a]
++ "m" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ['0' | Int
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 10]) String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ "s"
where (m :: Int
m,s :: Int
s) = Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
divMod Int
secs 60
liftA2' :: Applicative m => m a -> m b -> (a -> b -> c) -> m c
liftA2' :: m a -> m b -> (a -> b -> c) -> m c
liftA2' a :: m a
a b :: m b
b f :: 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
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 input :: 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 = (\donePerSec :: Double
donePerSec ruleTime :: Double
ruleTime (todoKnown :: Double
todoKnown,todoUnknown :: Int
todoUnknown) ->
"Progress: " String -> ShowS
forall a. [a] -> [a] -> [a]
++
"((known=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Double -> String
forall a. RealFloat a => Int -> a -> String
showDP 2 Double
todoKnown String -> ShowS
forall a. [a] -> [a] -> [a]
++ "s) + " String -> ShowS
forall a. [a] -> [a] -> [a]
++
"(unknown=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
todoUnknown String -> ShowS
forall a. [a] -> [a] -> [a]
++ " * time=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Double -> String
forall a. RealFloat a => Int -> a -> String
showDP 2 Double
ruleTime String -> ShowS
forall a. [a] -> [a] -> [a]
++ "s)) " String -> ShowS
forall a. [a] -> [a] -> [a]
++
"(rate=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Double -> String
forall a. RealFloat a => Int -> a -> String
showDP 2 Double
donePerSec String -> ShowS
forall a. [a] -> [a] -> [a]
++ "))")
(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)
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
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
(==) 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 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 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 1.2 Mealy (Double, Progress) Double
done Mealy (Double, Progress) Double
secs
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 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{..} -> 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))
where
weightedAverage :: (Int, Double) -> (Int, Double) -> Double
weightedAverage (w1 :: Int
w1,x1 :: Double
x1) (w2 :: Int
w2,x2 :: Double
x2)
| Int
w1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 Bool -> Bool -> Bool
&& Int
w2 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = 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 i :: Int
i *. :: Int -> Double -> Double
*. d :: Double
d = if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 then 0 else Int -> Double
intToDouble Int
i Double -> Double -> Double
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 divide :: Mealy (Double, Progress) b
-> Mealy (Double, Progress) Double -> Mealy (Double, Progress) b
divide time :: Progress -> b
time count :: 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)
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{..} ruleTime :: 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)
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
(==) 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 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
$ \done :: Double
done todo :: Double
todo -> 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)
progressDisplay :: Double -> (String -> IO ()) -> IO Progress -> IO ()
progressDisplay :: Double -> (String -> IO ()) -> IO Progress -> IO ()
progressDisplay sample :: Double
sample disp :: String -> IO ()
disp prog :: IO Progress
prog = do
String -> IO ()
disp "Starting..."
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 (\x :: 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
$ String -> IO ()
disp "Finished")
where
loop :: IO Double -> Mealy (Double, Progress) (Double, Double, String) -> IO ()
loop :: IO Double
-> Mealy (Double, Progress) (Double, Double, String) -> IO ()
loop time :: IO Double
time mealy :: Mealy (Double, Progress) (Double, Double, String)
mealy = do
Double -> IO ()
sleep Double
sample
Progress
p <- IO Progress
prog
Double
t <- IO Double
time
((secs :: Double
secs,perc :: Double
perc,debug :: String
debug), mealy :: 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 (m :: * -> *) a. Monad m => a -> m a
return (((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)
String -> IO ()
disp (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Double -> Double -> String
formatMessage Double
secs Double
perc String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> ShowS -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" (\err :: String
err -> ", Failure! " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
err) (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 -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
actualSecs Bool -> Bool -> Bool
|| Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
actualPerc
progressReplay :: [(Double, Progress)] -> [ProgressEntry]
progressReplay :: [(Double, Progress)] -> [ProgressEntry]
progressReplay [] = []
progressReplay ps :: [(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 a :: Mealy (Double, b) (Double, Double, c)
a (time :: Double
time,p :: 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
* 100 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
end) Double
secs Double
perc)
where ((secs :: Double
secs,perc :: Double
perc,_),a2 :: 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)
writeProgressReport :: FilePath -> [(FilePath, [(Double, Progress)])] -> IO ()
writeProgressReport :: String -> [(String, [(Double, Progress)])] -> IO ()
writeProgressReport out :: 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)
| (bad :: String
bad,_):_ <- ((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
$ "Progress generates NaN for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
bad
| ShowS
takeExtension String
out String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== ".js" = String -> String -> IO ()
writeFile String
out (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "var shake = \n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(String, [ProgressEntry])] -> String
generateJSON [(String, [ProgressEntry])]
xs
| ShowS
takeExtension String
out String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== ".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 -> 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 xs :: [(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
$ \(file :: String
file,xs :: [ProgressEntry]
xs) ->
["# " String -> ShowS
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 "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 "Percent" ProgressEntry -> Double
idealPerc ProgressEntry -> Double
actualPerc]
where
levels :: [Int]
levels = [100,90,80,50]
f :: [t] -> String -> (t -> a) -> (t -> a) -> String
f xs :: [t]
xs lbl :: String
lbl ideal :: t -> a
ideal actual :: t -> a
actual = String
lbl String -> ShowS
forall a. [a] -> [a] -> [a]
++ ": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate ", "
[Int -> String
forall a. Show a => a -> String
show Int
l String -> ShowS
forall a. [a] -> [a] -> [a]
++ "% within " String -> ShowS
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
$ 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` 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 xs :: [(String, [ProgressEntry])]
xs = do
ByteString
report <- String -> IO ByteString
readDataFileHTML "progress.html"
let f :: String -> IO ByteString
f name :: String
name | String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "progress-data.js" = ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
LBS.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ "var progress =\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(String, [ProgressEntry])] -> String
generateJSON [(String, [ProgressEntry])]
xs
| String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "version.js" = ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
LBS.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ "var version = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
shakeVersionString
| Bool
otherwise = String -> IO ByteString
readDataFileHTML String
name
(String -> IO ByteString) -> ByteString -> IO ByteString
forall (m :: * -> *).
(Functor m, MonadIO m) =>
(String -> m ByteString) -> ByteString -> m ByteString
runTemplate String -> IO 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 -> ShowS
forall a. [a] -> [a] -> [a]
++"}") ShowS
-> ((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 (file :: String
file,ps :: [ProgressEntry]
ps) =
("{\"name\":" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show (ShowS
takeFileName String
file) String -> ShowS
forall a. [a] -> [a] -> [a]
++ ", \"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 1
g :: ProgressEntry -> String
g ProgressEntry{..} = [(String, String)] -> String
forall a. Show a => [(a, String)] -> String
jsonObject
[("idealSecs",Double -> String
shw Double
idealSecs),("idealPerc",Double -> String
shw Double
idealPerc)
,("actualSecs",Double -> String
shw Double
actualSecs),("actualPerc",Double -> String
shw Double
actualPerc)]
indent :: [String] -> [String]
indent = ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (" "String -> ShowS
forall a. [a] -> [a] -> [a]
++)
jsonList :: [String] -> [String]
jsonList xs :: [String]
xs = (Char -> ShowS) -> String -> [String] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (:) ('['Char -> ShowS
forall a. a -> [a] -> [a]
:Char -> String
forall a. a -> [a]
repeat ',') [String]
xs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ["]"]
jsonObject :: [(a, String)] -> String
jsonObject xs :: [(a, String)]
xs = "{" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate ", " [a -> String
forall a. Show a => a -> String
show a
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ ":" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
b | (a :: a
a,b :: String
b) <- [(a, String)]
xs] String -> ShowS
forall a. [a] -> [a] -> [a]
++ "}"
{-# NOINLINE xterm #-}
xterm :: Bool
xterm :: Bool
xterm = IO Bool -> Bool
forall a. IO a -> a
unsafePerformIO (IO Bool -> Bool) -> IO Bool -> Bool
forall a b. (a -> b) -> a -> b
$
Bool -> (String -> Bool) -> Maybe String -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ("xterm" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) (Maybe String -> Bool) -> IO (Maybe String) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv "TERM"
progressTitlebar :: String -> IO ()
progressTitlebar :: String -> IO ()
progressTitlebar x :: String
x
| Bool
xterm = ByteString -> IO ()
BS.putStr (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString
BS.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ "\ESC]0;" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\BEL"
#ifdef mingw32_HOST_OS
| otherwise = BS.useAsCString (BS.pack x) $ \x -> c_setConsoleTitle x >> return ()
#else
| Bool
otherwise = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#endif
progressProgram :: IO (String -> IO ())
progressProgram :: IO (String -> IO ())
progressProgram = do
Maybe String
exe <- String -> IO (Maybe String)
findExecutable "shake-progress"
case Maybe String
exe of
Nothing -> (String -> IO ()) -> IO (String -> IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return ((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 (m :: * -> *) a. Monad m => a -> m a
return ()
Just exe :: String
exe -> do
IORef (Maybe (Bool, String))
ref <- Maybe (Bool, String) -> IO (IORef (Maybe (Bool, String)))
forall a. a -> IO (IORef a)
newIORef Maybe (Bool, String)
forall a. Maybe a
Nothing
(String -> IO ()) -> IO (String -> IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return ((String -> IO ()) -> IO (String -> IO ()))
-> (String -> IO ()) -> IO (String -> IO ())
forall a b. (a -> b) -> a -> b
$ \msg :: String
msg -> do
let failure :: Bool
failure = " Failure! " String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
msg
let perc :: String
perc = let (a :: String
a,b :: 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
== '%') String
msg
in if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
b then "" else ShowS
forall a. [a] -> [a]
reverse ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isDigit ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS
forall a. [a] -> [a]
reverse String
a
let key :: (Bool, String)
key = (Bool
failure, String
perc)
Bool
same <- IORef (Maybe (Bool, String))
-> (Maybe (Bool, String) -> (Maybe (Bool, String), Bool))
-> IO Bool
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (Maybe (Bool, String))
ref ((Maybe (Bool, String) -> (Maybe (Bool, String), Bool)) -> IO Bool)
-> (Maybe (Bool, String) -> (Maybe (Bool, String), Bool))
-> IO Bool
forall a b. (a -> b) -> a -> b
$ \old :: Maybe (Bool, String)
old -> ((Bool, String) -> Maybe (Bool, String)
forall a. a -> Maybe a
Just (Bool, String)
key, Maybe (Bool, String)
old Maybe (Bool, String) -> Maybe (Bool, String) -> Bool
forall a. Eq a => a -> a -> Bool
== (Bool, String) -> Maybe (Bool, String)
forall a. a -> Maybe a
Just (Bool, String)
key)
let state :: String
state | String
perc String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "" = "NoProgress"
| Bool
failure = "Error"
| Bool
otherwise = "Normal"
String -> [String] -> IO ExitCode
rawSystem String
exe ([String] -> IO ExitCode) -> [String] -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ ["--title=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg, "--state=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
state] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ["--value=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
perc | String
perc String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= ""]
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
progressSimple :: IO Progress -> IO ()
progressSimple :: IO Progress -> IO ()
progressSimple p :: IO Progress
p = do
String -> IO ()
program <- IO (String -> IO ())
progressProgram
Double -> (String -> IO ()) -> IO Progress -> IO ()
progressDisplay 5 (\s :: 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