hydra-print-0.1.0.0: UI/HydraPrint.hs
{-# LANGUAGE OverloadedStrings, NamedFieldPuns #-}
{-# LANGUAGE CPP #-}
#define UPDATE_ALL_ALWAYS
#ifndef NOTESTING
{-# LANGUAGE TemplateHaskell #-}
#endif
-- | A simple utility to multiplex of *dynamic* collection of text streams. As the
-- number of streams varies, the multiplexing of the terminal output does too.
module UI.HydraPrint
(
-- * hydraPrint and friends
hydraPrint, hydraPrintStatic,
HydraConf(..), defaultHydraConf, DeleteWinWhen(..)
-- * Types
-- * Tiling behavior
-- computeTiling, applyTiling
#ifndef NOTESTING
-- * Testing
, testSuite
#endif
-- TEMPORARY:
, 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 hiding (unzip4)
import Control.Monad
import Control.Concurrent (threadDelay)
import Control.Monad.IO.Class (liftIO, MonadIO)
import Control.Exception
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 Control.Monad.State
-- import Control.Monad.Reader
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
--------------------------------------------------------------------------------
-- User visible configuration
--------------------------------------------------------------------------------
data HydraConf =
HydraConf
{
-- majorMode :: -- | Interleaved, windows, or serialized.
deleteWhen :: DeleteWinWhen,
useColor :: Bool -- Use colors if they are supported.
-- TODO: Introduce environment variables:
-- HYDRA_COLOR
-- HYDRA_DELETEWHEN
-- ...
}
-- | How long should we wait after a stream goes dry to close the window associated
-- with it? If 'Never' is selected, then the window will stay until a new stream
-- causes the screen to reconfigure, or hydraPrint exits.
data DeleteWinWhen = Never
| After Seconds
| Immediately
type Seconds = Double
-- | Like the name says, a default set of options for passing to `hydraPrint`.
defaultHydraConf :: HydraConf
defaultHydraConf =
HydraConf
{
deleteWhen = After 3.0,
useColor = True
}
--------------------------------------------------------------------------------
-- Internal Types
--------------------------------------------------------------------------------
-- | The state of an active `hydraPrint` computation.
data MPState =
MPState
{
activeStrms :: M.Map StreamID WindowWidget,
-- | Windows whose streams have ended but are not yet removed (deleteWhen).
-- Each entry stores its timeout.
dyingStrms :: [(StreamID, Seconds, WindowWidget)],
-- | Streams that are gone and have no widget.
deadStrms :: [StreamHistory],
-- | All active windows. Need to be explicitly deleted.
windows :: [CWindow],
-- | All color IDs, cycle through these for new windows.
colorIDs :: [ColorID]
-- Log: TODO: could log stream create/delete events and their times.
}
-- | All the state for a widget, that persists beyond the creation and destruction of
-- individual NCurses windows (and even the reinitialization of the whole system).
--
-- These text widgets currently do NOT support line wrapping. They crop to the right
-- and at the bottom.
data WindowWidget =
WindowWidget
{
-- "Methods"
----------------------------------------
-- | The current and previous text in the widget.
hist :: StreamHistory,
-- | Get the current size of the writable area.
textSizeYX :: IO (Word,Word),
-- | Replace a line within the window, clearing the rest of the line if the
-- string is too short, and cropping it if it is too long. The `Word` argument
-- is a zero-based index into the writable area of the window. Drawing off the
-- end of the window will be ignored.
putLine :: ByteString -> Curses (),
-- putLineN :: Word -> String -> IO ()
-- | Just redraw it.
repaint :: Curses (),
setWin :: CWindow -> Curses (),
-- "Private" state:
----------------------------------------
winRef :: IORef CWindow
}
-- | The history of a stream. The view changes, but the underlying stream histories
-- persist.
data StreamHistory =
StreamHistory {
-- | The name of a stream might identify a client hostname, or a subprogram run,
-- or a file being compiled. These are displayed so as to help distinguish
-- different windows from one another, especially as the layout changes.
streamName :: String,
-- | A (reverse) list of lines with the most recently produced at the head.
revHist :: IORef [ByteString]
}
-- | Most of the computation for this module happens in the context of a global,
-- mutable state.
-- type MP a = StateT (IORef MPState) IO a
-- | Position of a window: (Height,Width, PosY, PosX)
-- The same order as accepted by `newWin`.
type WinPos = (Word,Word,Word,Word)
-- | Along with the raw pointer, remember the size at which a window was created:
data CWindow = CWindow C.Window WinPos (String,ColorID)
deriving Show
--------------------------------------------------------------------------------
-- These are all the basic colors currently exported by UI.NCurses, except black:
-- We make sure the basic, white-on-black option is first.
allColors :: [Color]
--allColors = [ColorWhite, ColorGreen, ColorCyan, ColorMagenta, ColorYellow, ColorRed, ColorBlue]
allColors = [ColorGreen, ColorCyan, ColorMagenta, ColorYellow, ColorRed, ColorBlue]
-- TODO: Pair attributes with them:
-- AttributeStandout
-- AttributeUnderline
-- AttributeReverse
-- AttributeBlink
-- AttributeDim
-- AttributeBold
-- AttributeAltCharset
-- AttributeInvisible
-- AttributeProtect
-- Return a finite list of color IDs, we rotate through these.
initColors :: Curses [ColorID]
initColors = do
supports <- supportsColor
if supports then do
cdc <- canDefineColor
mx <- maxColorID
-- Here we make the backgrounds actually black instead of grey:
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]
-- | Create a new batch of NCurses windows (deleting the old ones) and display the
-- current state of a set of stream histories.
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)
-- when dbg $ do dbgLogLn msg
-- moveCursor 1 2
-- drawString msg
-- drawBox Nothing Nothing
let cwin = CWindow w1 tup (name,colorID)
#ifndef UPDATE_ALL_ALWAYS
updateWindow w1$ drawNamedBorder cwin
#endif
return cwin
return (ws,nX,nY)
-- For blanking out inactive windows.
blankChar :: Char
blankChar = ' '
{-
-- | Use the simple method of writing blanks to clear. Convention: overwrite the
-- lower & right borders, but not the top/left.
clearWindow :: CWindow -> IO ()
clearWindow (CWindow wp (hght,wid,_,_)) = do
let
width' = wid - borderLeft -- - borderRight
blank = P.replicate (w2i width') blankChar
forM_ [borderTop .. hght - borderBottom - 1 ] $ \ yind -> do
-- forM_ [borderTop .. hght - 1] $ \ yind -> do
-- forM_ [hght - 1 .. hght - 1] $ \ yind -> do
wMove wp (w2i yind) (w2i borderLeft)
wAddStr wp blank
-- blit wp blank
writeToCorner wp (w2i$ hght-1) (w2i borderLeft) blank
wnoutRefresh wp
-}
-- Nah, this won't do it... odd that there's no clear or fill function?
#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 -- - borderRight
blank = P.replicate (w2i width') blankChar
io$ evaluate hght
io$ evaluate wid
io$ evaluate wp
forM_ [borderTop .. hght - borderBottom - 1 ] $ \ yind -> do
moveCursor (w2i yind) (w2i borderLeft)
drawString blank
return ()
writeToCorner (w2i$ hght-1) (w2i borderLeft) blank
-- wnoutRefresh wp
#endif
-- | Write out a string that goes all the way to the bottom/right corner.
writeToCorner :: Int -> Int -> String -> Update ()
writeToCorner y x str = do
let len = P.length str
moveCursor (fromIntegral y) (fromIntegral x)
drawString (P.init str)
-- Uh oh! 'ncurses' doesn't expose winsch either. SKIP IT for now:
-- moveCursor y (len-1)
-- throwIfErr_ "winsch" $ winsch wp (fromIntegral$ ord$ P.last str)
return ()
{-
-- | Write out a string that goes all the way to the bottom/right corner.
writeToCorner :: Window -> Int -> Int -> String -> IO ()
writeToCorner wp y x str = do
-- I'm getting a Curses error if I try to write the lower-right corner character!?9
let len = P.length str
wMove wp y x
wAddStr wp (P.init str)
wMove wp y (len-1)
------------
-- Hack: Even waddch directly is throwing an error in the lower right
-- corner... Hmm. A hack is to ignore the error code.
--throwIfErr_ "waddch" $
-- waddch wp (fromIntegral$ ord blankChar) -- Don't advance the cursor.
------------
-- This seems to be a known issue:
-- http://lists.gnu.org/archive/html/bug-ncurses/2007-09/msg00002.html
throwIfErr_ "winsch" $ winsch wp (fromIntegral$ ord blankChar)
return ()
wAddCh :: Window -> Char -> IO ()
wAddCh wp ch = throwIfErr_ "waddch" $ waddch wp (fromIntegral$ ord ch)
wInsCh :: Window -> Char -> IO ()
wInsCh wp ch = throwIfErr_ "winsch" $ winsch wp (fromIntegral$ ord ch)
blit :: Window -> String -> IO ()
blit wp s =
-- Ignore all non-ascii at the moment:
withCAStringLen s $ \ (s',len) ->
throwIfErr_ "waddchnstr" $ waddchnstr wp s' (fromIntegral len)
blitB :: Window -> ByteString -> IO ()
blitB wp s =
-- Ignore all non-ascii at the moment:
-- B.useAsCStringLen s $ \ (s',len) ->
unsafeUseAsCStringLen s $ \ (s',len) ->
throwIfErr_ "waddchnstr" $ waddchnstr wp s' (fromIntegral len)
-- This SHOULDNT be necessary, but I'm having problems with blanking and blinking
-- otherwise.
redrawAll :: [CWindow] -> IO ()
redrawAll wins = do
-- forM_ wins $ \ (CWindow wp _) -> do
-- wBorder wp defaultBorder
-- wRefresh wp -- TODO: use wnoutrefresh instead
-- wnoutRefresh wp
C.update
-}
redrawAll :: [CWindow] -> Curses ()
redrawAll wins = do
forM_ wins $ \ cwin@(CWindow wp _ _) -> do
#ifdef UPDATE_ALL_ALWAYS
updateWindow wp $ do
-- HACK: This shouldn't be necessary, but I have problems with windows
-- appearing and then disappearing:
--------------------
-- moveCursor 1 1
-- drawString " "
drawNamedBorder cwin
-- drawBox Nothing Nothing
--------------------
return ()
#endif
return ()
C.render
-- How many characters to avoid at the edges of window, for the border:
borderTop :: Word
borderTop = if dbg then 2 else 1
-- borderTop = 2
borderBottom :: Word
borderBottom = 1
borderLeft :: Word
borderLeft = 1
borderRight :: Word
borderRight = 1
-- | Create a new, persistent scrolling text widget.
createWindowWidget :: String -> IO WindowWidget
createWindowWidget streamName = do -- ioStrm
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 -- `B.append` (B.pack (" <line "++show (P.length oldhist)++" y "++show y++">"))
let newhist = msg : oldhist
io$ writeIORef revHist newhist
repaint
-- Redraw all text AND the border:
repaint = do
cwin@(CWindow wp (y,x,_,_) _) <- io$ readIORef winRef
updateWindow wp $ do
newhist <- io$ readIORef revHist
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)
------ Line is put! ----
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
-- wBorder wp defaultBorder
setColor defaultColorID
drawBox Nothing Nothing
setColor winColor
let isTop = (y == 0)
-- name' = llCorner : name ++ [lrCorner]
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$ hght-1) 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
--------------------------------------------------------------------------------
-- | This simply takes the names of the desired initial windows, and sets things up.
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]
-- _ <- leaveOk True
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 -- tail cids ++ [head cids]
}
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
-- | Take a fixed list of input streams. This variant preemptively splits the screen
-- into exactly one panel per stream.
hydraPrintStatic :: HydraConf -> [(String, InputStream ByteString)] -> IO ()
hydraPrintStatic _ [] = return ()
hydraPrintStatic conf srcs = do
-- Because of how steadyStat is structured, we need to peel off the LAST stream:
let (nameL,strmL) = P.last srcs
(names,strms) = unzip (P.init srcs)
strms' <- sequence$ zipWith preProcess [0..] strms
merged <- concurrentMerge strms'
-- We set up all but the LAST stream, and then go into steady state:
initAndRunCurses conf names $ \ initMPS -> do
steadyState conf{deleteWhen=Never} initMPS (i2w$ P.length names) (nameL,strmL) merged
-- steadyState conf initSt 1 (s2name,s2) merge2
--------------------------------------------------------------------------------
-- | Takes a /source/ of input streams, which may be added dynamically. A stream
-- that joins dynamically, exits once it issues an end-of-stream.
--
-- `hydraPrint` is a blocking call that doesn't return until ALL streams that
-- appear produce an end-of-stream, AND the stream-source itself reaches
-- end-of-stream.
hydraPrint :: HydraConf -> InputStream (String, InputStream ByteString) -> IO ()
hydraPrint conf strmSrc = phase0 conf =<< S.map NewStream strmSrc
----------------------------------------PHASE0----------------------------------------
-- Nothing to do before there is at least ONE stream...
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
-- Next, we need a "select/epoll". We use concurrentMerge.
merge1 <- concurrentMerge [strmSrc', s1']
phase1 conf s1name merge1
_ -> error "hydraPrint: Internal error. Unexpected event."
----------------------------------------PHASE1----------------------------------------
-- Initially, we start in "cooked" (non-ncurses) mode, and stay there as long as
-- there is only one output stream.
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..." -- (press enter)
----------------------
-- PROBLEM: We don't want to do a nested runCurses here...
-- cursesEvts <- io$ S.makeInputStream $ fmap (Just . CursesKeyEvent)
-- (C.getEvent defaultWindow Nothing)
-- Warning, because the curses events go into a concurrentMerge, they will keep
-- being read into Haskell, irrespective of what this "main" thread does.
-- merge2 <- io$ concurrentMerge [merge1, cursesEvts]
heartbeat <- timer 200 -- 200ms heartbeat
merge2 <- concurrentMerge [ merge1, heartbeat ]
----------------------
initAndRunCurses conf [s1name] $ \ initMPS ->
-- The first stream as ID 0, so this next one has ID 1:
steadyState conf initMPS 1 (s2name,s2) merge2
Just (CursesKeyEvent _) -> error "Internal error. Shouldn't see Curses event here."
----------------------------------------PHASE3----------------------------------------
-- Re-enter this loop every time there is a new stream.
steadyState :: HydraConf -> MPState -> StreamID -> (String,InputStream ByteString) -> InputStream Event -> Curses ()
steadyState conf state0@MPState{activeStrms,windows} sidCnt (newName,newStrm) merged = do
-- First, deal with the new stream.
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}
-- redraw is next, as soon as we call loop:
-- Second, enter an event loop:
let loop mps@MPState{activeStrms, dyingStrms, deadStrms, windows} = do
-- TEMP:
-- mapM_ repaint (M.elems activeStrms)
redrawAll windows
nxt <- io$ S.read merged'
case nxt of
Nothing -> return ()
Just HeartBeat-> do
-----------------Poll dying windows-------------------
let deadLp mps' [] = loop mps' -- mps{dyingStrms=remain}
deadLp mps' ((sid,timeOut,widg):tl) = do
now <- secsToday
-- io $ dbgPrnt $ "Checking dying time "++show timeOut++" against now: "++show now
if now >= timeOut
-- TODO: Remove duplicate code here:
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
-- Call this below to actually do the poll.
pollAndContinue mps = deadLp mps dyingStrms
-------------------Poll key event-------------------
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
-- windows' <- reCreate activeStrms windows
-- keyLoop hit mps{windows=windows'}
keyLoop hit mps
EventCharacter 'q' -> return ()
_ -> do
-- mapM_ repaint (M.elems activeStrms)
-- C.render
keyLoop True mps
keyLoop False mps
-- hWaitForInput stdin (1000)
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 -- Don't change *anything*..
After secs -> do
now <- secsToday
let dyingStrms' = (sid, secs + now, activeStrms!sid) : dyingStrms
-- FIXME: don't use winRef:
(CWindow wp _ _) <- io$ readIORef (winRef (activeStrms!sid))
updateWindow wp $ return ()
loop mps{ dyingStrms=dyingStrms' }
Immediately -> do
let active' = M.delete sid activeStrms
-- Deleting always shifts down the LAST window (should improve this)
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
{-
KeyChar 'q' -> do
CH.end
dbgLn " [dbg] NCurses finished."
KeyChar 'p' -> do
-- Pause until another key is hit.
_ <- C.getCh
loop mps
KeyResize -> do
C.endWin
C.update
windows' <- reCreate activeStrms windows
-- redrawAll windows'
loop mps{windows=windows'}
-}
_ -> do io$ dbgPrnt $ " [dbg] CURSES Key event: "++show key
loop mps
loop state1
where
dbgPrnt s = when dbg $ do
dbgLogLn s
-- AGAIN, a problem with the Curses monad here... we want to call this before curses is initialized:
-- putLine (P.head$ M.elems activeStrms) (B.pack s)
-- redrawAll windows
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
-- Guaranteed to be in ascending key order, which in our case is
-- first-stream-to-join first.
forM_ (P.zip ws (M.assocs active')) $ \ (win,(sid,wid)) -> do
setWin wid win
-- Actually delete the old windows:
-- forM_ oldWins (\ (CWindow w _) -> delWin w)
forM_ oldWins (\ (CWindow w _ _) -> closeWindow w)
-- io$ dbgPrnt$ " [dbg] Deleted windows: "++show (P.map (\ (CWindow w _) -> w) oldWins)
-- ++ " created "++ show(P.map (\ (CWindow w _) -> w) ws)
----------------------------------------
-- Erase the bit of border which may be unused:
(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
----------- First wipe the horizontal lower border:
let startX = lastCol+1
remainingX = fromIntegral$ nCols - startX
dummy <- newWindow 1 remainingX (w2i$ y+hght-1) startX
let dummyCW = CWindow dummy (1, i2w remainingX, (w2i$ y+hght-1), i2w startX) ("",defaultColorID)
-- wclear dummy; wnoutRefresh dummy
io$ dbgPrnt$ "Dummy horiz (screen "++show (nLines,nCols)++"): "++show dummyCW
-- clearWindow dummyCW
----------- Then the vertical right border:
let startY = (w2i$ y+1)
remainingY = fromIntegral$ nLines - startY - 1
dummy2 <- newWindow remainingY 1 startY (nCols-1)
let dummy2CW = CWindow dummy2 (i2w remainingY, 1, i2w startY, i2w (nCols-1)) ("",defaultColorID)
io$ dbgPrnt$ "Dummy vert: "++show dummy2CW
-- wclear dummy2; wnoutRefresh dummy2
-- clearWindow dummy2CW
return [dummy,dummy2]
else return []
return ws
-- Helper: import a bytestring into our system.
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
-- | There are three relevant kinds of events inside our inner loop.
data Event = NewStream (String, InputStream ByteString)
| NewStrLine {-# UNPACK #-} !StreamID (Lifted ByteString)
| CursesKeyEvent Key
| HeartBeat
-- deriving (Show,Eq,Read,Ord)
instance Show Event where
show (NewStream (s,_)) = "NewStream "++s
show (NewStrLine sid str) = "NewStrLine "++show sid++" "++show str
show (CursesKeyEvent k) = "CursesKeyEvent "++ show k
--------------------------------------------------------------------------------
-- Tiling behavior
--------------------------------------------------------------------------------
-- | If at least `n` windows are required, this computes the x-by-y tiling such that
-- `x * y >= n`. It returns `(x,y)` where `x` represents the number of horizontal
-- tiles and `y` the number of vertical.
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
-- | Split a space into a given X-by-Y tile arrangement, leaving room for borders.
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
-- This is used both for horizontal and vertical, but I use horizontal
-- terminology below:
doDim :: Word -> Word -> [(Word,Word)]
doDim screen splits = P.zip starts widths'
-- Every window must "pay" for its left border, the rightmost border is paid for
-- globally, hence the minus-one here:
where
-- Every window must "pay" for its left border, the rightmost border is paid for
-- globally, hence the minus-one here:
usable = screen - 1
(each,left) = usable `quotRem` splits
-- Here we distribute the remainder as evenly as possible:
widths = let (hd,tl) = L.splitAt (fromIntegral left)
(L.replicate (w2i splits) each) in
(L.map (+1) hd) ++ tl
-- Starting positions are based on the raw widths not counting overlap
starts = L.init$ L.scanl (+) 0 widths
-- Final widths get bumped to include their rightmost border:
widths' = L.map (+1) widths
--------------------------------------------------------------------------------
test :: IO ()
test = do
-- Weird, what will happen:
-- inlines <- S.lines S.stdin
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)]
--------------------------------------------------------------------------------
-- Missing bits that should be elsewhere:
--------------------------------------------------------------------------------
-- | 'unzip4' for `NonEmpty` lists
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)
-- | Annoyingly, many libraries use Int where negative values are not allowed.
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 -- putStrLn "TIMER"
threadDelay$ milles * 1000
return (Just HeartBeat)
secsToday :: Curses Double
secsToday = do
now <- io getCurrentTime
return (fromRational$ toRational$ utctDayTime now)
-- | io-streams do not by default support tee or fan-out, because all reads "pop".
-- This broadcasts an InputStream to two new InputStreams, each of which will
-- receive every element.
--
-- One useful application of this is creating additional copies of a stream before
-- it is connected to a downstream operator like
-- `System.IO.Streams.Concurrent.concurrentMerge`. Once that connection happens,
-- even if one stops demanding output from the `concurrentMerge`, one cannot know
-- how many elements it popped from the original input stream already.
dupStream :: InputStream a -> IO (InputStream a, InputStream a)
dupStream = error "dupStream unimplemented"
-- | This makes the EOS into an /explicit/, penultimate message. This way it survives
-- `concurrentMerge`.
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
-- | Datatype for reifying end-of-stream.
data Lifted a = EOS | StrmElt a
deriving (Show,Eq,Read,Ord)
--------------------------------------------------------------------------------
-- Tests
--------------------------------------------------------------------------------
-- Returns (inclusive,exclusive) bounds.
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))
-- DISABLING: This hangs under quickcheck.
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 -- Trivially.
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 `catch` handleExists
where handleExists e
| isDoesNotExistError e = return ()
| otherwise = throwIO e