{-# LANGUAGE ScopedTypeVariables #-}
module Brick.Main
  ( App(..)
  , defaultMain
  , customMain
  , customMainWithVty
  , simpleMain
  , resizeOrQuit
  , simpleApp

  -- * Event handler functions
  , continue
  , halt
  , suspendAndResume
  , lookupViewport
  , lookupExtent
  , findClickedExtents
  , clickedExtent
  , getVtyHandle

  -- ** Viewport scrolling
  , viewportScroll
  , ViewportScroll
  , vScrollBy
  , vScrollPage
  , vScrollToBeginning
  , vScrollToEnd
  , hScrollBy
  , hScrollPage
  , hScrollToBeginning
  , hScrollToEnd
  , setTop
  , setLeft

  -- * Cursor management functions
  , neverShowCursor
  , showFirstCursor
  , showCursorNamed

  -- * Rendering cache management
  , invalidateCacheEntry
  , invalidateCache

  -- * Renderer internals (for benchmarking)
  , renderFinal
  , getRenderState
  , resetRenderState
  )
where

import qualified Control.Exception as E
import Lens.Micro ((^.), (&), (.~), (%~), _1, _2)
import Control.Monad (forever)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State
import Control.Monad.Trans.Reader
import Control.Concurrent (forkIO, killThread)
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
import Data.Monoid (mempty)
#endif
import qualified Data.Foldable as F
import Data.Maybe (listToMaybe)
import qualified Data.Map as M
import qualified Data.Set as S
import Graphics.Vty
  ( Vty
  , Picture(..)
  , Cursor(..)
  , Event(..)
  , update
  , outputIface
  , displayBounds
  , shutdown
  , nextEvent
  , mkVty
  , defaultConfig
  )
import Graphics.Vty.Attributes (defAttr)

import Brick.BChan (BChan, newBChan, readBChan, readBChan2, writeBChan)
import Brick.Types (Widget, EventM(..))
import Brick.Types.Internal
import Brick.Widgets.Internal
import Brick.AttrMap

-- | The library application abstraction. Your application's operations
-- are represented here and passed to one of the various main functions
-- in this module. An application is in terms of an application state
-- type 's', an application event type 'e', and a resource name type
-- 'n'. In the simplest case 'e' is unused (left polymorphic or set to
-- '()'), but you may define your own event type and use 'customMain'
-- to provide custom events. The state type is the type of application
-- state to be provided by you and iteratively modified by event
-- handlers. The resource name type is the type of names you can assign
-- to rendering resources such as viewports and cursor locations.
data App s e n =
    App { appDraw :: s -> [Widget n]
        -- ^ This function turns your application state into a list of
        -- widget layers. The layers are listed topmost first.
        , appChooseCursor :: s -> [CursorLocation n] -> Maybe (CursorLocation n)
        -- ^ This function chooses which of the zero or more cursor
        -- locations reported by the rendering process should be
        -- selected as the one to use to place the cursor. If this
        -- returns 'Nothing', no cursor is placed. The rationale here
        -- is that many widgets may request a cursor placement but your
        -- application state is what you probably want to use to decide
        -- which one wins.
        , appHandleEvent :: s -> BrickEvent n e -> EventM n (Next s)
        -- ^ This function takes the current application state and an
        -- event and returns an action to be taken and a corresponding
        -- transformed application state. Possible options are
        -- 'continue', 'suspendAndResume', and 'halt'.
        , appStartEvent :: s -> EventM n s
        -- ^ This function gets called once just prior to the first
        -- drawing of your application. Here is where you can make
        -- initial scrolling requests, for example.
        , appAttrMap :: s -> AttrMap
        -- ^ The attribute map that should be used during rendering.
        }

-- | The default main entry point which takes an application and an
-- initial state and returns the final state returned by a 'halt'
-- operation.
defaultMain :: (Ord n)
            => App s e n
            -- ^ The application.
            -> s
            -- ^ The initial application state.
            -> IO s
defaultMain app st = do
    let builder = mkVty defaultConfig
    initialVty <- builder
    customMain initialVty builder Nothing app st

-- | A simple main entry point which takes a widget and renders it. This
-- event loop terminates when the user presses any key, but terminal
-- resize events cause redraws.
simpleMain :: (Ord n)
           => Widget n
           -- ^ The widget to draw.
           -> IO ()
simpleMain w = defaultMain (simpleApp w) ()

-- | A simple application with reasonable defaults to be overridden as
-- desired:
--
-- * Draws only the specified widget
-- * Quits on any event other than resizes
-- * Has no start event handler
-- * Provides no attribute map
-- * Never shows any cursors
simpleApp :: Widget n -> App s e n
simpleApp w =
    App { appDraw = const [w]
        , appHandleEvent = resizeOrQuit
        , appStartEvent = return
        , appAttrMap = const $ attrMap defAttr []
        , appChooseCursor = neverShowCursor
        }

-- | An event-handling function which continues execution of the event
-- loop only when resize events occur; all other types of events trigger
-- a halt. This is a convenience function useful as an 'appHandleEvent'
-- value for simple applications using the 'Event' type that do not need
-- to get more sophisticated user input.
resizeOrQuit :: s -> BrickEvent n e -> EventM n (Next s)
resizeOrQuit s (VtyEvent (EvResize _ _)) = continue s
resizeOrQuit s _ = halt s

data InternalNext n a = InternalSuspendAndResume (RenderState n) (IO a)
                      | InternalHalt a

readBrickEvent :: BChan (BrickEvent n e) -> BChan e -> IO (BrickEvent n e)
readBrickEvent brickChan userChan = either id AppEvent <$> readBChan2 brickChan userChan

runWithVty :: (Ord n)
           => Vty
           -> BChan (BrickEvent n e)
           -> Maybe (BChan e)
           -> App s e n
           -> RenderState n
           -> s
           -> IO (InternalNext n s)
runWithVty vty brickChan mUserChan app initialRS initialSt = do
    pid <- forkIO $ supplyVtyEvents vty brickChan
    let readEvent = case mUserChan of
          Nothing -> readBChan brickChan
          Just uc -> readBrickEvent brickChan uc
        runInner rs st = do
          (result, newRS) <- runVty vty readEvent app st (resetRenderState rs)
          case result of
              SuspendAndResume act -> do
                  killThread pid
                  return $ InternalSuspendAndResume newRS act
              Halt s -> do
                  killThread pid
                  return $ InternalHalt s
              Continue s -> runInner newRS s
    runInner initialRS initialSt

-- | The custom event loop entry point to use when the simpler ones
-- don't permit enough control. Returns the final application state
-- after the application halts.
customMain :: (Ord n)
           => Vty
           -- ^ The initial Vty handle to use.
           -> IO Vty
           -- ^ An IO action to build a Vty handle. This is used
           -- to build a Vty handle whenever the event loop needs
           -- to reinitialize the terminal, e.g. on resume after
           -- suspension.
           -> Maybe (BChan e)
           -- ^ An event channel for sending custom events to the event
           -- loop (you write to this channel, the event loop reads from
           -- it). Provide 'Nothing' if you don't plan on sending custom
           -- events.
           -> App s e n
           -- ^ The application.
           -> s
           -- ^ The initial application state.
           -> IO s
customMain initialVty buildVty mUserChan app initialAppState = do
    (s, vty) <- customMainWithVty initialVty buildVty mUserChan app initialAppState
    shutdown vty
    return s

-- | Like 'customMain', except the last 'Vty' handle used by the
-- application is returned without being shut down with 'shutdown'. This
-- allows the caller to re-use the 'Vty' handle for something else, such
-- as another Brick application.
customMainWithVty :: (Ord n)
                  => Vty
                  -- ^ The initial Vty handle to use.
                  -> IO Vty
                  -- ^ An IO action to build a Vty handle. This is used
                  -- to build a Vty handle whenever the event loop needs
                  -- to reinitialize the terminal, e.g. on resume after
                  -- suspension.
                  -> Maybe (BChan e)
                  -- ^ An event channel for sending custom events to the event
                  -- loop (you write to this channel, the event loop reads from
                  -- it). Provide 'Nothing' if you don't plan on sending custom
                  -- events.
                  -> App s e n
                  -- ^ The application.
                  -> s
                  -- ^ The initial application state.
                  -> IO (s, Vty)
customMainWithVty initialVty buildVty mUserChan app initialAppState = do
    let run vty rs st brickChan = do
            result <- runWithVty vty brickChan mUserChan app rs st
                `E.catch` (\(e::E.SomeException) -> shutdown vty >> E.throw e)
            case result of
                InternalHalt s -> return (s, vty)
                InternalSuspendAndResume newRS action -> do
                    shutdown vty
                    newAppState <- action
                    newVty <- buildVty
                    run newVty (newRS { renderCache = mempty }) newAppState brickChan

    let emptyES = ES [] mempty
        emptyRS = RS M.empty mempty S.empty mempty mempty
        eventRO = EventRO M.empty initialVty mempty emptyRS

    (st, eState) <- runStateT (runReaderT (runEventM (appStartEvent app initialAppState)) eventRO) emptyES
    let initialRS = RS M.empty (esScrollRequests eState) S.empty mempty []
    brickChan <- newBChan 20
    run initialVty initialRS st brickChan

supplyVtyEvents :: Vty -> BChan (BrickEvent n e) -> IO ()
supplyVtyEvents vty chan =
    forever $ do
        e <- nextEvent vty
        writeBChan chan $ VtyEvent e

runVty :: (Ord n)
       => Vty
       -> IO (BrickEvent n e)
       -> App s e n
       -> s
       -> RenderState n
       -> IO (Next s, RenderState n)
runVty vty readEvent app appState rs = do
    (firstRS, exts) <- renderApp vty app appState rs
    e <- readEvent

    (e', nextRS, nextExts) <- case e of
        -- If the event was a resize, redraw the UI to update the
        -- viewport states before we invoke the event handler since we
        -- want the event handler to have access to accurate viewport
        -- information.
        VtyEvent (EvResize _ _) -> do
            (rs', exts') <- renderApp vty app appState $ firstRS & observedNamesL .~ S.empty
            return (e, rs', exts')
        VtyEvent (EvMouseDown c r button mods) -> do
            let matching = findClickedExtents_ (c, r) exts
            case matching of
                (Extent n (Location (ec, er)) _ (Location (oC, oR)):_) ->
                    -- If the clicked extent was registered as
                    -- clickable, send a click event. Otherwise, just
                    -- send the raw mouse event
                    case n `elem` firstRS^.clickableNamesL of
                        True -> do
                            let localCoords = Location (lc, lr)
                                lc = c - ec + oC
                                lr = r - er + oR

                                -- If the clicked extent was a viewport,
                                -- adjust the local coordinates by
                                -- adding the viewport upper-left corner
                                -- offset.
                                newCoords = case M.lookup n (viewportMap firstRS) of
                                  Nothing -> localCoords
                                  Just vp -> localCoords & _1 %~ (+ (vp^.vpLeft))
                                                         & _2 %~ (+ (vp^.vpTop))

                            return (MouseDown n button mods newCoords, firstRS, exts)
                        False -> return (e, firstRS, exts)
                _ -> return (e, firstRS, exts)
        VtyEvent (EvMouseUp c r button) -> do
            let matching = findClickedExtents_ (c, r) exts
            case matching of
                (Extent n (Location (ec, er)) _ (Location (oC, oR)):_) ->
                    -- If the clicked extent was registered as
                    -- clickable, send a click event. Otherwise, just
                    -- send the raw mouse event
                    case n `elem` firstRS^.clickableNamesL of
                        True -> do
                            let localCoords = Location (lc, lr)
                                lc = c - ec + oC
                                lr = r - er + oR
                                -- If the clicked extent was a viewport,
                                -- adjust the local coordinates by
                                -- adding the viewport upper-left corner
                                -- offset.
                                newCoords = case M.lookup n (viewportMap firstRS) of
                                  Nothing -> localCoords
                                  Just vp -> localCoords & _1 %~ (+ (vp^.vpLeft))
                                                         & _2 %~ (+ (vp^.vpTop))
                            return (MouseUp n button newCoords, firstRS, exts)
                        False -> return (e, firstRS, exts)
                _ -> return (e, firstRS, exts)
        _ -> return (e, firstRS, exts)

    let emptyES = ES [] mempty
        eventRO = EventRO (viewportMap nextRS) vty nextExts nextRS

    (next, eState) <- runStateT (runReaderT (runEventM (appHandleEvent app appState e'))
                                eventRO) emptyES
    return (next, nextRS { rsScrollRequests = esScrollRequests eState
                         , renderCache = applyInvalidations (cacheInvalidateRequests eState) $
                                         renderCache nextRS
                         })

applyInvalidations :: (Ord n) => S.Set (CacheInvalidateRequest n) -> M.Map n v -> M.Map n v
applyInvalidations ns cache =
    if InvalidateEntire `S.member` ns
    then mempty
    else foldr (.) id (mkFunc <$> F.toList ns) cache
    where
        mkFunc InvalidateEntire = const mempty
        mkFunc (InvalidateSingle n) = M.delete n

-- | Given a viewport name, get the viewport's size and offset
-- information from the most recent rendering. Returns 'Nothing' if
-- no such state could be found, either because the name was invalid
-- or because no rendering has occurred (e.g. in an 'appStartEvent'
-- handler).
lookupViewport :: (Ord n) => n -> EventM n (Maybe Viewport)
lookupViewport n = EventM $ asks (M.lookup n . eventViewportMap)

-- | Did the specified mouse coordinates (column, row) intersect the
-- specified extent?
clickedExtent :: (Int, Int) -> Extent n -> Bool
clickedExtent (c, r) (Extent _ (Location (lc, lr)) (w, h) _) =
   c >= lc && c < (lc + w) &&
   r >= lr && r < (lr + h)

-- | Given a resource name, get the most recent rendering extent for the
-- name (if any).
lookupExtent :: (Eq n) => n -> EventM n (Maybe (Extent n))
lookupExtent n = EventM $ asks (listToMaybe . filter f . latestExtents)
    where
        f (Extent n' _ _ _) = n == n'

-- | Given a mouse click location, return the extents intersected by the
-- click. The returned extents are sorted such that the first extent in
-- the list is the most specific extent and the last extent is the most
-- generic (top-level). So if two extents A and B both intersected the
-- mouse click but A contains B, then they would be returned [B, A].
findClickedExtents :: (Int, Int) -> EventM n [Extent n]
findClickedExtents pos = EventM $ asks (findClickedExtents_ pos . latestExtents)

findClickedExtents_ :: (Int, Int) -> [Extent n] -> [Extent n]
findClickedExtents_ pos = reverse . filter (clickedExtent pos)

-- | Get the Vty handle currently in use.
getVtyHandle :: EventM n Vty
getVtyHandle = EventM $ asks eventVtyHandle

-- | Invalidate the rendering cache entry with the specified resource
-- name.
invalidateCacheEntry :: (Ord n) => n -> EventM n ()
invalidateCacheEntry n = EventM $ do
    lift $ modify (\s -> s { cacheInvalidateRequests = S.insert (InvalidateSingle n) $ cacheInvalidateRequests s })

-- | Invalidate the entire rendering cache.
invalidateCache :: (Ord n) => EventM n ()
invalidateCache = EventM $ do
    lift $ modify (\s -> s { cacheInvalidateRequests = S.insert InvalidateEntire $ cacheInvalidateRequests s })

getRenderState :: EventM n (RenderState n)
getRenderState = EventM $ asks oldState

resetRenderState :: RenderState n -> RenderState n
resetRenderState s =
    s & observedNamesL .~ S.empty
      & clickableNamesL .~ mempty

renderApp :: Vty -> App s e n -> s -> RenderState n -> IO (RenderState n, [Extent n])
renderApp vty app appState rs = do
    sz <- displayBounds $ outputIface vty
    let (newRS, pic, theCursor, exts) = renderFinal (appAttrMap app appState)
                                        (appDraw app appState)
                                        sz
                                        (appChooseCursor app appState)
                                        rs
        picWithCursor = case theCursor of
            Nothing -> pic { picCursor = NoCursor }
            Just cloc -> pic { picCursor = AbsoluteCursor (cloc^.locationColumnL)
                                                          (cloc^.locationRowL)
                             }

    update vty picWithCursor

    return (newRS, exts)

-- | Ignore all requested cursor positions returned by the rendering
-- process. This is a convenience function useful as an
-- 'appChooseCursor' value when a simple application has no need to
-- position the cursor.
neverShowCursor :: s -> [CursorLocation n] -> Maybe (CursorLocation n)
neverShowCursor = const $ const Nothing

-- | Always show the first cursor, if any, returned by the rendering
-- process. This is a convenience function useful as an
-- 'appChooseCursor' value when a simple program has zero or more
-- widgets that advertise a cursor position.
showFirstCursor :: s -> [CursorLocation n] -> Maybe (CursorLocation n)
showFirstCursor = const listToMaybe

-- | Show the cursor with the specified resource name, if such a cursor
-- location has been reported.
showCursorNamed :: (Eq n) => n -> [CursorLocation n] -> Maybe (CursorLocation n)
showCursorNamed name locs =
    let matches l = l^.cursorLocationNameL == Just name
    in listToMaybe $ filter matches locs

-- | A viewport scrolling handle for managing the scroll state of
-- viewports.
data ViewportScroll n =
    ViewportScroll { viewportName :: n
                   -- ^ The name of the viewport to be controlled by
                   -- this scrolling handle.
                   , hScrollPage :: Direction -> EventM n ()
                   -- ^ Scroll the viewport horizontally by one page in
                   -- the specified direction.
                   , hScrollBy :: Int -> EventM n ()
                   -- ^ Scroll the viewport horizontally by the
                   -- specified number of rows or columns depending on
                   -- the orientation of the viewport.
                   , hScrollToBeginning :: EventM n ()
                   -- ^ Scroll horizontally to the beginning of the
                   -- viewport.
                   , hScrollToEnd :: EventM n ()
                   -- ^ Scroll horizontally to the end of the viewport.
                   , vScrollPage :: Direction -> EventM n ()
                   -- ^ Scroll the viewport vertically by one page in
                   -- the specified direction.
                   , vScrollBy :: Int -> EventM n ()
                   -- ^ Scroll the viewport vertically by the specified
                   -- number of rows or columns depending on the
                   -- orientation of the viewport.
                   , vScrollToBeginning :: EventM n ()
                   -- ^ Scroll vertically to the beginning of the viewport.
                   , vScrollToEnd :: EventM n ()
                   -- ^ Scroll vertically to the end of the viewport.
                   , setTop :: Int -> EventM n ()
                   -- ^ Set the top row offset of the viewport.
                   , setLeft :: Int -> EventM n ()
                   -- ^ Set the left column offset of the viewport.
                   }

addScrollRequest :: (n, ScrollRequest) -> EventM n ()
addScrollRequest req = EventM $ do
    lift $ modify (\s -> s { esScrollRequests = req : esScrollRequests s })

-- | Build a viewport scroller for the viewport with the specified name.
viewportScroll :: n -> ViewportScroll n
viewportScroll n =
    ViewportScroll { viewportName       = n
                   , hScrollPage        = \dir -> addScrollRequest (n, HScrollPage dir)
                   , hScrollBy          = \i ->   addScrollRequest (n, HScrollBy i)
                   , hScrollToBeginning =         addScrollRequest (n, HScrollToBeginning)
                   , hScrollToEnd       =         addScrollRequest (n, HScrollToEnd)
                   , vScrollPage        = \dir -> addScrollRequest (n, VScrollPage dir)
                   , vScrollBy          = \i ->   addScrollRequest (n, VScrollBy i)
                   , vScrollToBeginning =         addScrollRequest (n, VScrollToBeginning)
                   , vScrollToEnd       =         addScrollRequest (n, VScrollToEnd)
                   , setTop             = \i ->   addScrollRequest (n, SetTop i)
                   , setLeft            = \i ->   addScrollRequest (n, SetLeft i)
                   }

-- | Continue running the event loop with the specified application
-- state.
continue :: s -> EventM n (Next s)
continue = return . Continue

-- | Halt the event loop and return the specified application state as
-- the final state value.
halt :: s -> EventM n (Next s)
halt = return . Halt

-- | Suspend the event loop, save the terminal state, and run the
-- specified action. When it returns an application state value, restore
-- the terminal state, empty the rendering cache, redraw the application
-- from the new state, and resume the event loop.
suspendAndResume :: IO s -> EventM n (Next s)
suspendAndResume = return . SuspendAndResume