#define UPDATE_ALL_ALWAYS
#ifndef NOTESTING
#endif
module UI.HydraPrint
(
hydraPrint, hydraPrintStatic,
HydraConf(..), defaultHydraConf, DeleteWinWhen(..)
#ifndef NOTESTING
, testSuite
#endif
, dbgLogLn
)
where
import Data.IORef
import Data.Time.Clock
import Data.Word
import Data.Char (ord)
import Data.Map as M
import Data.List as L
import qualified Data.ByteString.Char8 as B
import Data.ByteString.Char8 (ByteString)
import Data.ByteString.Unsafe (unsafeUseAsCStringLen)
import Prelude as P
import Control.Monad
import Control.Concurrent (threadDelay)
import Control.Monad.IO.Class (liftIO, MonadIO)
import qualified Control.Exception as E
import Foreign.C.String (withCAStringLen)
import qualified System.IO.Streams as S
import System.IO.Streams (InputStream, OutputStream)
import System.IO.Streams.Concurrent (concurrentMerge)
#if 0
import UI.HSCurses.CursesHelper as CH
import UI.HSCurses.Curses as C hiding (s1,s3,tl,ls)
#else
import UI.NCurses hiding (Event)
import qualified UI.NCurses as C
#endif
import System.IO (hFlush, hPutStrLn, stderr, openFile, IOMode(WriteMode), Handle)
import System.IO.Unsafe (unsafePerformIO)
import System.IO.Error (isDoesNotExistError)
import System.Directory (removeFile)
import System.Environment (getEnvironment)
import Control.Applicative
import qualified Data.Foldable as F
import qualified Data.List.NonEmpty as NE
import Data.List.NonEmpty (NonEmpty((:|)))
#ifndef NOTESTING
import Test.QuickCheck hiding (NonEmpty)
import Test.HUnit (Assertion, assertEqual, assertBool)
import Test.Framework (Test, defaultMain)
import Test.Framework.Providers.HUnit (testCase)
import Test.Framework.Providers.QuickCheck2 (testProperty)
import Test.Framework.TH (testGroupGenerator)
#endif
dbg :: Bool
dbg = case P.lookup "HYDRA_DEBUG" theEnv of
Nothing -> False
Just "" -> False
Just "0" -> False
Just "False" -> False
Just _ -> True
theEnv :: [(String, String)]
theEnv = unsafePerformIO$ getEnvironment
io :: MonadIO m => IO a -> m a
io x = liftIO x
data HydraConf =
HydraConf
{
deleteWhen :: DeleteWinWhen,
useColor :: Bool
}
data DeleteWinWhen = Never
| After Seconds
| Immediately
type Seconds = Double
defaultHydraConf :: HydraConf
defaultHydraConf =
HydraConf
{
deleteWhen = After 3.0,
useColor = True
}
data MPState =
MPState
{
activeStrms :: M.Map StreamID WindowWidget,
dyingStrms :: [(StreamID, Seconds, WindowWidget)],
deadStrms :: [StreamHistory],
windows :: [CWindow],
colorIDs :: [ColorID]
}
data WindowWidget =
WindowWidget
{
hist :: StreamHistory,
textSizeYX :: IO (Word,Word),
putLine :: ByteString -> Curses (),
repaint :: Curses (),
setWin :: CWindow -> Curses (),
winRef :: IORef CWindow
}
data StreamHistory =
StreamHistory {
streamName :: String,
revHist :: IORef [ByteString]
}
type WinPos = (Word,Word,Word,Word)
data CWindow = CWindow C.Window WinPos (String,ColorID)
instance Show CWindow where
show (CWindow _ winpos _) = "<Window at "++show winpos++">"
allColors :: [Color]
allColors = [ColorGreen, ColorCyan, ColorMagenta, ColorYellow, ColorRed, ColorBlue]
initColors :: Curses [ColorID]
initColors = do
supports <- supportsColor
if supports then do
cdc <- canDefineColor
mx <- maxColorID
when cdc $ defineColor ColorBlack 0 0 0
ls <- mapM (\(idx, x) -> newColorID x ColorBlack idx)
(zip [1..mx] allColors)
return$ defaultColorID : ls
else
return [defaultColorID]
createWindows :: [(String,ColorID)] -> Word -> Curses ([CWindow],Word,Word)
createWindows names num = do
(curY,curX) <- screenSize
let (nX,nY) = computeTiling num
panelDims = applyTiling (i2w curY, i2w curX) (nY,nX)
ws <- forM (P.zip names (NE.toList panelDims)) $
\ ((name,colorID), tup@(hght,wid, posY, posX)) -> do
w1 <- newWindow (w2i hght) (w2i wid) (w2i posY) (w2i posX)
let msg = ("CreatedWindow: at "++show tup++", name "++name)
let cwin = CWindow w1 tup (name,colorID)
#ifndef UPDATE_ALL_ALWAYS
updateWindow w1$ drawNamedBorder cwin
#endif
return cwin
return (ws,nX,nY)
blankChar :: Char
blankChar = ' '
#if 0
clearWindow :: CWindow -> Curses ()
clearWindow (CWindow wp _) = do
updateWindow wp $
setBackground (Glyph ' ' [])
#else
clearWindow :: CWindow -> Curses ()
clearWindow (CWindow wp (hght,wid,_,_) _) = updateWindow wp $ do
let
width' = wid borderLeft
blank = P.replicate (w2i width') blankChar
forM_ [borderTop .. hght borderBottom 1 ] $ \ yind -> do
moveCursor (w2i yind) (w2i borderLeft)
drawString blank
return ()
writeToCorner (w2i$ hght1) (w2i borderLeft) blank
#endif
writeToCorner :: Int -> Int -> String -> Update ()
writeToCorner y x str = do
let len = P.length str
moveCursor (fromIntegral y) (fromIntegral x)
drawString (P.init str)
return ()
redrawAll :: [CWindow] -> Curses ()
redrawAll wins = do
forM_ wins $ \ cwin@(CWindow wp _ _) -> do
#ifdef UPDATE_ALL_ALWAYS
updateWindow wp $ do
drawNamedBorder cwin
return ()
#endif
return ()
C.render
borderTop :: Word
borderTop = if dbg then 2 else 1
borderBottom :: Word
borderBottom = 1
borderLeft :: Word
borderLeft = 1
borderRight :: Word
borderRight = 1
createWindowWidget :: String -> IO WindowWidget
createWindowWidget streamName = do
revHist <- newIORef []
winRef <- newIORef (error "winRef field uninialized. Call setWin.")
let hist = StreamHistory{streamName, revHist}
putLine bstr = do
oldhist <- io$ readIORef revHist
let msg = bstr
let newhist = msg : oldhist
io$ writeIORef revHist newhist
repaint
repaint :: Curses ()
repaint = do
cwin@(CWindow wp (y,x,_,_) _) <- io$ readIORef winRef
newhist <- io$ readIORef revHist
updateWindow wp $ do
let y' = y borderTop borderBottom
shown = P.take (w2i y') newhist
padY = y' i2w(P.length shown)
forM_ (P.zip [1..] shown) $ \ (ind,oneline) -> do
moveCursor (w2i (y borderBottom ind padY)) (w2i borderLeft)
let padded = oneline `B.append`
B.replicate (w2i x B.length oneline) ' '
cropped = B.take (w2i (x borderLeft borderRight)) padded
drawString (B.unpack cropped)
drawNamedBorder cwin
textSizeYX = do
CWindow _ (y,x,_,_) _ <- readIORef winRef
return (y,x)
setWin cwin@(CWindow wp _ _) = do
io$ writeIORef winRef cwin
updateWindow wp $
drawNamedBorder cwin
return ()
obj = WindowWidget { hist, textSizeYX, putLine,
setWin, winRef, repaint }
return obj
drawNamedBorder :: CWindow -> Update ()
drawNamedBorder (CWindow wp (hght,wid,y,_) (name,winColor)) = do
setColor defaultColorID
drawBox Nothing Nothing
setColor winColor
let isTop = (y == 0)
name' = "[" ++ name ++ "]"
mid = wid `quot` 2
strt = max 0 (w2i mid (fromIntegral (P.length name' `quot` 2)))
if isTop then
moveCursor 0 strt
else
moveCursor (w2i$ hght1) strt
drawString (take (w2i wid) name')
dbgLn :: String -> IO ()
dbgLn s = when dbg$
do dbgLogLn s
P.putStrLn s
dbgLogLn :: String -> IO ()
dbgLogLn s = when dbg$
do B.hPutStrLn dbgLog (B.pack s)
hFlush dbgLog
dbgLog :: Handle
dbgLog = unsafePerformIO $ do
let file = "/tmp/hydraprint_debug.log"
removeIfExists file
openFile file WriteMode
initAndRunCurses :: HydraConf -> [String] -> (MPState -> Curses a) -> IO a
initAndRunCurses HydraConf{useColor} names action = runCurses $ do
setCursorMode CursorInvisible
cids <- if useColor then initColors
else return [defaultColorID]
wids <- forM names $ \ sname ->
io$ createWindowWidget sname
(wins,_,_) <- createWindows (zip names cids) (i2w$ P.length names)
sequence$ zipWith setWin wids wins
action$ MPState { activeStrms= M.fromList (zip [0..] wids),
dyingStrms= [],
deadStrms= [],
windows = wins,
colorIDs= cids
}
hydraPrintStatic :: HydraConf -> [(String, InputStream ByteString)] -> IO ()
hydraPrintStatic _ [] = return ()
hydraPrintStatic conf srcs = do
let (nameL,strmL) = P.last srcs
(names,strms) = unzip (P.init srcs)
strms' <- sequence$ zipWith preProcess [0..] strms
merged <- concurrentMerge strms'
initAndRunCurses conf names $ \ initMPS -> do
steadyState conf{deleteWhen=Never} initMPS (i2w$ P.length names) (nameL,strmL) merged
hydraPrint :: HydraConf -> InputStream (String, InputStream ByteString) -> IO ()
hydraPrint conf strmSrc = phase0 conf =<< S.map NewStream strmSrc
phase0 :: HydraConf -> InputStream Event -> IO ()
phase0 conf strmSrc' = do
dbgLn $ "phase0: blocking for event."
ms1 <- S.read strmSrc'
case ms1 of
Nothing -> do
dbgLn $ "phase0: stream ended"
return ()
Just (NewStream (s1name,s1)) -> do
dbgLn $ "phase0: new (first) stream! ("++s1name++") Moving to phase1."
s1' <- preProcess 0 s1
merge1 <- concurrentMerge [strmSrc', s1']
phase1 conf s1name merge1
_ -> error "hydraPrint: Internal error. Unexpected event."
----------------------------------------PHASE1----------------------------------------
phase1 :: HydraConf -> String -> InputStream Event -> IO ()
phase1 conf s1name merge1 = do
dbgLn $ "phase1: blocking for event."
nxt <- S.read merge1
case nxt of
Nothing -> do
dbgLn $ "Streams ended in phase1!"
return ()
Just (NewStrLine _ (StrmElt ln)) -> do
B.putStrLn ln
phase1 conf s1name merge1
Just (NewStrLine sid EOS) -> do
dbgLn $ "Got stream EOS! ID "++show sid
phase0 conf merge1
Just (NewStream (s2name,s2)) -> do
dbgLn $ "Got newStream! "++s2name++". Transition to steady state..."
heartbeat <- timer 200
merge2 <- concurrentMerge [ merge1, heartbeat ]
initAndRunCurses conf [s1name] $ \ initMPS ->
steadyState conf initMPS 1 (s2name,s2) merge2
Just (CursesKeyEvent _) -> error "Internal error. Shouldn't see Curses event here."
----------------------------------------PHASE3----------------------------------------
steadyState :: HydraConf -> MPState -> StreamID -> (String,InputStream ByteString) -> InputStream Event -> Curses ()
steadyState conf state0@MPState{activeStrms,windows} sidCnt (newName,newStrm) merged = do
newStrm' <- io$ preProcess sidCnt newStrm
merged' <- io$ concurrentMerge [merged, newStrm']
widg <- io$ createWindowWidget newName
let active2 = M.insert sidCnt widg activeStrms
windows2 <- reCreate active2 windows
let state1 = state0{activeStrms=active2, windows=windows2}
let loop mps@MPState{activeStrms, dyingStrms, deadStrms, windows} = do
redrawAll windows
nxt <- io$ S.read merged'
case nxt of
Nothing -> return ()
Just HeartBeat-> do
let deadLp mps' [] = loop mps'
deadLp mps' ((sid,timeOut,widg):tl) = do
now <- secsToday
if now >= timeOut
then do let MPState{activeStrms,dyingStrms,deadStrms} = mps'
let active' = M.delete sid activeStrms
case P.reverse windows of
[] -> error "hydraPrint: Internal error. Expecting list of windows to be non-empty."
lst:_ -> clearWindow lst
windows' <- reCreate active' windows
deadLp mps'{activeStrms=active',
dyingStrms= P.filter (\(a,_,_) -> a /= sid) dyingStrms,
deadStrms = hist widg : deadStrms,
windows = windows'
}
tl
else deadLp mps' tl
pollAndContinue mps = deadLp mps dyingStrms
win <- defaultWindow
let keyLoop hit mps = do
mevt <- getEvent win (Just 0)
case mevt of
Nothing -> do when hit $ do
mapM_ repaint (M.elems activeStrms)
return ()
pollAndContinue mps
Just evt -> do
io$ dbgPrnt$ " [dbg] Got curses event: "++show evt
case evt of
EventResized -> do
keyLoop hit mps
EventCharacter 'q' -> return ()
_ -> do
keyLoop True mps
keyLoop False mps
Just (NewStrLine sid (StrmElt ln)) -> do
io$ dbgLogLn (B.unpack ln)
putLine (activeStrms!sid) ln
loop mps
Just (NewStrLine sid EOS) -> do
io$ dbgPrnt $ " [dbg] Stream ID "++ show sid++" got end-of-stream "
case deleteWhen conf of
Never -> loop mps
After secs -> do
now <- secsToday
let dyingStrms' = (sid, secs + now, activeStrms!sid) : dyingStrms
(CWindow wp _ _) <- io$ readIORef (winRef (activeStrms!sid))
updateWindow wp $ return ()
loop mps{ dyingStrms=dyingStrms' }
Immediately -> do
let active' = M.delete sid activeStrms
case P.reverse windows of
[] -> error "hydraPrint: Internal error. Expecting list of windows to be non-empty."
lst:_ -> clearWindow lst
windows' <- reCreate active' windows
loop mps{ activeStrms = active',
deadStrms= hist (activeStrms!sid) : deadStrms,
windows = windows' }
Just (NewStream (s2name,s2)) -> do
io$ dbgPrnt $ " [dbg] NEW stream: "++ show s2name
steadyState conf mps (sidCnt+1) (s2name,s2) merged'
Just (CursesKeyEvent key) -> do
case key of
_ -> do io$ dbgPrnt $ " [dbg] CURSES Key event: "++show key
loop mps
loop state1
where
dbgPrnt s = when dbg $ do
dbgLogLn s
reCreate active' oldWins = do
let names = P.map (streamName . hist) $ M.elems active'
numactive = fromIntegral (M.size active')
withcolors = P.zip names (P.cycle (colorIDs state0))
(ws,numHoriz,numVert) <- createWindows withcolors numactive
forM_ (P.zip ws (M.assocs active')) $ \ (win,(sid,wid)) -> do
setWin wid win
forM_ oldWins (\ (CWindow w _ _) -> closeWindow w)
(nLines,nCols) <- screenSize
dummies <- case reverse ws of
[] -> return []
(CWindow wp (hght,wid,y,x) _ : _) ->
let lastCol = w2i$ x + wid 1 in
if (lastCol < nCols 1) then do
let startX = lastCol+1
remainingX = fromIntegral$ nCols startX
dummy <- newWindow 1 remainingX (w2i$ y+hght1) startX
let dummyCW = CWindow dummy (1, i2w remainingX, (w2i$ y+hght1), i2w startX) ("",defaultColorID)
io$ dbgPrnt$ "Dummy horiz (screen "++show (nLines,nCols)++"): "++show dummyCW
let startY = (w2i$ y+1)
remainingY = fromIntegral$ nLines startY 1
dummy2 <- newWindow remainingY 1 startY (nCols1)
let dummy2CW = CWindow dummy2 (i2w remainingY, 1, i2w startY, i2w (nCols1)) ("",defaultColorID)
io$ dbgPrnt$ "Dummy vert: "++show dummy2CW
return [dummy,dummy2]
else return []
return ws
preProcess :: StreamID -> InputStream ByteString -> IO (InputStream Event)
preProcess id s = do
s' <- S.lines s
s'' <- liftStream s'
S.map (NewStrLine id) s''
type StreamID = Word
data Event = NewStream (String, InputStream ByteString)
| NewStrLine !StreamID (Lifted ByteString)
| CursesKeyEvent Key
| HeartBeat
instance Show Event where
show (NewStream (s,_)) = "NewStream "++s
show (NewStrLine sid str) = "NewStrLine "++show sid++" "++show str
show (CursesKeyEvent k) = "CursesKeyEvent "++ show k
computeTiling :: Word -> (Word,Word)
computeTiling reqWins =
if (n' 1) * n' >= reqWins
then (n' 1, n')
else (n', n')
where
n :: Double
n = sqrt (fromIntegral reqWins)
n' = ceiling n
applyTiling :: (Word, Word) -> (Word, Word) -> NonEmpty WinPos
applyTiling _ a2@(splitsY,splitsX)
| splitsX < 1 || splitsY < 1 =
error$"applyTiling: cannot split ZERO ways in either dimension: "++show(a2)
applyTiling (screenY,screenX) (splitsY,splitsX) = NE.fromList$
[ (height,width, yStrt, xStrt)
| (yStrt,height) <- doDim screenY splitsY
, (xStrt,width) <- doDim screenX splitsX ]
where
doDim :: Word -> Word -> [(Word,Word)]
doDim screen splits = P.zip starts widths'
where
usable = screen 1
(each,left) = usable `quotRem` splits
widths = let (hd,tl) = L.splitAt (fromIntegral left)
(L.replicate (w2i splits) each) in
(L.map (+1) hd) ++ tl
starts = L.init$ L.scanl (+) 0 widths
widths' = L.map (+1) widths
test :: IO ()
test = do
s1 <- S.fromList ["hi","there","you","blah"]
s2 <- S.fromList ["aaa","bbb","ccc"]
Just x <- S.read s1
Just y <- S.read s1
P.putStrLn$"READ FIRST INPUTs: "++show (x,y)
S.unRead y s1
S.unRead x s1
_ <- P.getLine
hydraPrint defaultHydraConf =<< S.fromList [("s1",s1),("s2",s2)]
unzip4 :: Functor f => f (a,b,c,d) -> (f a, f b, f c, f d)
unzip4 xs = ((\(x,_,_,_) -> x) <$> xs,
(\(_,x,_,_) -> x) <$> xs,
(\(_,_,x,_) -> x) <$> xs,
(\(_,_,_,x) -> x) <$> xs)
i2w :: (Show n, Integral n) => n -> Word
i2w i | i < 0 = error$"i2w: Cannot convert negative Int to Word: "++show i
i2w i = fromIntegral i
w2i :: (Show n, Integral n) => Word -> n
w2i w = if i < 0
then error$"w2i: Cannot convert Word to Int: "++show w
else i
where
i = fromIntegral w
timer :: Int -> IO (S.InputStream Event)
timer milles = S.makeInputStream g
where
g = do
threadDelay$ milles * 1000
return (Just HeartBeat)
secsToday :: Curses Double
secsToday = do
now <- io getCurrentTime
return (fromRational$ toRational$ utctDayTime now)
dupStream :: InputStream a -> IO (InputStream a, InputStream a)
dupStream = error "dupStream unimplemented"
liftStream :: InputStream a -> IO (InputStream (Lifted a))
liftStream ins =
do flag <- newIORef True
S.makeInputStream $ do
x <- S.read ins
flg <- readIORef flag
case x of
Just y -> return (Just (StrmElt y))
Nothing | flg -> do writeIORef flag False
return (Just EOS)
| otherwise -> return Nothing
data Lifted a = EOS | StrmElt a
deriving (Show,Eq,Read,Ord)
boundingBox :: NE.NonEmpty WinPos -> WinPos
boundingBox wps = (maxY,maxX, minY,minX)
where
minY = F.foldl1 min ys
minX = F.foldl1 min xs
maxY = F.foldl1 max (NE.zipWith (+) hs ys)
maxX = F.foldl1 max (NE.zipWith (+) ws xs)
(hs,ws,ys,xs) = UI.HydraPrint.unzip4 wps
t0 :: NonEmpty WinPos
t0 = applyTiling (48,173) (3,2)
t1 :: WinPos
t1 = boundingBox t0
#ifndef NOTESTING
case_t0 :: Assertion
case_t0 = assertBool "Basic tiling example"
(noprop_goodtiling (48,173) (3,2))
noprop_goodtiling :: (Word,Word) -> (Word,Word) -> Bool
noprop_goodtiling (y,x) (splitY,splitX) =
if (y>0 && x>0 && splitY>0 && splitX > 0)
then (h == y && w == x)
else True
where
tiles = applyTiling (y,x) (splitY,splitX)
(h,w,0,0) = boundingBox tiles
testSuite :: Test
testSuite = $(testGroupGenerator)
instance (Arbitrary a) => Arbitrary (NE.NonEmpty a) where
arbitrary = (:|) <$> arbitrary <*> arbitrary
shrink x = NE.fromList <$> shrink (NE.toList x)
case_lift :: Assertion
case_lift = do
x <- liftStream =<< S.fromList [1..4]
y <- S.toList x
assertEqual "eq" [StrmElt 1,StrmElt 2,StrmElt 3,StrmElt 4,EOS] y
#endif
removeIfExists :: FilePath -> IO ()
removeIfExists fileName = removeFile fileName `E.catch` handleExists
where handleExists e
| isDoesNotExistError e = return ()
| otherwise = E.throwIO e