Event.hs

{- HLINT ignore "Use tuple-section" -}
module UI.Event where

import Brick hiding (on, str)
import Brick.Keybindings
import Control.Monad (unless, void)
import Control.Monad.RWS
import Data.List (intercalate, uncons)
import qualified Data.Map as Map
import qualified Data.Text as T
import Data.Time
import Docs.Event (handleDocEvent)
import Editor.Core (OutputType (..))
import Editor.Event (editorToAppEvent)
import EnvBrowser.Event (handleEnvBrowserEvent, updateEnvBrowser)
import qualified Graphics.Vty as V
import Keyboard.Event (handleKeyboardEvent)
import Keymap
import SampleBrowser.Event (handleSampleBrowserEvent)
import Session (quitEvent)
import Sound.Doux.Engine (activeVoices, douxVersion, load, memory, peakVoices, scheduleDepth)
import UI.Core
import UI.Window
import Zwirn.Doux.Types (Stream (..))
import Zwirn.Doux.UI (streamGetBPM, streamGetCPS, streamGetCycle)
import Zwirn.Language.Compiler (compilerInterpreterBasic, runCIEnv)

handleEvent :: BrickEvent Name AppEvent -> EventM Name AppState ()
handleEvent ev = do
  handledd <- handleGlobalEvent ev
  unless handledd $ do
    active <- gets getActiveWindow
    case active of
      Just (name, win) -> do
        win' <- handleWindowEvent (name, win) ev
        wm <- gets asWindows
        modify $ \as -> as {asWindows = Map.insert name win' wm}
      Nothing -> return ()

getActiveWindow :: AppState -> Maybe (Name, Window)
getActiveWindow as = (\val -> (asActiveWindow as, val)) <$> Map.lookup (asActiveWindow as) (asWindows as)

handleWindowEvent :: (Name, Window) -> BrickEvent Name AppEvent -> EventM Name AppState Window
handleWindowEvent (name, Window p s (EditorContent es) h l) ev = editorToAppEvent name es ev >>= \es' -> return $ Window p s (EditorContent es') h l
handleWindowEvent (_, Window p s (DocumentationContent d c m) h l) ev = handleDocEvent d c m ev >>= \(d', f) -> return (Window p s (DocumentationContent d' f m) h l)
handleWindowEvent (_, Window p s (SampleBrowserContent sb) h l) ev = handleSampleBrowserEvent sb ev >>= \sb' -> return (Window p s (SampleBrowserContent sb') h l)
handleWindowEvent (_, Window p s (EnvBrowserContent sb) h l) ev = handleEnvBrowserEvent sb ev >>= \sb' -> return (Window p s (EnvBrowserContent sb') h l)
handleWindowEvent (_, Window p s (KeyboardContent k) h l) ev = handleKeyboardEvent k ev >>= \k' -> return (Window p s (KeyboardContent k') h l)
handleWindowEvent (_, win) _ = return win

handleGlobalEvent :: BrickEvent Name AppEvent -> EventM Name AppState Bool
handleGlobalEvent (VtyEvent (V.EvKey key mods)) = gets asKeyConfig >>= \conf -> handleKey (globalKeyDispatcher $ kGlobal conf) key mods
handleGlobalEvent (AppEvent UpdateStatus) = handled updateStatus
handleGlobalEvent (AppEvent UpdateEnv) = handled updateEnvBrowser
handleGlobalEvent (AppEvent (AnimationUpdate a)) = handled a
handleGlobalEvent (AppEvent (UpdateOutput o)) = handled $ updateOutput o
handleGlobalEvent (MouseUp _ (Just V.BLeft) _) = handled $ modify $ \as -> as {asDragging = Nothing}
handleGlobalEvent (MouseDown name V.BRight _ (Location pos)) = handled $ rightClickWindow name pos
handleGlobalEvent (MouseDown OptionWin V.BLeft _ (Location pos)) = handled $ clickOptionWindow pos
handleGlobalEvent (MouseDown name V.BLeft _ (Location (mx, my))) = handled $ do
  closeOptions
  drag <- gets asDragging
  case drag of
    Just (pos, dragged, action) -> do
      ab <- getAbsolutePos (name, dragged) (mx, my)
      dragWindow dragged ab pos action
    Nothing -> clickWindow name (mx, my) >> modify (\as -> as {asActiveWindow = parentWindow name})
