Preferences.hs

{-# LANGUAGE CPP #-}

-- | Description : Controls the Preferences dialog and setting app preferences
-- Copyright     : (c) Dennis Gosnell, 2023
-- License       : BSD3
-- Stability     : experimental
-- Portability   : POSIX
--
-- This module controls the Preferences dialog, which lets you set Termonad
-- preferences at run-time.
--
-- It also exports helpful functions from "Termonad.Preferences.File".

module Termonad.Preferences
  ( module Termonad.Preferences.File
  , showPreferencesDialog
  ) where

import Termonad.Prelude

import Control.Lens ((^.), over, set, view)
import qualified Data.List as List
import qualified Data.Text as Text
import GI.Gtk
  ( CheckButton(CheckButton)
  , ComboBoxText(ComboBoxText)
  , Dialog(Dialog)
  , Entry(Entry)
  , FontButton(FontButton)
  , Label(Label)
  , PolicyType(PolicyTypeAutomatic)
  , ResponseType(ResponseTypeAccept)
  , SpinButton(SpinButton)
  , adjustmentNew
  , applicationGetActiveWindow
  , applicationWindowSetShowMenubar
  , builderNewFromString
  , comboBoxGetActiveId
  , comboBoxSetActiveId
  , comboBoxTextAppend
  , dialogRun
  , entryBufferGetText
  , entryBufferSetText
  , fontChooserSetFontDesc
  , fontChooserGetFontDesc
  , getEntryBuffer
  , scrolledWindowSetPolicy
  , spinButtonGetValueAsInt
  , spinButtonSetAdjustment
  , spinButtonSetValue
  , toggleButtonGetActive
  , toggleButtonSetActive
  , widgetDestroy
  , widgetSetVisible
  , windowSetTransientFor
  )
import GI.Vte
  ( CursorBlinkMode(..)
  , terminalSetBoldIsBright
  , terminalSetCursorBlinkMode
  , terminalSetFont
  , terminalSetScrollbackLines
  , terminalSetWordCharExceptions
  , terminalSetAllowBold
  )
import System.Environment (getExecutablePath)
import System.FilePath (takeFileName)
import Termonad.Gtk (objFromBuildUnsafe, terminalSetEnableSixelIfExists)
import Termonad.Lenses
  ( lensBoldIsBright
  , lensEnableSixel
  , lensAllowBold
  , lensConfirmExit
  , lensCursorBlinkMode
  , lensFontConfig
  , lensOptions
  , lensShowMenu
  , lensShowScrollbar
  , lensShowTabBar
  , lensScrollbackLen
  , lensTMNotebookTabTermContainer
  , lensTMNotebookTabTerm
  , lensTMStateApp
  , lensTMStateConfig
  , lensTMStateFontDesc
  , lensTerm
  , lensWordCharExceptions
  )
import Termonad.Preferences.File (saveToPreferencesFile, tmConfigFromPreferencesFile)
import Termonad.Term
  ( setShowTabs
  , showScrollbarToPolicy
  )
import Termonad.Types
  ( ConfigOptions(..)
  , ShowScrollbar(..)
  , ShowTabBar(..)
  , TMNotebookTab
  , TMState
  , TMWindowId
  , fontConfigFromFontDescription
  , getTMWindowFromTMState'
  , tmNotebook
  , tmNotebookTabs
  , tmStateWindows
  , tmWindowAppWin
  , tmWindowNotebook
  )
import Termonad.XML (preferencesText)
import Termonad.IdMap (keysIdMap)

-- | Fill a combo box with ids and labels
--
-- The ids are stored in the combobox as 'Text', so their type should be an
-- instance of the 'Show' type class.
comboBoxFill :: forall a. Show a => ComboBoxText -> [(a, Text)] -> IO ()
comboBoxFill comboBox = mapM_ go
  where
    go :: (a, Text) -> IO ()
    go (value, textId) =
      comboBoxTextAppend comboBox (Just $ tshow value) textId

-- | Set the current active item in a combobox given an input id.
comboBoxSetActive :: Show a => ComboBoxText -> a -> IO ()
comboBoxSetActive cb item = void $ comboBoxSetActiveId cb (Just $ tshow item)

-- | Get the current active item in a combobox
--
-- The list of values to be searched in the combobox must be given as a
-- parameter. These values are converted to Text then compared to the current
-- id.
comboBoxGetActive
  :: forall a. (Show a, Enum a) => ComboBoxText -> [a] -> IO (Maybe a)
comboBoxGetActive cb values = findEnumFromMaybeId <$> comboBoxGetActiveId cb
  where
    findEnumFromMaybeId :: Maybe Text -> Maybe a
    findEnumFromMaybeId maybeId = maybeId >>= findEnumFromId

    findEnumFromId :: Text -> Maybe a
    findEnumFromId label = List.find (\x -> tshow x == label) values

applyNewPreferencesToTab :: TMState -> TMNotebookTab -> IO ()
applyNewPreferencesToTab mvarTMState tab = do
  tmState <- readMVar mvarTMState
  let fontDesc = tmState ^. lensTMStateFontDesc
      term = tab ^. lensTMNotebookTabTerm . lensTerm
      scrolledWin = tab ^. lensTMNotebookTabTermContainer
      options = tmState ^. lensTMStateConfig . lensOptions
  terminalSetFont term (Just fontDesc)
  terminalSetCursorBlinkMode term (cursorBlinkMode options)
  terminalSetWordCharExceptions term (wordCharExceptions options)
  terminalSetScrollbackLines term (fromIntegral (scrollbackLen options))
  terminalSetBoldIsBright term (boldIsBright options)
  terminalSetEnableSixelIfExists term (enableSixel options)
  terminalSetAllowBold term (allowBold options)

  let vScrollbarPolicy = showScrollbarToPolicy (options ^. lensShowScrollbar)
  scrolledWindowSetPolicy scrolledWin PolicyTypeAutomatic vScrollbarPolicy

applyNewPreferencesToWindow :: TMState -> TMWindowId -> IO ()
applyNewPreferencesToWindow mvarTMState tmWinId = do
  tmState <- readMVar mvarTMState
  tmWin <- getTMWindowFromTMState' tmState tmWinId
  let appWin = tmWindowAppWin tmWin
      config = tmState ^. lensTMStateConfig
      notebook = tmWindowNotebook tmWin
      tabFocusList = tmNotebookTabs notebook
      showMenu = config  ^. lensOptions . lensShowMenu
  applicationWindowSetShowMenubar appWin showMenu
  setShowTabs config (tmNotebook notebook)
  -- Sets the remaining preferences to each tab
  foldMap (applyNewPreferencesToTab mvarTMState) tabFocusList

-- | Takes a 'TMState', and looks at the 'TMConfig' within.
-- Take all the configuration options from the 'TMConfig' and apply them to the
-- current 'Application', 'Window's, and 'Term's.
--
-- This function is meant to be used after a big update to the 'TMConfig' within a
-- 'TMState'.
applyNewPreferences :: TMState -> IO ()
applyNewPreferences mvarTMState = do
  tmState <- readMVar mvarTMState
  let windows = tmStateWindows tmState
  foldMap (applyNewPreferencesToWindow mvarTMState) (keysIdMap windows)

-- | Show the preferences dialog.
--
-- When the user clicks on the Ok button, it copies the new settings to TMState.
-- Then apply them to the current terminals.
showPreferencesDialog :: TMState -> IO ()
showPreferencesDialog mvarTMState = do
  -- Get app out of mvar
  tmState <- readMVar mvarTMState
  let app = tmState ^. lensTMStateApp

  -- Create the preference dialog and get some widgets
  preferencesBuilder <-
    builderNewFromString preferencesText $ fromIntegral (Text.length preferencesText)
  preferencesDialog <-
    objFromBuildUnsafe preferencesBuilder "preferences" Dialog
  confirmExitCheckButton <-
    objFromBuildUnsafe preferencesBuilder "confirmExit" CheckButton
  showMenuCheckButton <-
    objFromBuildUnsafe preferencesBuilder "showMenu" CheckButton
  boldIsBrightCheckButton <-
    objFromBuildUnsafe preferencesBuilder "boldIsBright" CheckButton
  enableSixelCheckButton <-
    objFromBuildUnsafe preferencesBuilder "enableSixel" CheckButton
  allowBoldCheckButton <-
    objFromBuildUnsafe preferencesBuilder "allowBold" CheckButton
  wordCharExceptionsEntryBuffer <-
    objFromBuildUnsafe preferencesBuilder "wordCharExceptions" Entry >>=
      getEntryBuffer
  fontButton <- objFromBuildUnsafe preferencesBuilder "font" FontButton
  showScrollbarComboBoxText <-
    objFromBuildUnsafe preferencesBuilder "showScrollbar" ComboBoxText
  comboBoxFill
    showScrollbarComboBoxText
    [ (ShowScrollbarNever, "Never")
    , (ShowScrollbarAlways, "Always")
    , (ShowScrollbarIfNeeded, "If needed")
    ]
  showTabBarComboBoxText <-
    objFromBuildUnsafe preferencesBuilder "showTabBar" ComboBoxText
  comboBoxFill
    showTabBarComboBoxText
    [ (ShowTabBarNever, "Never")
    , (ShowTabBarAlways, "Always")
    , (ShowTabBarIfNeeded, "If needed")
    ]
  cursorBlinkModeComboBoxText <-
    objFromBuildUnsafe preferencesBuilder "cursorBlinkMode" ComboBoxText
  comboBoxFill
    cursorBlinkModeComboBoxText
    [ (CursorBlinkModeSystem, "System")
    , (CursorBlinkModeOn, "On")
    , (CursorBlinkModeOff, "Off")
    ]
  scrollbackLenSpinButton <-
    objFromBuildUnsafe preferencesBuilder "scrollbackLen" SpinButton
  adjustmentNew 0 0 (fromIntegral (maxBound :: Int)) 1 10 0 >>=
    spinButtonSetAdjustment scrollbackLenSpinButton
  warningLabel <- objFromBuildUnsafe preferencesBuilder "warning" Label

  -- We show the warning label only if the user has launched termonad with a
  -- termonad.hs file
  executablePath <- getExecutablePath
  let hasTermonadHs = takeFileName executablePath == "termonad-linux-x86_64"
  widgetSetVisible warningLabel hasTermonadHs

  -- Make the dialog modal
  maybeWin <- applicationGetActiveWindow app
  windowSetTransientFor preferencesDialog maybeWin

  -- Init with current state
  fontChooserSetFontDesc fontButton (tmState ^. lensTMStateFontDesc)
  let options = tmState ^. lensTMStateConfig . lensOptions
  comboBoxSetActive showScrollbarComboBoxText $ showScrollbar options
  comboBoxSetActive showTabBarComboBoxText $ showTabBar options
  comboBoxSetActive cursorBlinkModeComboBoxText $ cursorBlinkMode options
  spinButtonSetValue scrollbackLenSpinButton (fromIntegral $ scrollbackLen options)
  toggleButtonSetActive confirmExitCheckButton $ confirmExit options
  toggleButtonSetActive showMenuCheckButton $ showMenu options
  toggleButtonSetActive boldIsBrightCheckButton $ boldIsBright options
  toggleButtonSetActive enableSixelCheckButton $ enableSixel options
  toggleButtonSetActive allowBoldCheckButton $ allowBold options
  entryBufferSetText wordCharExceptionsEntryBuffer (wordCharExceptions options) (-1)

  -- Run dialog then close
  res <- dialogRun preferencesDialog

  -- When closing the dialog get the new settings
  when (toEnum (fromIntegral res) == ResponseTypeAccept) $ do
    maybeFontDesc <- fontChooserGetFontDesc fontButton
    maybeFontConfig <-
      join <$> mapM fontConfigFromFontDescription maybeFontDesc
    maybeShowScrollbar <-
      comboBoxGetActive showScrollbarComboBoxText [ShowScrollbarNever ..]
    maybeShowTabBar <-
      comboBoxGetActive showTabBarComboBoxText [ShowTabBarNever ..]
    maybeCursorBlinkMode <-
      comboBoxGetActive cursorBlinkModeComboBoxText [CursorBlinkModeSystem ..]
    scrollbackLenVal <-
      fromIntegral <$> spinButtonGetValueAsInt scrollbackLenSpinButton
    confirmExitVal <- toggleButtonGetActive confirmExitCheckButton
    showMenuVal <- toggleButtonGetActive showMenuCheckButton
    boldIsBrightVal <- toggleButtonGetActive boldIsBrightCheckButton
    enableSixelVal <- toggleButtonGetActive enableSixelCheckButton
    allowBoldVal <- toggleButtonGetActive allowBoldCheckButton
    wordCharExceptionsVal <- entryBufferGetText wordCharExceptionsEntryBuffer

    -- Apply the changes to mvarTMState
    modifyMVar_ mvarTMState $ pure
      . over lensTMStateFontDesc (`fromMaybe` maybeFontDesc)
      . over (lensTMStateConfig . lensOptions)
        ( set lensConfirmExit confirmExitVal
        . set lensShowMenu showMenuVal
        . set lensBoldIsBright boldIsBrightVal
        . set lensEnableSixel enableSixelVal
        . set lensAllowBold allowBoldVal
        . set lensWordCharExceptions wordCharExceptionsVal
        . over lensFontConfig (`fromMaybe` maybeFontConfig)
        . set lensScrollbackLen scrollbackLenVal
        . over lensShowScrollbar (`fromMaybe` maybeShowScrollbar)
        . over lensShowTabBar (`fromMaybe` maybeShowTabBar)
        . over lensCursorBlinkMode (`fromMaybe` maybeCursorBlinkMode)
        )

    -- Save the changes to the preferences files
    withMVar mvarTMState $ saveToPreferencesFile . view lensTMStateConfig

    -- Update the app with new settings
    applyNewPreferences mvarTMState

  widgetDestroy preferencesDialog