Config.hs

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

module Config where

{-
    Config.hs - configuration
    Copyright (C) 2023, Martin Gius

    This library is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This library is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this library.  If not, see <http://www.gnu.org/licenses/>.
-}

import Brick.BChan (writeBChan)
import Brick.Types (EventM)
import Conferer (fetch, mkConfig')
import Conferer.Config ((/.))
import Conferer.FromConfig (DefaultConfig (..))
import qualified Conferer.FromConfig as Conf
import qualified Conferer.Source.CLIArgs as Cli
import qualified Conferer.Source.Env as Env
import qualified Conferer.Source.Yaml as Yaml
import Control.Concurrent (forkIO)
import Control.Monad (unless)
import Control.Monad.RWS
import qualified Data.ByteString.Lazy.UTF8 as BL
import Data.Functor (void)
import Data.Maybe (fromMaybe)
import Data.Ratio ((%))
import qualified Data.Text as T
import Data.Yaml (ToJSON (..), encodeFile, object, (.=))
import Editor.Core (OutputType (..))
import Graphics.UI.TinyFileDialogs (selectFolderDialog)
import Keymap
import System.Directory.OsPath
import System.File.OsPath as F
import System.OsPath
import UI.Core (AppEvent (..), AppState (..), Name)
import Zwirn.Doux.Types (defaultDouxClockConfig)
import qualified Zwirn.Doux.Types as Stream
import Zwirn.Language (StreamType (Doux))
import Zwirn.Language.Compiler (CIError (..), Environment (..), compilerInterpreterBoot, runCI)
import qualified Zwirn.Language.Compiler as Compiler
import Prelude hiding (log)

data StreamConfig = StreamConfig
  { streamConfigSamples :: Maybe FilePath,
    streamConfigInput :: Maybe String,
    streamConfigOutput :: Maybe String,
    streamConfigHost :: Maybe String,
    streamConfigBufferSize :: Int,
    streamConfigChannels :: Int,
    streamConfigBlockSize :: Int,
    streamConfigMaxVoices :: Int
  }
  deriving (Show)

data CiConfig = CiConfig
  { ciConfigBootPath :: FilePath,
    ciConfigOverwriteBuiltin :: Bool,
    ciConfigDynamicTypes :: Bool,
    ciConfigPrecision :: Int
  }
  deriving (Show)

data FullConfig = FullConfig
  { fullConfigCi :: CiConfig,
    fullConfigStream :: StreamConfig
  }
  deriving (Show)

instance DefaultConfig CiConfig where
  configDef = CiConfig "" False False 288

instance DefaultConfig StreamConfig where
  configDef = StreamConfig Nothing Nothing Nothing Nothing 256 2 32 128

instance DefaultConfig FullConfig where
  configDef = FullConfig configDef configDef

instance Conf.FromConfig StreamConfig where
  fromConfig key configSource = do
    path <- Conf.fetchFromConfig (key /. "samples") configSource
    input <- Conf.fetchFromConfig (key /. "input") configSource
    output <- Conf.fetchFromConfig (key /. "output") configSource
    host <- Conf.fetchFromConfig (key /. "host") configSource
    bs <- Conf.fetchFromConfig (key /. "buffersize") configSource
    cs <- Conf.fetchFromConfig (key /. "channels") configSource
    bl <- Conf.fetchFromConfig (key /. "blocksize") configSource
    mx <- Conf.fetchFromConfig (key /. "maxvoices") configSource
    return $ StreamConfig path input output host (fromMaybe 256 bs) (fromMaybe 2 cs) (fromMaybe 32 bl) (fromMaybe 128 mx)

instance Conf.FromConfig CiConfig where
  fromConfig key configSource = do
    path <- Conf.fetchFromConfig (key /. "bootpath") configSource
    bp <- Conf.fetchFromConfig (key /. "overwritebuiltin") configSource
    dt <- Conf.fetchFromConfig (key /. "dynamictypes") configSource
    prec <- Conf.fetchFromConfig (key /. "precision") configSource
    return $ CiConfig (fromMaybe "" path) (fromMaybe False bp) (fromMaybe False dt) (fromMaybe 288 prec)

instance Conf.FromConfig FullConfig where
  fromConfig key configSource = do
    ci <- Conf.fetchFromConfig (key /. "ci") configSource
    str <- Conf.fetchFromConfig (key /. "stream") configSource
    return $ FullConfig ci (fromMaybe configDef str)

instance ToJSON CiConfig where
  toJSON (CiConfig p o d prec) =
    object
      [ "bootpath" .= p,
        "overwritebuiltin" .= o,
        "dynamictypes" .= d,
        "precision" .= prec
      ]

instance ToJSON StreamConfig where
  toJSON (StreamConfig sam inp out host buf chan block maxv) =
    object
      [ "samples" .= sam,
        "host" .= host,
        "input" .= inp,
        "output" .= out,
        "buffersize" .= buf,
        "channels" .= chan,
        "blocksize" .= block,
        "maxvoices" .= maxv
      ]

instance ToJSON FullConfig where
  toJSON (FullConfig ci str) =
    object
      [ "ci" .= toJSON ci,
        "stream" .= toJSON str
      ]

getConfigPath :: IO OsPath
getConfigPath = do
  appname <- encodeUtf "zwirnmill"
  configname <- encodeUtf "config.yaml"
  configDirPath <- getXdgDirectory XdgConfig appname
  let path = configDirPath </> configname
  createDirectoryIfMissing True configDirPath
  return path

getKeymapPath :: IO OsPath
getKeymapPath = do
  appname <- encodeUtf "zwirnmill"
  configname <- encodeUtf "keymap.yaml"
  configDirPath <- getXdgDirectory XdgConfig appname
  return $ configDirPath </> configname

getConfig :: IO (FullConfig, CustomKeymap)
getConfig = do
  path <- getConfigPath
  kmpath <- getKeymapPath
  exists <- doesFileExist path
  existskm <- doesFileExist kmpath
  unless exists encodeDefault
  unless existskm (encodeKeymap configDef)
  decoded <- decodeUtf path
  decodedkm <- decodeUtf kmpath
  keymapConf <- mkConfig' [] [Yaml.fromFilePath decodedkm]
  conf <-
    mkConfig'
      []
      [ Cli.fromConfig,
        Env.fromConfig "zwirnmill",
        Yaml.fromFilePath decoded
      ]
  full <- fetch conf
  keymap <- fetch keymapConf
  return (full, keymap)

toStream :: Rational -> StreamConfig -> Stream.StreamConfig
toStream prec (StreamConfig a b c d e f g h) = Stream.StreamConfig prec a b c d e f g h defaultDouxClockConfig

toCiConfig :: CiConfig -> Compiler.CiConfig
toCiConfig (CiConfig _ x y z) = Compiler.CiConfig x y (1 % fromIntegral z) Doux

configPath :: IO String
configPath = do
  path <- getConfigPath
  exists <- doesFileExist path
  decoded <- decodeUtf path
  if exists then return decoded else return "Config file not found!"

resetConfig :: IO String
resetConfig = encodeDefault >> return "Restored default config."

encodeDefault :: IO ()
encodeDefault = encodeConfig configDef

encodeConfig :: FullConfig -> IO ()
encodeConfig conf = do
  path <- getConfigPath
  strp <- decodeFS path
  encodeFile strp $ toJSON conf

encodeKeymap :: CustomKeymap -> IO ()
encodeKeymap conf = do
  path <- getKeymapPath
  strp <- decodeFS path
  encodeFile strp $ toJSON conf

getFile :: String -> IO String
getFile p = do
  path <- encodeUtf p
  f <- F.readFile path
  return $ BL.toString f

setBootPath :: EventM Name AppState ()
setBootPath = do
  mpath <- liftIO $ openFolder "choose a boot folder"
  case mpath of
    Just path -> do
      env <- gets asEnvironment
      chan <- gets asChan
      menv <- liftIO $ checkBoot (\st -> void $ forkIO $ writeBChan chan (UpdateOutput (OutputInfo, st))) path env
      case menv of
        Just env' -> do
          (FullConfig ci str, _) <- liftIO getConfig
          modify $ \as -> as {asEnvironment = env'}
          liftIO $ encodeConfig $ FullConfig ci {ciConfigBootPath = path} str
        Nothing -> return ()
    Nothing -> return ()

setSamplePath :: EventM Name AppState ()
setSamplePath = do
  mpath <- liftIO $ openFolder "choose a sample folder"
  case mpath of
    Just path -> do
      chan <- gets asChan
      (FullConfig ci str, _) <- liftIO getConfig
      liftIO $ encodeConfig $ FullConfig ci str {streamConfigSamples = Just path}
      liftIO $ void $ forkIO $ writeBChan chan (UpdateOutput (OutputInfo, "Successfully set sample folder path. \nRestart for it to take effect."))
    Nothing -> return ()

openFolder :: T.Text -> IO (Maybe FilePath)
openFolder msg = fmap T.unpack <$> selectFolderDialog msg ""

checkBoot :: (String -> IO ()) -> FilePath -> Environment -> IO (Maybe Environment)
checkBoot log "" _ = log "Starting without Bootfile." >> return Nothing
checkBoot log path env = do
  ospath <- encodeUtf path
  isfile <- doesFileExist ospath
  ps <-
    if isfile
      then return $ decodeUtf ospath
      else do
        isfolder <- doesDirectoryExist ospath
        if isfolder
          then do
            pss <- listDirectory ospath
            fs <- mapM decodeUtf pss
            return $ map (\f -> path ++ "/" ++ f) fs
          else return []
  res <- runCI env (compilerInterpreterBoot $ map T.pack ps)
  case res of
    Left (CIError err _) -> log ("Error in Bootfile: " ++ show err) >> return Nothing
    Right newEnv ->
      if ps /= []
        then log ("Successfully loaded Bootfiles from " ++ path) >> return (Just newEnv)
        else log ("No Bootfiles found at " ++ path) >> return Nothing