content: {-|
  Module      : Monomer.Main.Core
  Copyright   : (c) 2018 Francisco Vallarino
  License     : BSD-3-Clause (see the LICENSE file)
  Maintainer  : fjvallarino@gmail.com
  Stability   : experimental
  Portability : non-portable
  
  Core glue for running an application.
  -}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE LambdaCase #-}
  {-# LANGUAGE RecordWildCards #-}
  {-# LANGUAGE Strict #-}
  
  module Monomer.Main.Core (
    AppEventResponse,
    AppEventHandler,
    AppUIBuilder,
    startApp
  ) where
  
  import Control.Concurrent
  import Control.Concurrent.STM.TChan (TChan, newTChanIO, readTChan, writeTChan)
  import Control.Exception
  import Control.Lens ((&), (^.), (.=), (.~), _2, use)
  import Control.Monad.Extra
  import Control.Monad.State
  import Control.Monad.STM (atomically)
  import Data.Default
  import Data.Either (isLeft)
  import Data.Maybe (fromMaybe, fromJust, isJust)
  import Data.Map (Map)
  import Data.Text (Text)
  import Data.Time
  import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
  import Data.Word (Word32)
  import Graphics.GL
  
  import qualified Data.Map as Map
  import qualified Data.Sequence as Seq
  import qualified Data.Text as T
  import qualified Foreign.Store as FS
  import qualified SDL
  
  import Monomer.Core
  import Monomer.Core.Combinators
  import Monomer.Event
  import Monomer.Main.Handlers
  import Monomer.Main.Platform
  import Monomer.Main.Types
  import Monomer.Main.Util
  import Monomer.Main.WidgetTask
  import Monomer.Graphics
  import Monomer.Helper (catchAny, putStrLnErr, isGhciRunning)
  import Monomer.Widgets.Composite
  
  import qualified Monomer.Lens as L
  
  {-|
  Type of response an App event handler can return, with __s__ being the model and
  __e__ the user's event type.
  -}
  type AppEventResponse s e = EventResponse s e s e
  
  -- | Type of an App event handler.
  type AppEventHandler s e
    = WidgetEnv s e            -- ^ The widget environment.
    -> WidgetNode s e          -- ^ The root node of the application.
    -> s                       -- ^ The application's model.
    -> e                       -- ^ The event to handle.
    -> [AppEventResponse s e]  -- ^ The list of requested actions.
  
  -- | Type of the function responsible of creating the App UI.
  type AppUIBuilder s e = UIBuilder s e
  
  -- | Updated information for the current step of the event loop.
  data MainLoopArgs sp e ep = MainLoopArgs {
    _mlIsGhci :: Bool,
    _mlOS :: Text,
    _mlTheme :: Theme,
    _mlAppStartTs :: Millisecond,
    _mlMaxFps :: Int,
    _mlLatestRenderTs :: Millisecond,
    _mlFrameStartTs :: Millisecond,
    _mlFrameAccumTs :: Millisecond,
    _mlFrameCount :: Int,
    _mlExitEvents :: [e],
    _mlWidgetRoot :: WidgetNode sp ep,
    _mlWidgetShared :: MVar (Map Text WidgetShared)
  }
  
  -- | State information for the rendering thread.
  data RenderState s e = RenderState {
    _rstDpr :: Double,
    _rstWidgetEnv :: WidgetEnv s e,
    _rstRootNode :: WidgetNode s e
  }
  
  {-|
  Information for hot reload of an application running on ghci.
  
  When running in interpreted mode, SDL initialization and window creation data
  will be reused on further code updates.
  -}
  data MonomerReloadData s e = MonomerReloadData {
    -- | The active window.
    _mrdWindow :: !SDL.Window,
    -- | The OpenGL context associated to the window.
    _mrdGlContext :: !SDL.GLContext,
    -- | The latest context.
    _mrdMonomerCtx :: !(MonomerCtx s e),
    -- | The fingerprint of the model. Used to detect changes in the data type.
    _mrdModelFp :: !String,
    -- | The latest widget tree.
    _mrdRoot :: !(WidgetNode s e)
  }
  
  {-|
  Runs an application, creating the UI with the provided function and initial
  model, handling future events with the event handler.
  
  Control will not be returned until the UI exits. This needs to be ran in the
  main thread if using macOS.
  -}
  startApp
    :: (Eq s, WidgetModel s, WidgetEvent e)
    => s                    -- ^ The initial model.
    -> AppEventHandler s e  -- ^ The event handler.
    -> AppUIBuilder s e     -- ^ The UI builder.
    -> [AppConfig s e]      -- ^ The application config.
    -> IO ()                -- ^ The application action.
  startApp newModel eventHandler uiBuilder configs = do
    isGhci <- isGhciRunning
    channel <- newTChanIO
  
    (model, oldRoot) <- retrieveModelAndRoot config newModel newRoot
    (window, glCtx, ctx) <- retrieveSDLWindow config channel model
  
    when isGhci $
      setReloadData (MonomerReloadData window glCtx ctx modelFp newRoot)
  
    resp <- runStateT (runAppLoop window glCtx channel oldRoot newRoot config) ctx
  
    -- Even when running on ghci, if exitApplication == True it means the user
    -- closed the window and it will need to be created again on reload.
    when (not isGhci || resp ^. _2 . L.exitApplication) $ do
      destroySDLWindow window
      resetReloadData
    where
      config = mconcat configs
      compCfgs
        = (onInit <$> _apcInitEvent config)
        ++ (onDispose <$> _apcDisposeEvent config)
        ++ (onResize <$> _apcResizeEvent config)
      ~modelFp = maybe "" ($ newModel) (_apcModelFingerprintFn config)
      newRoot = composite_ "app" id uiBuilder eventHandler compCfgs
  
  runAppLoop
    :: (MonomerM sp ep m, Eq sp, WidgetEvent e, WidgetEvent ep)
    => SDL.Window
    -> SDL.GLContext
    -> TChan (RenderMsg sp ep)
    -> Maybe (WidgetNode sp ep)
    -> WidgetNode sp ep
    -> AppConfig s e
    -> m ()
  runAppLoop window glCtx channel mRootOld newRoot config = do
    isGhci <- liftIO isGhciRunning
    dpr <- use L.dpr
    winSize <- use L.windowSize
  
    let useRenderThreadFlag = fromMaybe True (_apcUseRenderThread config)
    let useRenderThread = useRenderThreadFlag && rtsSupportsBoundThreads
    let maxFps = fromMaybe 60 (_apcMaxFps config)
    let fonts = _apcFonts config
    let theme = fromMaybe def (_apcTheme config)
    let exitEvents = _apcExitEvent config
    let mainBtn = fromMaybe BtnLeft (_apcMainButton config)
    let contextBtn = fromMaybe BtnRight (_apcContextButton config)
  
    appStartTs <- getCurrentTimestamp
    model <- use L.mainModel
    os <- liftIO getPlatform
    widgetSharedMVar <- liftIO $ newMVar Map.empty
    fontManager <- liftIO $ makeFontManager fonts dpr
    -- Restore previous state
    hovered <- getHoveredPath
    focused <- getFocusedPath
    overlay <- getOverlayPath
    dragged <- getDraggedMsgInfo
  
    let wenv = WidgetEnv {
      _weOs = os,
      _weDpr = dpr,
      _weIsGhci = isGhci,
      _weAppStartTs = appStartTs,
      _weFontManager = fontManager,
      _weFindBranchByPath = const Seq.empty,
      _weMainButton = mainBtn,
      _weContextButton = contextBtn,
      _weTheme = theme,
      _weWindowSize = winSize,
      _weWidgetShared = widgetSharedMVar,
      _weWidgetKeyMap = Map.empty,
      _weCursor = Nothing,
      _weHoveredPath = hovered,
      _weFocusedPath = focused,
      _weOverlayPath = overlay,
      _weDragStatus = dragged,
      _weMainBtnPress = Nothing,
      _weModel = model,
      _weInputStatus = def,
      _weTimestamp = 0,
      _weThemeChanged = False,
      _weInTopLayer = const True,
      _weLayoutDirection = LayoutNone,
      _weViewport = Rect 0 0 (winSize ^. L.w) (winSize ^. L.h),
      _weOffset = def
    }
    let tmpRoot = newRoot
          & L.info . L.path .~ rootPath
          & L.info . L.widgetId .~ WidgetId (wenv ^. L.timestamp) rootPath
    let mergeNewRoot newRoot oldRoot = result where
          result = widgetMerge (newRoot ^. L.widget) wenv newRoot oldRoot
    let result = maybe (resultNode tmpRoot) (mergeNewRoot tmpRoot) mRootOld
    let appRoot = result ^. L.node
    let makeMainThreadRenderer = do
          renderer <- liftIO $ makeRenderer fonts dpr
          L.renderMethod .= Left renderer
          return RenderSetupSingle
  
    setupRes <- if useRenderThread
      then do
        stpChan <- liftIO newTChanIO
  
        liftIO . void . forkOS $
          {-
          The wenv and appRoot values are not used, since they are replaced
          during MsgInit. Kept to avoid issues with the Strict pragma.
          -}
          startRenderThread stpChan channel window glCtx fonts dpr wenv appRoot
  
        setupRes <- liftIO . atomically $ readTChan stpChan
  
        case setupRes of
          RenderSetupMakeCurrentFailed msg -> do
            liftIO . putStrLnErr $ "Setup of the rendering thread failed: " ++ msg
            liftIO . putStrLnErr $ "Falling back to rendering in the main thread. "
              ++ "The content may not be updated while resizing the window."
  
            makeMainThreadRenderer
          _ -> do
            return RenderSetupMulti
      else do
        makeMainThreadRenderer
  
    handleResourcesInit
  
    (newWenv, newAppRoot, _) <- if isJust mRootOld
      then handleWidgetResult wenv True result
      else handleWidgetInit wenv appRoot
  
    {-
    Deferred initialization step to account for Widgets that rely on OpenGL. They
    need the Renderer to be setup before handleWidgetInit is called, and it is
    safer to initialize the watcher after this happens.
    -}
    case setupRes of
      RenderSetupMulti -> do
        liftIO . atomically $ writeTChan channel (MsgInit newWenv newAppRoot)
  
        unless (isLinux newWenv) $
          liftIO $ watchWindowResize channel
      _ -> return ()
  
    let loopArgs = MainLoopArgs {
      _mlIsGhci = isGhci,
      _mlOS = os,
      _mlTheme = theme,
      _mlMaxFps = maxFps,
      _mlAppStartTs = appStartTs,
      _mlLatestRenderTs = 0,
      _mlFrameStartTs = 0,
      _mlFrameAccumTs = 0,
      _mlFrameCount = 0,
      _mlExitEvents = exitEvents,
      _mlWidgetRoot = newAppRoot,
      _mlWidgetShared = widgetSharedMVar
    }
  
    L.mainModel .= _weModel newWenv
  
    mainLoop window fontManager config loopArgs
  
  mainLoop
    :: (MonomerM sp ep m, WidgetEvent e)
    => SDL.Window
    -> FontManager
    -> AppConfig s e
    -> MainLoopArgs sp e ep
    -> m ()
  mainLoop window fontManager config loopArgs = do
    let MainLoopArgs{..} = loopArgs
  
    startTs <- getElapsedTimestampSince _mlAppStartTs
    events <- SDL.pumpEvents >> SDL.pollEvents
  
    windowSize <- use L.windowSize
    dpr <- use L.dpr
    epr <- use L.epr
    currentModel <- use L.mainModel
    cursorIcon <- getCurrentCursorIcon
    hovered <- getHoveredPath
    focused <- getFocusedPath
    overlay <- getOverlayPath
    dragged <- getDraggedMsgInfo
    mainPress <- use L.mainBtnPress
    inputStatus <- use L.inputStatus
    mousePos <- liftIO $ getCurrentMousePos epr
    currWinSize <- liftIO $ getViewportSize window dpr
    prevRenderNeeded <- use L.renderRequested
  
    let Size rw rh = windowSize
    let ts = startTs - _mlFrameStartTs
    let eventsPayload = fmap SDL.eventPayload events
    let quit = SDL.QuitEvent `elem` eventsPayload
  
    let windowResized = currWinSize /= windowSize && isWindowResized eventsPayload
    let windowExposed = isWindowExposed eventsPayload
    let mouseEntered = isMouseEntered eventsPayload
    let invertX = fromMaybe False (_apcInvertWheelX config)
    let invertY = fromMaybe False (_apcInvertWheelY config)
    let convertCfg = ConvertEventsCfg _mlOS dpr epr invertX invertY
    let baseSystemEvents = convertEvents convertCfg mousePos eventsPayload
  
  --  when newSecond $
  --    liftIO . putStrLnErr $ "Frames: " ++ show _mlFrameCount
  
    when quit $
      L.exitApplication .= True
  
    when windowExposed $
      L.mainBtnPress .= Nothing
  
    let newSecond = _mlFrameAccumTs > 1000
    let mainBtn = fromMaybe BtnLeft (_apcMainButton config)
    let contextBtn = fromMaybe BtnRight (_apcContextButton config)
    let wenv = WidgetEnv {
      _weOs = _mlOS,
      _weDpr = dpr,
      _weIsGhci = _mlIsGhci,
      _weAppStartTs = _mlAppStartTs,
      _weFontManager = fontManager,
      _weFindBranchByPath = findChildBranchByPath wenv _mlWidgetRoot,
      _weMainButton = mainBtn,
      _weContextButton = contextBtn,
      _weTheme = _mlTheme,
      _weWindowSize = windowSize,
      _weWidgetShared = _mlWidgetShared,
      _weWidgetKeyMap = Map.empty,
      _weCursor = cursorIcon,
      _weHoveredPath = hovered,
      _weFocusedPath = focused,
      _weOverlayPath = overlay,
      _weDragStatus = dragged,
      _weMainBtnPress = mainPress,
      _weModel = currentModel,
      _weInputStatus = inputStatus,
      _weTimestamp = startTs,
      _weThemeChanged = False,
      _weInTopLayer = const True,
      _weLayoutDirection = LayoutNone,
      _weViewport = Rect 0 0 rw rh,
      _weOffset = def
    }
    -- Exit handler
    let baseWidgetId = _mlWidgetRoot ^. L.info . L.widgetId
    let exitMsgs = SendMessage baseWidgetId <$> _mlExitEvents
    let baseReqs
          | quit = Seq.fromList exitMsgs
          | otherwise = Seq.Empty
    let baseStep = (wenv, _mlWidgetRoot, Seq.empty)
  
    L.renderRequested .= False
  
    (rqWenv, rqRoot, _) <- handleRequests baseReqs baseStep
    (wtWenv, wtRoot, _) <- handleWidgetTasks rqWenv rqRoot
    (seWenv, seRoot, _) <- handleSystemEvents wtWenv wtRoot baseSystemEvents
  
    (newWenv, newRoot, _) <- if windowResized
      then do
        L.windowSize .= currWinSize
        handleResizeWidgets (seWenv, seRoot, Seq.empty)
      else return (seWenv, seRoot, Seq.empty)
  
    endTs <- getElapsedTimestampSince _mlAppStartTs
  
    -- Rendering
    renderCurrentReq <- checkRenderCurrent startTs _mlLatestRenderTs
    renderMethod <- use L.renderMethod
  
    let actionEvt = any isActionEvent eventsPayload
    let renderResize = windowResized && (isLinux wenv || isLeft renderMethod)
    let windowRenderEvt = renderResize || any isWindowRenderEvent eventsPayload
    let renderNeeded = windowRenderEvt || actionEvt || renderCurrentReq
  
    when (prevRenderNeeded || renderNeeded) $
      case renderMethod of
        Right renderChan -> do
          liftIO . atomically $ writeTChan renderChan (MsgRender newWenv newRoot)
        Left renderer -> do
          let bgColor = newWenv ^. L.theme . L.clearColor
  
          liftIO $ renderWidgets window dpr renderer bgColor newWenv newRoot
  
    {-
    Used in the next rendering cycle.
  
    Temporary workaround: when rendering is needed, make sure to render the next
    frame too in order to avoid visual artifacts.
    -}
    L.renderRequested .= renderNeeded
  
    let fps = realToFrac _mlMaxFps
    let frameLength = round (1000000 / fps)
    let remainingMs = endTs - startTs
    let tempDelay = abs (frameLength - fromIntegral remainingMs * 1000)
    let nextFrameDelay = min frameLength tempDelay
    let latestRenderTs = if renderNeeded then startTs else _mlLatestRenderTs
    let newModel = newWenv ^. L.model
    let newLoopArgs = loopArgs {
      _mlLatestRenderTs = latestRenderTs,
      _mlFrameStartTs = startTs,
      _mlFrameAccumTs = if newSecond then 0 else _mlFrameAccumTs + ts,
      _mlFrameCount = if newSecond then 0 else _mlFrameCount + 1,
      _mlWidgetRoot = newRoot
    }
  
    when _mlIsGhci $ do
      ctx <- get
      liftIO $ updateReloadData ctx newRoot
  
    liftIO $ threadDelay nextFrameDelay
  
    shouldQuit <- use L.exitApplication
  
    when shouldQuit $
      void $ handleWidgetDispose newWenv newRoot
  
    unless shouldQuit (mainLoop window fontManager config newLoopArgs)
  
  {-
  Attempts to initialize a GL context in a separate OS thread to handle rendering
  actions. This allows for continuous content updates when the user resizes the
  window.
  
  In case the setup fails, it notifies the parent process so it can fall back to
  rendering in the main thread.
  -}
  startRenderThread
    :: (Eq s, WidgetEvent e)
    => TChan RenderSetupResult
    -> TChan (RenderMsg s e)
    -> SDL.Window
    -> SDL.GLContext
    -> [FontDef]
    -> Double
    -> WidgetEnv s e
    -> WidgetNode s e
    -> IO ()
  startRenderThread setupChan msgChan window glCtx fonts dpr wenv root = do
    resp <- try $ SDL.glMakeCurrent window glCtx
  
    case resp of
      Right{} -> do
        renderer <- liftIO $ makeRenderer fonts dpr
        fontMgr <- liftIO $ makeFontManager fonts dpr
  
        atomically $ writeTChan setupChan RenderSetupMulti
  
        waitRenderMsg msgChan window renderer fontMgr state
      Left (SDL.SDLCallFailed _ _ err) -> do
        let msg = T.unpack err
        atomically $ writeTChan setupChan (RenderSetupMakeCurrentFailed msg)
      Left e -> do
        let msg = displayException e
        atomically $ writeTChan setupChan (RenderSetupMakeCurrentFailed msg)
    where
      state = RenderState dpr wenv root
  
  waitRenderMsg
    :: (Eq s, WidgetEvent e)
    => TChan (RenderMsg s e)
    -> SDL.Window
    -> Renderer
    -> FontManager
    -> RenderState s e
    -> IO ()
  waitRenderMsg msgChan window renderer fontMgr state = do
    msg <- atomically $ readTChan msgChan
    newState <- handleRenderMsg window renderer fontMgr state msg
    waitRenderMsg msgChan window renderer fontMgr newState
  
  handleRenderMsg
    :: (Eq s, WidgetEvent e)
    => SDL.Window
    -> Renderer
    -> FontManager
    -> RenderState s e
    -> RenderMsg s e
    -> IO (RenderState s e)
  handleRenderMsg window renderer fontMgr state (MsgInit newWenv newRoot) = do
    let RenderState dpr _ _ = state
    return (RenderState dpr newWenv newRoot)
  handleRenderMsg window renderer fontMgr state (MsgRender tmpWenv newRoot) = do
    let RenderState dpr _ _ = state
    let newWenv = tmpWenv
          & L.fontManager .~ fontMgr
    let color = newWenv ^. L.theme . L.clearColor
  
    renderWidgets window dpr renderer color newWenv newRoot
    return (RenderState dpr newWenv newRoot)
  handleRenderMsg window renderer fontMgr state (MsgResize _) = do
    newSize <- getViewportSize window (_rstDpr state)
  
    let RenderState dpr wenv root = state
    let viewport = Rect 0 0 (newSize ^. L.w) (newSize ^. L.h)
    let newWenv = wenv
          & L.fontManager .~ fontMgr
          & L.windowSize .~ newSize
          & L.viewport .~ viewport
    let color = newWenv ^. L.theme . L.clearColor
    let resizeCheck = const False
    let result = widgetResize (root ^. L.widget) newWenv root viewport resizeCheck
    let newRoot = result ^. L.node
  
    renderWidgets window dpr renderer color newWenv newRoot
    return state
  handleRenderMsg window renderer fontMgr state (MsgRemoveImage name) = do
    deleteImage renderer name
    return state
  handleRenderMsg window renderer fontMgr state (MsgRunInRender chan task) = do
    flip catchAny print $ do
      value <- task
      atomically $ writeTChan chan value
    return state
  
  renderWidgets
    :: SDL.Window
    -> Double
    -> Renderer
    -> Color
    -> WidgetEnv s e
    -> WidgetNode s e
    -> IO ()
  renderWidgets window dpr renderer clearColor wenv widgetRoot = do
    Size dwW dwH <- getDrawableSize window
    Size vpW vpH <- getViewportSize window dpr
  
    glViewport 0 0 (round dwW) (round dwH)
  
    glClearColor r g b a
    glClear GL_COLOR_BUFFER_BIT
  
    beginFrame renderer vpW vpH
    widgetRender (widgetRoot ^. L.widget) wenv widgetRoot renderer
    endFrame renderer
  
    renderRawTasks renderer
  
    beginFrame renderer vpW vpH
    renderOverlays renderer
    endFrame renderer
  
    renderRawOverlays renderer
  
    SDL.glSwapWindow window
    where
      r = fromIntegral (clearColor ^. L.r) / 255
      g = fromIntegral (clearColor ^. L.g) / 255
      b = fromIntegral (clearColor ^. L.b) / 255
      a = realToFrac (clearColor ^. L.a)
  
  watchWindowResize :: TChan (RenderMsg s e) -> IO ()
  watchWindowResize channel = do
    void . SDL.addEventWatch $ \ev -> do
      case SDL.eventPayload ev of
        SDL.WindowSizeChangedEvent sizeChangeData -> do
          let SDL.V2 nw nh = SDL.windowSizeChangedEventSize sizeChangeData
          let newSize = Size (fromIntegral nw) (fromIntegral nh)
  
          atomically $ writeTChan channel (MsgResize newSize)
        _ -> return ()
  
  checkRenderCurrent :: (MonomerM s e m) => Millisecond -> Millisecond -> m Bool
  checkRenderCurrent currTs renderTs = do
    renderCurrent <- use L.renderRequested
    schedule <- use L.renderSchedule
    L.renderSchedule .= Map.filter (renderScheduleActive currTs) schedule
    return (renderCurrent || renderNext schedule)
    where
      requiresRender = renderScheduleReq currTs renderTs
      renderNext schedule = any requiresRender schedule
  
  renderScheduleReq :: Millisecond -> Millisecond -> RenderSchedule -> Bool
  renderScheduleReq currTs renderTs schedule = required where
    RenderSchedule _ start ms _ = schedule
    stepCount = floor (fromIntegral (currTs - start) / fromIntegral ms)
    stepTs = start + ms * stepCount
    required = renderTs < stepTs
  
  renderScheduleActive :: Millisecond -> RenderSchedule -> Bool
  renderScheduleActive currTs schedule = scheduleActive where
    RenderSchedule _ start ms count = schedule
    stepCount = floor (fromIntegral (currTs - start) / fromIntegral ms)
    scheduleActive = maybe True (> stepCount) count
  
  isWindowResized :: [SDL.EventPayload] -> Bool
  isWindowResized eventsPayload = not status where
    status = null [ e | e@SDL.WindowResizedEvent {} <- eventsPayload ]
  
  isWindowExposed :: [SDL.EventPayload] -> Bool
  isWindowExposed eventsPayload = not status where
    status = null [ e | e@SDL.WindowExposedEvent {} <- eventsPayload ]
  
  isMouseEntered :: [SDL.EventPayload] -> Bool
  isMouseEntered eventsPayload = not status where
    status = null [ e | e@SDL.WindowGainedMouseFocusEvent {} <- eventsPayload ]
  
  isWindowRenderEvent :: SDL.EventPayload -> Bool
  isWindowRenderEvent SDL.WindowShownEvent{} = True
  isWindowRenderEvent SDL.WindowExposedEvent{} = True
  isWindowRenderEvent SDL.WindowMovedEvent{} = True
  isWindowRenderEvent SDL.WindowResizedEvent{} = True
  isWindowRenderEvent SDL.WindowSizeChangedEvent{} = True
  isWindowRenderEvent SDL.WindowMaximizedEvent{} = True
  isWindowRenderEvent SDL.WindowRestoredEvent{} = True
  isWindowRenderEvent SDL.WindowGainedMouseFocusEvent{} = True
  isWindowRenderEvent SDL.WindowGainedKeyboardFocusEvent{} = True
  isWindowRenderEvent _ = False
  
  getCurrentTimestamp :: MonadIO m => m Millisecond
  getCurrentTimestamp = toMs <$> liftIO getCurrentTime
    where
      toMs = floor . (1e3 *) . nominalDiffTimeToSeconds . utcTimeToPOSIXSeconds
  
  getElapsedTimestampSince :: MonadIO m => Millisecond -> m Millisecond
  getElapsedTimestampSince start = do
    ts <- getCurrentTimestamp
    return (ts - start)
  
  -- Hot reload support
  
  reloadStoreId :: Word32
  reloadStoreId = 0
  
  getReloadData :: IO (Maybe (MonomerReloadData s e))
  getReloadData = FS.lookupStore reloadStoreId >>= \case
    Just{} -> Just <$> FS.readStore (FS.Store reloadStoreId)
    _ -> return Nothing
  
  setReloadData :: MonomerReloadData s e -> IO ()
  setReloadData = FS.writeStore (FS.Store reloadStoreId)
  
  resetReloadData :: IO ()
  resetReloadData = FS.deleteStore (FS.Store reloadStoreId)
  
  updateReloadData :: MonomerCtx s e -> WidgetNode s e -> IO ()
  updateReloadData context widgetRoot = do
    whenJustM getReloadData $ \rd ->
      setReloadData rd {
        _mrdMonomerCtx = context,
        _mrdRoot = widgetRoot
      }
  
  {-|
  When running in GHCi, avoids reinitializing SDL, reuses the existing window and
  restores the model and (merged) widget tree when code is reloaded.
  -}
  retrieveSDLWindow
    :: AppConfig s e
    -> TChan (RenderMsg s e)
    -> s
    -> IO (SDL.Window, SDL.GLContext, MonomerCtx s e)
  retrieveSDLWindow config channel model = do
    getReloadData >>= \case
      Just rd -> return (_mrdWindow rd, _mrdGlContext rd, newCtx) where
        ctx = _mrdMonomerCtx rd
        newCtx = ctx {
          _mcMainModel = model,
          _mcRenderMethod = Right channel
        }
      Nothing -> do
        (window, dpr, epr, ctxRender) <- initSDLWindow config
        vpSize <- getViewportSize window dpr
        let newCtx = initMonomerCtx window channel vpSize dpr epr model
        return (window, ctxRender, newCtx)
  
  retrieveModelAndRoot
    :: WidgetModel s
    => AppConfig s e
    -> s
    -> WidgetNode s e
    -> IO (s, Maybe (WidgetNode s e))
  retrieveModelAndRoot config newModel newRoot = getReloadData >>= \case
    Just rd
      | attemptModelReuse && fingerprint == _mrdModelFp rd ->
          return (_mrdMonomerCtx rd ^. L.mainModel, Just (_mrdRoot rd))
    _ -> do
      return (newModel, Nothing)
    where
      attemptModelReuse = isJust (_apcModelFingerprintFn config)
      ~fingerprint = fromJust (_apcModelFingerprintFn config) newModel
  