{-# LANGUAGE NoImplicitPrelude #-}
module Console.Display
( TerminalDisplay
, displayInit
, display
, displayTextColor
, displayLn
, ProgressBar
, progress
, progressTick
, Summary
, summary
, summarySet
, ColorComponent
, OutputElem(..)
, termText
, justify
, Justify(..)
, Table
, Column
, columnNew
, tableCreate
, tableHeaders
, tableAppend
) where
import Basement.Terminal
import Basement.Terminal.ANSI
import Basement.Types.OffsetSize
import Foundation
import Foundation.Numerical
import Foundation.IO
import Foundation.IO.Terminal
import Foundation.String
import Foundation.Collection
import System.IO (Handle, hSetBuffering, BufferMode(NoBuffering))
import Control.Applicative
import Control.Monad (when)
import Control.Concurrent.MVar
data OutputElem =
Bg ColorComponent
| Fg ColorComponent
| T String
| LeftT (CountOf Char) String
| RightT (CountOf Char) String
| CenterT (CountOf Char) String
| JustifiedT (CountOf Char) String
| NA
deriving (Show,Eq)
data TerminalDisplay = TerminalDisplay (MVar Bool) Handle
hPutStr :: Handle -> String -> IO ()
hPutStr h = hPut h . toBytes UTF8
termText :: String -> String
termText = id
displayInit :: IO TerminalDisplay
displayInit = do
initialize
hSetBuffering stdout NoBuffering
cf <- newMVar False
pure $ TerminalDisplay cf stdout
display :: TerminalDisplay -> [OutputElem] -> IO ()
display tdisp@(TerminalDisplay clearFirst term) oelems = do
cf <- modifyMVar clearFirst $ \cf -> return (False, cf)
when cf $ hPutStr term eraseLineFromCursor
hPutStr term $ renderOutput tdisp oelems
where
clearLineFirst = eraseLineFromCursor
renderOutput :: TerminalDisplay -> [OutputElem] -> String
renderOutput (TerminalDisplay _ term) to = mconcat $ fmap toString to
where
wF = flip sgrForeground False
wB = flip sgrBackground False
rD = sgrReset
toString (Fg c) = wF c
toString (Bg c) = wB c
toString (T t) = t
toString (LeftT size t) = justify JustifyLeft size t
toString (RightT size t) = justify JustifyRight size t
toString (CenterT size t) = justify JustifyCenter size t
toString (JustifiedT size t) = justify JustifyJustified size t
toString NA = rD
displayTextColor :: TerminalDisplay -> ColorComponent -> String -> IO ()
displayTextColor term color msg =
display term [Fg color, T msg]
displayLn :: TerminalDisplay -> ColorComponent -> String -> IO ()
displayLn disp color msg = displayTextColor disp color (msg <> "\n")
white :: ColorComponent
white = 7
data ProgressBar = ProgressBar TerminalDisplay ProgressBackend (MVar ProgressState)
type ProgressBackend = String -> IO ()
data Summary = Summary SummaryBackend
type SummaryBackend = [OutputElem] -> IO ()
data ProgressState = ProgressState
{ pgLhs :: String
, pgRhs :: String
, pgMax :: Int
, pgCurrent :: Int
}
initProgressState :: Int -> ProgressState
initProgressState maxItems = ProgressState
{ pgLhs = ""
, pgRhs = ""
, pgMax = maxItems
, pgCurrent = 0
}
progress :: TerminalDisplay
-> Int
-> (ProgressBar -> IO a)
-> IO a
progress tdisp@(TerminalDisplay cf term) numberItems f = do
let b = backend (Just cursorDown)
(Just "\r")
(Just eraseLineFromCursor)
pbar <- ProgressBar tdisp b <$> newMVar (initProgressState numberItems)
progressStart pbar
a <- f pbar
displayLn tdisp white ""
return a
where
backend :: Maybe (Word64 -> String)
-> Maybe String
-> Maybe String
-> ProgressBackend
backend _ (Just goHome) (Just clearEol) = \msg -> do
hPutStr term $ mconcat [clearEol, msg, goHome]
modifyMVar_ cf $ return . const True
backend _ _ _ = displayLn tdisp white
showBar :: ProgressBar -> IO ()
showBar (ProgressBar _ backend pgsVar) = do
pgs <- readMVar pgsVar
let bar = getBar pgs
backend bar
where
getBar (ProgressState lhs rhs maxItems current) =
lhs `sep` bar `sep`
(show current <> "/" <> show maxItems) `sep`
rhs
where
sep s1 s2
| null s1 = s2
| null s2 = s1
| otherwise = s1 <> " " <> s2
bar
| maxItems == current = "[" <> replicate (CountOf szMax) fillingChar <> "]"
| otherwise = "[" <> replicate (CountOf filled) fillingChar <> ">" <> replicate unfilled' ' ' <> "]"
fillingChar = '='
unfilled = CountOf $ szMax - filled
unfilled' = CountOf $ szMax - filled - 1
filled = roundDown numberChar
numberChar = fromIntegral szMax / currentProgress
szMax = 40 :: Int
currentProgress :: Double
currentProgress = fromIntegral maxItems / fromIntegral current
progressStart :: ProgressBar -> IO ()
progressStart pbar = do
showBar pbar
return ()
progressTick :: ProgressBar -> IO ()
progressTick pbar@(ProgressBar _ _ st) = do
modifyMVar_ st $ \pgs -> return $ pgs { pgCurrent = min (pgMax pgs) (pgCurrent pgs + 1) }
showBar pbar
return ()
summary :: TerminalDisplay -> IO Summary
summary tdisp@(TerminalDisplay cf term) = do
let b = backend (Just cursorDown)
(Just "\r")
(Just eraseLineFromCursor)
return $ Summary b
where
backend :: Maybe (Word64 -> String)
-> Maybe String
-> Maybe String
-> SummaryBackend
backend _ (Just goHome) (Just clearEol) = \msg -> do
hPutStr term $ mconcat [clearEol, renderOutput tdisp msg, goHome]
modifyMVar_ cf $ return . const True
backend _ _ _ = \msg ->
hPutStr term $ mconcat [renderOutput tdisp msg]
summarySet :: Summary -> [OutputElem] -> IO ()
summarySet (Summary backend) = backend
data Justify = JustifyLeft
| JustifyRight
| JustifyCenter
| JustifyJustified
justify :: Justify -> CountOf Char -> String -> String
justify justification size string
| size <= stringSize = string
| otherwise = case justification of
JustifyLeft -> padding <> string
JustifyRight -> string <> padding
JustifyCenter -> if even sizeDifference
then halfPadding <> string <> halfPadding
else halfPadding <> string <> ' ' `cons` halfPadding
JustifyJustified -> justifyJustified size string
where
padding = replicate sizeDifference ' '
halfPadding = replicate (toCount $ fromCount sizeDifference `div` 2) ' '
sizeDifference = fromMaybe 0 $ size - stringSize
stringSize = length string
even (CountOf n) = (n `mod` 2) == 0
justifyJustified :: CountOf Char -> String -> String
justifyJustified size string
| numberOfWords == 1 = string <> replicate (toCount lengthDifference) ' '
| otherwise = justifiedString
where
justifiedString = intercalate spaces $ insertExcessSpaces (toCount excessChars) stringWords
spaces = replicate (toCount spacing) ' '
excessChars = lengthDifference `mod` (numberOfWords - 1)
spacing = lengthDifference `div` (numberOfWords - 1)
lengthDifference = fromCount size - wordsLength
wordsLength = foldl' (+) 0 $ fmap (fromCount . length) stringWords
numberOfWords = fromCount (length stringWords)
stringWords = words string
insertExcessSpaces :: CountOf Char -> [String] -> [String]
insertExcessSpaces _ [] = []
insertExcessSpaces 0 w = w
insertExcessSpaces n (x:xs) = (x <> " ") : insertExcessSpaces (fromMaybe 0 $ n - 1) xs
data Column = Column
{ columnSize :: CountOf Char
, columnName :: String
, columnJustify :: Justify
, columnWrap :: Bool
}
columnNew :: CountOf Char -> String -> Column
columnNew n name = Column
{ columnSize = n
, columnName = name
, columnJustify = JustifyLeft
, columnWrap = False
}
data Table = Table
{ tColumns :: [Column]
, rowSeparator :: String
}
tableCreate :: [Column] -> Table
tableCreate cols = Table { tColumns = cols, rowSeparator = "" }
tableHeaders :: TerminalDisplay -> Table -> IO ()
tableHeaders td t =
tableAppend td t $ columnName <$> tColumns t
tableAppend :: TerminalDisplay -> Table -> [String] -> IO ()
tableAppend td (Table cols rowSep) l = do
let disp = case compare numelems numcols of
LT -> zip cols (l <> replicate (fromMaybe 0 $ numcols - numelems) "")
_ -> zip cols l :: [(Column, String)]
mapM_ printColRow $ intersperse Nothing $ fmap Just disp
where
numelems = length l
numcols = sizeCast Proxy (length cols) :: CountOf String
printColRow Nothing =
display td [T rowSep]
printColRow (Just (c, fieldElement)) = do
let oe = case columnJustify c of
JustifyLeft -> RightT (columnSize c) fieldElement
JustifyRight -> LeftT (columnSize c) fieldElement
JustifyCenter -> CenterT (columnSize c) fieldElement
JustifyJustified -> JustifiedT (columnSize c) fieldElement
display td [oe,T "\n"]