module Graphics.GPipe.Engine.TimeIt
  ( timeIt
  , timeItInPlace
  , Status (..)
  , Info (..)
  ) where

import           Control.Monad.IO.Class (MonadIO, liftIO)
import qualified Data.Time.Clock        as Time
import           Graphics.GPipe         (Buffer (..), Texture2D)
import           System.IO              (hFlush, stdout)


timeItInPlace :: (Info a, MonadIO m) => String -> m a -> m a
timeItInPlace :: String -> m a -> m a
timeItInPlace String
text m a
m = do
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr (String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Status -> String
forall a. Show a => a -> String
show Status
Running String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"] " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
text) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stdout
    UTCTime
s <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
Time.getCurrentTime
    (a
r, (Status
status, String
info)) <- a -> (a, (Status, String))
forall a. Info a => a -> (a, (Status, String))
getInfo (a -> (a, (Status, String))) -> m a -> m (a, (Status, String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
m
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr (String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
info String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
40 Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
info Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
text) Char
' ') IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stdout
    UTCTime
e <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
Time.getCurrentTime
    let elapsed :: Pico
elapsed = NominalDiffTime -> Pico
Time.nominalDiffTimeToSeconds (NominalDiffTime -> Pico) -> NominalDiffTime -> Pico
forall a b. (a -> b) -> a -> b
$ UTCTime -> UTCTime -> NominalDiffTime
Time.diffUTCTime UTCTime
e UTCTime
s
        ops :: Pico
ops = if Pico
elapsed Pico -> Pico -> Bool
forall a. Ord a => a -> a -> Bool
> Pico
0 then Pico
1 Pico -> Pico -> Pico
forall a. Fractional a => a -> a -> a
/ Pico
elapsed else -Pico
1
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Pico -> String
forall a. Show a => a -> String
show Pico
elapsed String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pico -> String
forall a. Show a => a -> String
show Pico
ops String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/sec)             "
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr (String
"\r[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Status -> String
forall a. Show a => a -> String
show Status
status String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\r")
    a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r


timeIt :: (Info a, MonadIO m) => String -> m a -> m a
timeIt :: String -> m a -> m a
timeIt String
text m a
m = do
    a
r <- String -> m a -> m a
forall a (m :: * -> *). (Info a, MonadIO m) => String -> m a -> m a
timeItInPlace String
text m a
m
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
"\n"
    a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r


data Status
    = Fail
    | Done
    | Running

instance Show Status where
    show :: Status -> String
show Status
Fail    = String
"\027[1;31mFAIL\027[0m"
    show Status
Done    = String
"\027[1;32mDONE\027[0m"
    show Status
Running = String
"\027[1;33m....\027[0m"

class Info a where
    getInfo :: a -> (a, (Status, String))

instance Info (Maybe a) where
    getInfo :: Maybe a -> (Maybe a, (Status, String))
getInfo r :: Maybe a
r@Maybe a
Nothing = (Maybe a
r, (Status
Done, String
""))
    getInfo r :: Maybe a
r@Just{}  = (Maybe a
r, (Status
Done, String
"OK"))

instance Info [a] where
    getInfo :: [a] -> ([a], (Status, String))
getInfo [a]
r = ([a]
r, (Status
Done, String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
r) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"))

instance Info b => Info (Either a b) where
    getInfo :: Either a b -> (Either a b, (Status, String))
getInfo r :: Either a b
r@Left{}     = (Either a b
r, (Status
Fail, String
""))
    getInfo r :: Either a b
r@(Right b
ok) = (Either a b
r, (b, (Status, String)) -> (Status, String)
forall a b. (a, b) -> b
snd ((b, (Status, String)) -> (Status, String))
-> (b, (Status, String)) -> (Status, String)
forall a b. (a -> b) -> a -> b
$ b -> (b, (Status, String))
forall a. Info a => a -> (a, (Status, String))
getInfo b
ok)

instance Info (Texture2D a b) where
    getInfo :: Texture2D a b -> (Texture2D a b, (Status, String))
getInfo Texture2D a b
r = (Texture2D a b
r, (Status
Done, String
""))

instance Info (a -> b) where
    getInfo :: (a -> b) -> (a -> b, (Status, String))
getInfo a -> b
r = (a -> b
r, (Status
Done, String
""))

instance Info (Buffer os a) where
    getInfo :: Buffer os a -> (Buffer os a, (Status, String))
getInfo Buffer os a
r = (Buffer os a
r, (Status
Done, String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Buffer os a -> Int
forall os b. Buffer os b -> Int
bufferLength Buffer os a
r) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"))