Core.hs

{-# LANGUAGE TemplateHaskell #-}

module UI.Core where

import Brick (EventM)
import qualified Brick.Animation as A
import Brick.BChan (BChan)
import Control.Monad.RWS
import qualified Data.Map as Map
import qualified Data.Text as T
import Data.Vector (Vector)
import Editor.Core
import qualified Graphics.Vty as V
import Keymap (FullKeyConfig)
import Lens.Micro.TH (makeLenses)
import Zwirn.Doux.Types (Stream)
import Zwirn.Language.Compiler (Environment, runCIEnv, setExpression)
import Zwirn.Language.Evaluate.Expression
import Zwirn.Language.TypeCheck.Types (Qualified (..), Scheme (..), numberT)

data Name
  = Editor Int
  | EditorViewport Int
  | Cursor
  | Status
  | Output
  | Slider Int
  | Background
  | OptionWin
  | Animator
  | SampleBrowser
  | SampleBrowserViewport
  | Keyboard
  | EnvBrowser
  | EnvBrowserViewport
  | Documentation
  | DocViewport
  | DocLink Int
  | DocCode Int
  deriving (Eq, Ord, Show)

data AppEvent
  = FileSelected (Maybe FilePath)
  | UpdateStatus
  | UpdateOutput (OutputType, String)
  | UpdateEnv
  | ClearFlash
  | AnimationUpdate (EventM Name AppState ())

data DragAction
  = Move
  | ResizeBottom
  | ResizeRight
  | ResizeBoth
  | Content
  deriving (Eq, Show)

data AnimationConfig = AnimationConfig {animationConfigRate :: Int, animationConfigPath :: String}
  deriving (Show, Eq)

data Content
  = StatusContent String Double Double Int Double (Int, Int) Int Int Double
  | OutputContent [(OutputType, String)]
  | EditorContent EditorState
  | SliderContent Double
  | AnimationContent (Maybe (A.Animation AppState Name)) AnimationConfig
  | DocumentationContent Doc DocFocus DocMap
  | SampleBrowserContent SampleBrowser
  | EnvBrowserContent EnvBrowser
  | KeyboardContent Keyboard

newtype DocumentationConfig = DocumentationConfig (Maybe T.Text)
  deriving (Show, Eq)

newtype Keyboard = KeyB {kSound :: Maybe T.Text}

data SampleBrowser = SampleB
  { sbSearchString :: T.Text,
    sbContent :: Vector (T.Text, Int)
  }

data EnvBrowser = EnvB
  { ebSearchString :: T.Text,
    ebContent :: Vector T.Text
  }

data DocFocus
  = CodeFocus Int
  | LinkFocus Int
  | NoFocus
  deriving (Eq, Show)

data DocStyle
  = Normal
  | Emph
  | Strong
  | Code
  deriving (Eq, Show)

data DocInline
  = TextChunk T.Text DocStyle
  | Link T.Text T.Text
  | Linebreak
  deriving (Show, Eq)

data DocBlock
  = Paragraph [DocInline]
  | CodeBlock T.Text
  deriving (Show, Eq)

newtype Doc = Doc [DocBlock]
  deriving (Show, Eq)

type DocMap = Map.Map T.Text Doc

data Option
  = Hide
  | Close
  | Show Name
  | AddEditor
  | AddSlider
  | ToggleAnimation
  | ChangeAnimation
  | ChangeFramerate
  | SetBootPath
  | SetSamplePath
  | ToggleLabel
  | QuitMill
  | Copy
  | GotoStart
  | OpenConfig
  | OpenKeymap
  | SelectAction
  deriving (Eq, Show)

data OptionWindow = OptionWindow
  { optionPos :: (Int, Int),
    optionParent :: Name,
    options :: [Option]
  }

data Window = Window
  { windowPos :: (Int, Int),
    windowSize :: (Int, Int),
    windowContent :: Content,
    windowHidden :: Bool,
    windowLabel :: Bool
  }

type WindowMap = Map.Map Name Window

data AppState = AppState
  { asWindows :: WindowMap,
    asEnvironment :: Environment,
    asStream :: Stream,
    asMaxVoices :: Int,
    asKeyConfig :: FullKeyConfig,
    asVtyOutput :: Maybe V.Output,
    asChan :: BChan AppEvent,
    asDragging :: Maybe ((Int, Int), Name, DragAction),
    asActiveWindow :: Name,
    asOptionWindow :: Maybe OptionWindow,
    asAnimationManager :: A.AnimationManager AppState AppEvent Name
  }

updateSlider :: Int -> Double -> Environment -> IO Environment
updateSlider slidern val env = do
  x <- runCIEnv env (setExpression ("slider" <> T.show slidern) (Forall [] $ Qual [] [] numberT) (EZwirn $ pure $ ENum val))
  case x of
    Right (_, env') -> return env'
    Left _ -> return env

newSlider :: Int -> EventM Name AppState Window
newSlider i = do
  env <- gets asEnvironment
  env' <- liftIO $ updateSlider i 0.5 env
  modify (\as -> as {asEnvironment = env'})
  return $ Window (0, 0) (30, 3) (SliderContent 0.5) False False

data EditorEventEnv = EditorEventEnv
  { _envBChan :: BChan AppEvent,
    _envName :: Name,
    _envKeyConfig :: FullKeyConfig,
    _envVtyOut :: Maybe V.Output,
    _envEnv :: Environment,
    _envEditorState :: EditorState
  }

makeLenses ''EditorEventEnv