module Graphics.Vty.Widgets.EventLoop
( Collection
, CollectionError(..)
, runUi
, schedule
, shutdownUi
, newCollection
, addToCollection
, addToCollectionWithCallbacks
, setCurrentEntry
, EntryHide
, EntryShow
)
where
import Data.IORef
import Data.Typeable
import Data.Default (def)
import Control.Concurrent ( forkIO )
import Control.Concurrent.STM ( atomically )
import Control.Concurrent.STM.TChan
import Control.Exception
import Control.Monad
import System.IO.Unsafe ( unsafePerformIO )
import Graphics.Vty
import Graphics.Vty.Widgets.Core
data CombinedEvent = VTYEvent Event
| UserEvent UserEvent
| ShutdownUi
data UserEvent = ScheduledAction (IO ())
eventChan :: TChan CombinedEvent
eventChan = unsafePerformIO newTChanIO
runUi :: Collection -> RenderContext -> IO ()
runUi collection ctx = do
vty <- mkVty def
_ <- forkIO $ vtyEventListener vty eventChan
setCurrentEntry collection 0
runUi' vty eventChan collection ctx `finally` shutdown vty
vtyEventListener :: Vty -> TChan CombinedEvent -> IO ()
vtyEventListener vty chan =
forever $ do
e <- nextEvent vty
atomically $ writeTChan chan $ VTYEvent e
schedule :: IO () -> IO ()
schedule act = atomically $ writeTChan eventChan $ UserEvent $ ScheduledAction act
shutdownUi :: IO ()
shutdownUi = atomically $ unGetTChan eventChan ShutdownUi
runUi' :: Vty -> TChan CombinedEvent -> Collection -> RenderContext -> IO ()
runUi' vty chan collection ctx = do
sz <- displayBounds $ outputIface vty
e <- getCurrentEntry collection
let fg = entryFocusGroup e
img <- entryRenderAndPosition e (0, 0) sz ctx
update vty $ picForLayers [img]
mPos <- getCursorPosition fg
case mPos of
Just (w, h) -> do
showCursor $ outputIface vty
setCursorPos (outputIface vty) w h
Nothing -> hideCursor $ outputIface vty
let getNextEvents = do
evt <- readTChan chan
em <- isEmptyTChan chan
case em of
True -> return [evt]
False -> do
rest <- getNextEvents
return $ evt : rest
evts <- atomically getNextEvents
let processEvent lastCont evt = do
if not lastCont then
return False else
case evt of
VTYEvent (EvKey k mods) -> handleKeyEvent fg k mods >> return True
VTYEvent _ -> return True
UserEvent (ScheduledAction act) -> act >> return True
ShutdownUi -> return False
cont <- foldM processEvent True evts
when cont $ runUi' vty chan collection ctx
data CollectionError = BadCollectionIndex Int
deriving (Show, Typeable)
instance Exception CollectionError
type EntryShow = IO ()
type EntryHide = IO ()
data Entry = forall a. (Show a) => Entry
{ entryWidget :: Widget a
, entryFocusGroup :: Widget FocusGroup
, entryShowCallback :: EntryShow
, entryHideCallback :: EntryHide
}
data CollectionData =
CollectionData { entries :: [Entry]
, currentEntryNum :: Int
}
type Collection = IORef CollectionData
instance Show CollectionData where
show (CollectionData es num) = concat [ "Collection { "
, "entries = <", show $ length es, "entries>"
, ", currentEntryNum = ", show num
, " }"
]
entryRenderAndPosition :: Entry -> DisplayRegion -> DisplayRegion -> RenderContext -> IO Image
entryRenderAndPosition (Entry { entryWidget = w }) = renderAndPosition w
newCollection :: IO Collection
newCollection =
newIORef $ CollectionData { entries = []
, currentEntryNum = 1
}
getMaybeCurrentEntry :: Collection -> IO (Maybe Entry)
getMaybeCurrentEntry cRef = do
cur <- currentEntryNum <~ cRef
es <- entries <~ cRef
if cur == 1
then return Nothing
else if cur >= 0 && cur < length es
then return . Just $ es !! cur
else return Nothing
getCurrentEntry :: Collection -> IO Entry
getCurrentEntry cRef = do
maybeEntry <- getMaybeCurrentEntry cRef
cur <- currentEntryNum <~ cRef
case maybeEntry of
Nothing -> throw $ BadCollectionIndex cur
Just entry -> return entry
addToCollection :: (Show a) => Collection -> Widget a -> Widget FocusGroup -> IO (IO ())
addToCollection cRef wRef fg = addToCollectionWithCallbacks cRef wRef fg (return ()) (return ())
addToCollectionWithCallbacks :: (Show a) => Collection -> Widget a
-> Widget FocusGroup -> EntryShow
-> EntryHide -> IO (IO ())
addToCollectionWithCallbacks cRef wRef fg onShowCb onHideCb = do
i <- (length . entries) <~ cRef
modifyIORef cRef $ \st ->
st { entries = (entries st) ++ [Entry wRef fg onShowCb onHideCb]
, currentEntryNum = if currentEntryNum st == 1
then 0
else currentEntryNum st
}
resetFocusGroup fg
return $ setCurrentEntry cRef i
setCurrentEntry :: Collection -> Int -> IO ()
setCurrentEntry cRef i = do
st <- readIORef cRef
if i < length (entries st) && i >= 0
then do
maybeOldEntry <- getMaybeCurrentEntry cRef
case maybeOldEntry of
Nothing -> return ()
Just oldEntry -> entryHideCallback oldEntry
(modifyIORef cRef $ \s -> s { currentEntryNum = i })
else throw $ BadCollectionIndex i
e <- getCurrentEntry cRef
entryShowCallback e
resetFocusGroup $ entryFocusGroup e