{-# LANGUAGE Rank2Types #-}
module Development.Rattle.UI(
UI, withUI, addUI, isControlledUI,
RattleUI(..),
) where
import System.Time.Extra
import Control.Exception
import Data.List.Extra
import qualified System.Console.Terminal.Size as Terminal
import Numeric.Extra
import General.EscCodes
import qualified Data.ByteString.Char8 as BS
import Data.IORef.Extra
import Control.Concurrent.Async
import Control.Monad.Extra
data RattleUI
=
RattleSerial
|
RattleFancy
|
RattleQuiet
deriving Show
data S = S
{sTraces :: [Maybe (String, String, Seconds)]
,sUnwind :: Int
}
emptyS :: S
emptyS = S [] 0
addTrace :: String -> String -> Seconds -> S -> S
addTrace msg1 msg2 time s = s{sTraces = f (msg1,msg2,time) $ sTraces s}
where
f v (Nothing:xs) = Just v:xs
f v (x:xs) = x : f v xs
f v [] = [Just v]
delTrace :: String -> String -> Seconds -> S -> S
delTrace msg1 msg2 time s = s{sTraces = f (msg1,msg2,time) $ sTraces s}
where
f v (Just x:xs) | x == v = Nothing:xs
f v (x:xs) = x : f v xs
f v [] = []
display :: Int -> String -> Seconds -> S -> (S, String)
display width header time s = (s{sUnwind=length post}, escCursorUp (sUnwind s) ++ unlines (map pad post))
where
post = "" : (escForeground Green ++ "Status: " ++ header ++ escNormal) : map f (sTraces s)
pad x = x ++ escClearLine
f Nothing = " *"
f (Just (s1,s2,t))
| width - endN1 > 20 = " * " ++ take (width - endN1 - 4) s1 ++ end1
| width - endN2 > 20 = " * " ++ take (width - endN2 - 4) s1 ++ end2
| otherwise = take width $ " * " ++ s1
where
end1 = g (time - t) s2
endN1 = length $ removeEscCodes end1
end2 = g (time - t) ""
endN2 = length $ removeEscCodes end2
g i m | showDurationSecs i == "0s" = if null m then "" else "(" ++ m ++ ")"
| i < 10 = " (" ++ s ++ ")"
| otherwise = " (" ++ escForeground (if i > 20 then Red else Yellow) ++ s ++ escNormal ++ ")"
where s = m ++ [' ' | m /= ""] ++ showDurationSecs i
data UI = UI Bool (forall a . String -> String -> IO a -> IO a)
addUI :: UI -> String -> String -> IO a -> IO a
addUI (UI _ x) = x
isControlledUI :: UI -> Bool
isControlledUI (UI x _) = x
showDurationSecs :: Seconds -> String
showDurationSecs = replace ".00s" "s" . showDuration . intToDouble . round
withUI :: Maybe RattleUI -> IO String -> (UI -> IO a) -> IO a
withUI fancy header act = case fancy of
Nothing ->
withUISerial act
Just RattleFancy -> do
checkEscCodes
withUICompact header act
Just RattleSerial ->
withUISerial act
Just RattleQuiet ->
withUIQuiet act
withUICompact :: IO String -> (UI -> IO a) -> IO a
withUICompact header act = do
ref <- newIORef emptyS
let tweak f = atomicModifyIORef_ ref f
time <- offsetTime
let tick = do
h <- header
t <- time
w <- maybe 80 Terminal.width <$> Terminal.size
mask_ $ putStr =<< atomicModifyIORef ref (display w h t)
withAsync (forever (tick >> sleep 0.4) `finally` tick) $ \_ ->
act $ UI True $ \s1 s2 act -> do
t <- time
bracket_
(tweak $ addTrace s1 s2 t)
(tweak $ delTrace s1 s2 t)
act
withUISerial :: (UI -> IO a) -> IO a
withUISerial act =
act $ UI False $ \msg1 msg2 act -> do
BS.putStrLn $ BS.pack $ msg1 ++ if null msg2 then "" else " (" ++ msg2 ++ ")"
act
withUIQuiet :: (UI -> IO a) -> IO a
withUIQuiet act =
act $ UI False $ \_ _ act -> act