handleGlobalEvent _ = return False

handled :: (Monad m) => m a -> m Bool
handled x = x >> return True

hushEvent :: EventM Name AppState ()
hushEvent = do
  env <- gets asEnvironment
  void $ liftIO $ runCIEnv env (compilerInterpreterBasic "hush")
  updateOutput (OutputInfo, "Hush.")

panicEvent :: EventM Name AppState ()
panicEvent = do
  env <- gets asEnvironment
  void $ liftIO $ runCIEnv env (compilerInterpreterBasic "panic")
  updateOutput (OutputInfo, "Panic.")

customActionEvent :: T.Text -> EventM Name AppState ()
customActionEvent exe = do
  env <- gets asEnvironment
  x <- liftIO $ runCIEnv env (compilerInterpreterBasic exe)
  case x of
    Right _ -> updateOutput (OutputInfo, "Ran custom action: " <> T.unpack exe)
    Left _ -> updateOutput (OutputError, "Failed to run custom action.")

updateStatus :: EventM Name AppState ()
updateStatus = do
  wm <- gets asWindows
  case Map.lookup Status wm of
    Nothing -> return ()
    Just (Window _ _ _ True _) -> return ()
    Just (Window _ _ _ False _) -> do
      str <- gets asStream
      mx <- gets asMaxVoices
      ver <- liftIO douxVersion
      ld <- liftIO $ realToFrac <$> load (sDoux str)
      voices <- liftIO $ activeVoices (sDoux str)
      peak <- liftIO $ peakVoices (sDoux str)
      schedule <- liftIO $ scheduleDepth (sDoux str)
      samples <- liftIO $ realToFrac <$> memory (sDoux str)
      bpm <- liftIO $ streamGetBPM str
      cps <- liftIO $ streamGetCPS str
      cyc <- liftIO $ streamGetCycle str
      let f (Just (Window p s _ False l)) = Just $ Window p s (StatusContent ver bpm cps cyc ld (voices, mx) peak schedule samples) False l
          f _ = Nothing
          wm' = Map.alter f Status wm
      modify $ \as -> as {asWindows = wm'}

updateOutput :: (OutputType, String) -> EventM Name AppState ()
updateOutput (t, cont) = do
  wm <- gets asWindows
  case Map.lookup Output wm of
    Just (Window _ _ (OutputContent os) False _) -> do
      time <- liftIO getZonedTime
      let f Nothing = Nothing
          f (Just (Window p s _ h l)) = Just $ Window p s (OutputContent $ (t, prettyShowContent time cont) : take 20 os) h l
          wm' = Map.alter f Output wm
      modify $ \as -> as {asWindows = wm'}
    _ -> return ()

showTime :: ZonedTime -> String
showTime = take 8 . show . localTimeOfDay . zonedTimeToLocalTime

prettyShowContent :: ZonedTime -> String -> String
prettyShowContent time cont = case uncons $ lines cont of
  Just (x, xs) -> showTime time <> " - " <> intercalate "\n" (x : map (\y -> replicate 11 ' ' <> y) xs)
  Nothing -> showTime time <> " - " <> cont

globalEventHandlerConstructor :: GlobalAction -> (T.Text, EventM Name AppState ())
globalEventHandlerConstructor Quit = ("exit ziwnrmill", quitEvent)
globalEventHandlerConstructor Hush = ("stop playing sound", hushEvent)
globalEventHandlerConstructor Panic = ("stop playing sound immediately", panicEvent)
globalEventHandlerConstructor (CustomAction x) = ("execute custom action", customActionEvent x)

globalEventHandlers :: KeyConfig GlobalAction -> [KeyEventHandler GlobalAction (EventM Name AppState)]
globalEventHandlers conf = map (\a -> toEventHandler a (globalEventHandlerConstructor a)) as
  where
    toEventHandler a (t, ev) = onEvent a t ev
    as = map snd $ keyEventsList $ keyConfigEvents conf

globalKeyDispatcher :: KeyConfig GlobalAction -> KeyDispatcher GlobalAction (EventM Name AppState)
globalKeyDispatcher conf = case keyDispatcher conf (globalEventHandlers conf) of
  Left err -> error $ show (map fst err)
  Right dis -> dis