Config.hs

{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module UI.Config where

import Conferer (DefaultConfig (..))
import Conferer.FromConfig (FromConfig (..), fetchFromConfig, (/.))
import Data.List (mapAccumL)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe, isJust)
import qualified Data.Text as T
import qualified Data.Vector as V
import Data.Yaml (ToJSON (..), object, (.=))
import Docs.Markdown (docMap, startDoc)
import Editor.Config (EditorConfig (..), editorFromConfig)
import Editor.Core (esFilePath, esTabWidth)
import Editor.Util (getContent)
import Lens.Micro ((^.))
import SampleBrowser.Load (loadSampleBrowser)
import UI.Core (AnimationConfig (..), Content (..), DocFocus (..), DocumentationConfig (..), EnvBrowser (..), Keyboard (..), Name (..), SampleBrowser (..), Window (..), WindowMap)

data WindowConfig = WindowConfig
  { windowConfigPosX :: Int,
    windowConfigPosY :: Int,
    windowConfigSizeX :: Int,
    windowConfigSizeY :: Int,
    windowConfigHidden :: Bool,
    windowConfigBorder :: Bool,
    windowConfigContent :: WindowContentConfig
  }
  deriving (Show)

data WindowContentConfig
  = WindowAnimationConfig AnimationConfig
  | WindowEditorConfig EditorConfig
  | WindowOutputConfig
  | WindowStatusConfig
  | WindowSliderConfig
  | WindowSampleBrowserConfig
  | WindowEnvBrowserConfig
  | WindowKeyboardConfig
  | WindowDocumentationConfig DocumentationConfig
  deriving (Show)

instance DefaultConfig [WindowConfig] where
  configDef =
    [ WindowConfig 0 0 51 28 False False (WindowEditorConfig $ EditorConfig 4 Nothing Nothing),
      WindowConfig 51 0 23 11 False False WindowStatusConfig,
      WindowConfig 51 11 23 17 False True WindowOutputConfig,
      WindowConfig 74 00 29 28 False False (WindowDocumentationConfig (DocumentationConfig Nothing)),
      WindowConfig 0 28 51 7 True True (WindowAnimationConfig $ AnimationConfig 150 "")
    ]

instance FromConfig WindowConfig where
  fromConfig key configSource = do
    pX <- fetchFromConfig (key /. "posx") configSource
    pY <- fetchFromConfig (key /. "posy") configSource
    sX <- fetchFromConfig (key /. "sizex") configSource
    sY <- fetchFromConfig (key /. "sizey") configSource
    b <- fetchFromConfig (key /. "border") configSource
    h <- fetchFromConfig (key /. "hidden") configSource
    wContent <- fetchFromConfig (key /. "content") configSource
    return $
      WindowConfig
        { windowConfigPosX = fromMaybe 0 pX,
          windowConfigPosY = fromMaybe 0 pY,
          windowConfigSizeX = fromMaybe 0 sX,
          windowConfigSizeY = fromMaybe 0 sY,
          windowConfigHidden = fromMaybe False h,
          windowConfigBorder = fromMaybe True b,
          windowConfigContent = wContent
        }

instance FromConfig WindowContentConfig where
  fromConfig key configSource = do
    typ <- fetchFromConfig (key /. "type") configSource :: IO (Maybe String)
    case typ of
      Just "status" -> pure WindowStatusConfig
      Just "output" -> pure WindowOutputConfig
      Just "slider" -> pure WindowSliderConfig
      Just "samplebrowser" -> pure WindowSampleBrowserConfig
      Just "keyboard" -> pure WindowKeyboardConfig
      Just "envbrowser" -> pure WindowEnvBrowserConfig
      Just "animation" -> WindowAnimationConfig <$> fetchFromConfig key configSource
      Just "editor" -> WindowEditorConfig <$> fetchFromConfig key configSource
      Just "documentation" -> WindowDocumentationConfig <$> fetchFromConfig key configSource
      _ -> pure WindowStatusConfig

instance FromConfig AnimationConfig where
  fromConfig key configSource = do
    r <- fetchFromConfig (key /. "rate") configSource
    p <- fetchFromConfig (key /. "path") configSource
    return (AnimationConfig (fromMaybe 150 r) (fromMaybe "" p))

instance FromConfig DocumentationConfig where
  fromConfig key configSource = do
    p <- fetchFromConfig (key /. "page") configSource
    return (DocumentationConfig p)

windowFromConfig :: Maybe FilePath -> WindowConfig -> IO Window
windowFromConfig mf (WindowConfig x y sx sy hidden border conf) = do
  cont <- contentFromType mf conf
  return $ Window (x, y) (sx, sy) cont hidden border

contentFromType :: Maybe FilePath -> WindowContentConfig -> IO Content
contentFromType _ (WindowEditorConfig c) = do
  es <- editorFromConfig c
  return $ EditorContent es
contentFromType _ WindowStatusConfig = return $ StatusContent "" 138 0.575 0 0 (0, 32) 0 0 0
contentFromType _ WindowOutputConfig = return $ OutputContent []
contentFromType _ WindowSliderConfig = return $ SliderContent 0.5
contentFromType (Just p) WindowSampleBrowserConfig = loadSampleBrowser p >>= \sb -> return $ SampleBrowserContent sb
contentFromType _ WindowSampleBrowserConfig = return $ SampleBrowserContent (SampleB T.empty V.empty)
contentFromType _ WindowEnvBrowserConfig = return $ EnvBrowserContent (EnvB T.empty V.empty)
contentFromType _ WindowKeyboardConfig = return $ KeyboardContent (KeyB Nothing)
contentFromType _ (WindowDocumentationConfig (DocumentationConfig Nothing)) = return $ DocumentationContent startDoc NoFocus docMap
contentFromType _ (WindowDocumentationConfig (DocumentationConfig (Just k))) = case Map.lookup k docMap of
  Just d -> return $ DocumentationContent d NoFocus docMap
  Nothing -> return $ DocumentationContent startDoc NoFocus docMap
