content: {-# LANGUAGE DeriveDataTypeable, ExistentialQuantification #-}
  -- |This module provides the main event loop functionality for this
  -- library.  All vty-ui applications must use runUi to get anything
  -- done usefully.
  module Graphics.Vty.Widgets.EventLoop
      ( Collection
      , CollectionError(..)
      , runUi
      , schedule
      , shutdownUi
      , newCollection
      , addToCollection
      , addToCollectionWithCallbacks
      , setCurrentEntry
      , EntryHide
      , EntryShow
      )
  where
  
  import Data.IORef
  import Data.Typeable
  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
  {-# NOINLINE eventChan #-}
  eventChan = unsafePerformIO newTChanIO
  
  -- |Run the main vty-ui event loop using the specified interface
  -- collection and initial rendering context.  The rendering context
  -- provides the default attributes and 'Skin' to use for the
  -- application.  Throws 'BadCollectionIndex' if the specified
  -- 'Collection' is empty.
  runUi :: Collection -> RenderContext -> IO ()
  runUi collection ctx = do
    vty <- mkVty defaultConfig
  
    -- Create VTY event listener thread
    _ <- 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 a widget-mutating 'IO' action to be run by the main event
  -- loop.  Use of this function is required to guarantee consistency
  -- between interface presentation and internal state.
  schedule :: IO () -> IO ()
  schedule act = atomically $ writeTChan eventChan $ UserEvent $ ScheduledAction act
  
  -- |Schedule a vty-ui event loop shutdown.  This event will preempt
  -- others so that it will be processed next.
  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
  
    -- Get the next event(s) in the queue.  Returns all available events;
    -- blocks until at least one event is available.
    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
                     }
  
  -- |The type of user interface collections.
  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
  
  -- |Create a new collection.
  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
  
  -- |Add a widget and its focus group to a collection.  Returns an
  -- action which, when invoked, will switch to the interface specified
  -- in the call.
  addToCollection :: (Show a) => Collection -> Widget a -> Widget FocusGroup -> IO (IO ())
  addToCollection cRef wRef fg = addToCollectionWithCallbacks cRef wRef fg (return ()) (return ())
  
  -- |Add a widget and its focus group to a collection.  In addition, two
  -- callbacks -- one to call when showing the widget and one to call when hiding
  -- it (i.e. showing some other widget) -- must be provided.  Returns an action
  -- which, when invoked, will switch to the interface specified.
  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
        -- Let the old entry know it's no longer current.
        maybeOldEntry <- getMaybeCurrentEntry cRef
        case maybeOldEntry of
          Nothing -> return ()
          Just oldEntry -> entryHideCallback oldEntry
        -- Set the current entry index.
        (modifyIORef cRef $ \s -> s { currentEntryNum = i })
      else throw $ BadCollectionIndex i
  
    e <- getCurrentEntry cRef
    entryShowCallback e
    resetFocusGroup $ entryFocusGroup e
  