{-# 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 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 instance Show CWindow where show (CWindow _ winpos _) = "" -------------------------------------------------------------------------------- -- 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 (" ")) 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