contentFromType _ (WindowAnimationConfig c) = return $ AnimationContent Nothing c

windowMapFromConfig :: Maybe FilePath -> [WindowConfig] -> IO WindowMap
windowMapFromConfig mf wcs = addHidden . Map.fromList <$> liftA2 zip ns ws
  where
    ws = mapM (windowFromConfig mf) wcs
    ns = snd . mapAccumL (\st win -> windowNameFromContent st $ windowContent win) (0, 0) <$> ws

windowNameFromContent :: (Int, Int) -> Content -> ((Int, Int), Name)
windowNameFromContent (editors, sliders) (EditorContent _) = ((editors + 1, sliders), Editor $ editors + 1)
windowNameFromContent (editors, sliders) (SliderContent _) = ((editors, sliders + 1), Slider $ sliders + 1)
windowNameFromContent st (StatusContent {}) = (st, Status)
windowNameFromContent st (OutputContent {}) = (st, Output)
windowNameFromContent st (AnimationContent {}) = (st, Animator)
windowNameFromContent st (DocumentationContent {}) = (st, Documentation)
windowNameFromContent st (SampleBrowserContent {}) = (st, SampleBrowser)
windowNameFromContent st (EnvBrowserContent {}) = (st, EnvBrowser)
windowNameFromContent st (KeyboardContent {}) = (st, Keyboard)

addHidden :: WindowMap -> WindowMap
addHidden wm = insertKeyboard $ insertEnv $ insertSamples $ insertDoc $ insertStatus $ insertOutput $ insertAnimator wm
  where
    defaultWindow c = Window (0, 0) (10, 10) c True False
    insertStatus = if Map.notMember Status wm then Map.insert Status (defaultWindow (StatusContent "" 138 0.575 0 0 (0, 32) 0 0 0)) else id
    insertOutput = if Map.notMember Output wm then Map.insert Output (defaultWindow (OutputContent [])) else id
    insertAnimator = if Map.notMember Animator wm then Map.insert Animator (defaultWindow (AnimationContent Nothing (AnimationConfig 150 ""))) else id
    insertDoc = if Map.notMember Documentation wm then Map.insert Documentation (defaultWindow (DocumentationContent startDoc NoFocus docMap)) else id
    insertSamples = if Map.notMember SampleBrowser wm then Map.insert SampleBrowser (defaultWindow (SampleBrowserContent (SampleB T.empty V.empty))) else id
    insertEnv = if Map.notMember EnvBrowser wm then Map.insert EnvBrowser (defaultWindow (EnvBrowserContent (EnvB T.empty V.empty))) else id
    insertKeyboard = if Map.notMember Keyboard wm then Map.insert Keyboard (defaultWindow (KeyboardContent (KeyB Nothing))) else id

configFromContent :: Content -> WindowContentConfig
configFromContent (EditorContent es) = WindowEditorConfig $ EditorConfig (es ^. esTabWidth) (es ^. esFilePath) (if isJust (es ^. esFilePath) then Nothing else Just $ getContent es)
configFromContent (StatusContent {}) = WindowStatusConfig
configFromContent (OutputContent _) = WindowOutputConfig
configFromContent (SliderContent _) = WindowSliderConfig
configFromContent (SampleBrowserContent _) = WindowSampleBrowserConfig
configFromContent (EnvBrowserContent _) = WindowEnvBrowserConfig
configFromContent (KeyboardContent _) = WindowKeyboardConfig
configFromContent (AnimationContent _ c) = WindowAnimationConfig c
configFromContent (DocumentationContent d _ m) = case Map.keys (Map.filter (== d) m) of
  (x : _) -> WindowDocumentationConfig (DocumentationConfig (Just x))
  _ -> WindowDocumentationConfig (DocumentationConfig Nothing)

configFromWindow :: Window -> WindowConfig
configFromWindow (Window (px, py) (sx, sy) c h b) = WindowConfig px py sx sy h b (configFromContent c)

configFromWindowMap :: WindowMap -> [WindowConfig]
configFromWindowMap = map configFromWindow . Map.elems

instance ToJSON WindowContentConfig where
  toJSON WindowOutputConfig = object ["type" .= ("output" :: String)]
  toJSON WindowStatusConfig = object ["type" .= ("status" :: String)]
  toJSON WindowSliderConfig = object ["type" .= ("slider" :: String)]
  toJSON WindowSampleBrowserConfig = object ["type" .= ("samplebrowser" :: String)]
  toJSON WindowEnvBrowserConfig = object ["type" .= ("envbrowser" :: String)]
  toJSON WindowKeyboardConfig = object ["type" .= ("keyboard" :: String)]
  toJSON (WindowDocumentationConfig (DocumentationConfig k)) =
    object
      [ "type" .= ("documentation" :: String),
        "page" .= k
      ]
  toJSON (WindowAnimationConfig (AnimationConfig i p)) =
    object
      [ "type" .= ("animation" :: String),
        "rate" .= i,
        "path" .= p
      ]
  toJSON (WindowEditorConfig (EditorConfig i p c)) =
    object
      [ "type" .= ("editor" :: String),
        "tabwidth" .= i,
        "path" .= p,
        "content" .= c
      ]

instance ToJSON WindowConfig where
  toJSON (WindowConfig px py sx sy h b c) =
    object
      [ "posx" .= px,
        "posy" .= py,
        "sizex" .= sx,
        "sizey" .= sy,
        "hidden" .= h,
        "border" .= b,
        "content" .= toJSON c
      ]