termonad-4.0.1.2: src/Termonad/App.hs
module Termonad.App where
import Termonad.Prelude
import Config.Dyre (defaultParams, projectName, realMain, showError, wrapMain)
import Control.Lens ((.~), (^.), (^..), over, set, view)
import Control.Monad.Fail (fail)
import Data.FocusList (focusList, moveFromToFL, updateFocusFL)
import Data.Sequence (findIndexR)
import GI.Gdk (castTo, managedForeignPtr, screenGetDefault)
import GI.Gio
( ApplicationFlags(ApplicationFlagsFlagsNone)
, MenuModel(MenuModel)
, actionMapAddAction
, applicationQuit
, applicationRun
, onApplicationActivate
, onApplicationStartup
, onSimpleActionActivate
, simpleActionNew
)
import GI.Gtk
( Application
, ApplicationWindow(ApplicationWindow)
, Box(Box)
, CheckButton(CheckButton)
, ComboBoxText(ComboBoxText)
, Dialog(Dialog)
, Entry(Entry)
, FontButton(FontButton)
, Label(Label)
, PolicyType(PolicyTypeAutomatic)
, PositionType(PositionTypeRight)
, ResponseType(ResponseTypeAccept, ResponseTypeNo, ResponseTypeYes)
, ScrolledWindow(ScrolledWindow)
, SpinButton(SpinButton)
, pattern STYLE_PROVIDER_PRIORITY_APPLICATION
, aboutDialogNew
, adjustmentNew
, applicationAddWindow
, applicationGetActiveWindow
, applicationSetAccelsForAction
, applicationSetMenubar
, applicationWindowSetShowMenubar
, boxPackStart
, builderNewFromString
, builderSetApplication
, comboBoxGetActiveId
, comboBoxSetActiveId
, comboBoxTextAppend
, containerAdd
, cssProviderLoadFromData
, cssProviderNew
, dialogAddButton
, dialogGetContentArea
, dialogNew
, dialogResponse
, dialogRun
, entryBufferGetText
, entryBufferSetText
, entryGetText
, entryNew
, fontChooserSetFontDesc
, fontChooserGetFontDesc
, getEntryBuffer
, gridAttachNextTo
, gridNew
, labelNew
, notebookGetNPages
, notebookNew
, notebookSetShowBorder
, onEntryActivate
, onNotebookPageRemoved
, onNotebookPageReordered
, onNotebookSwitchPage
, onWidgetDeleteEvent
, scrolledWindowSetPolicy
, setWidgetMargin
, spinButtonGetValueAsInt
, spinButtonSetAdjustment
, spinButtonSetValue
, styleContextAddProviderForScreen
, toggleButtonGetActive
, toggleButtonSetActive
, widgetDestroy
, widgetGrabFocus
, widgetSetCanFocus
, widgetSetVisible
, widgetShow
, widgetShowAll
, windowPresent
, windowSetDefaultIconFromFile
, windowSetTitle
, windowSetTransientFor
)
import qualified GI.Gtk as Gtk
import GI.Pango
( FontDescription
, pattern SCALE
, fontDescriptionGetFamily
, fontDescriptionGetSize
, fontDescriptionGetSizeIsAbsolute
, fontDescriptionNew
, fontDescriptionSetFamily
, fontDescriptionSetSize
, fontDescriptionSetAbsoluteSize
)
import GI.Vte
( CursorBlinkMode(..)
, catchRegexError
, regexNewForSearch
, terminalCopyClipboard
, terminalPasteClipboard
, terminalSearchFindNext
, terminalSearchFindPrevious
, terminalSearchSetRegex
, terminalSearchSetWrapAround
, terminalSetCursorBlinkMode
, terminalSetFont
, terminalSetScrollbackLines
, terminalSetWordCharExceptions
)
import System.Environment (getExecutablePath)
import System.FilePath (takeFileName)
import Paths_termonad (getDataFileName)
import Termonad.Gtk (appNew, objFromBuildUnsafe)
import Termonad.Keys (handleKeyPress)
import Termonad.Lenses
( lensConfirmExit
, lensCursorBlinkMode
, lensFontConfig
, lensOptions
, lensShowMenu
, lensShowScrollbar
, lensShowTabBar
, lensScrollbackLen
, lensTMNotebook
, lensTMNotebookTabTermContainer
, lensTMNotebookTabs
, lensTMNotebookTabTerm
, lensTMStateApp
, lensTMStateAppWin
, lensTMStateConfig
, lensTMStateFontDesc
, lensTMStateNotebook
, lensTerm
, lensWordCharExceptions
)
import Termonad.PreferencesFile (saveToPreferencesFile)
import Termonad.Term
( createTerm
, relabelTabs
, termExitFocused
, setShowTabs
, showScrollbarToPolicy
)
import Termonad.Types
( FontConfig(..)
, FontSize(FontSizePoints, FontSizeUnits)
, ShowScrollbar(..)
, ShowTabBar(..)
, TMConfig
, TMNotebookTab
, TMState
, TMState'(TMState)
, getFocusedTermFromState
, modFontSize
, newEmptyTMState
, tmNotebookTabTermContainer
, tmNotebookTabs
, tmStateApp
, tmStateNotebook
)
import Termonad.XML (interfaceText, menuText, preferencesText)
setupScreenStyle :: IO ()
setupScreenStyle = do
maybeScreen <- screenGetDefault
case maybeScreen of
Nothing -> pure ()
Just screen -> do
cssProvider <- cssProviderNew
let (textLines :: [Text]) =
[
"scrollbar {"
-- , " -GtkRange-slider-width: 200px;"
-- , " -GtkRange-stepper-size: 200px;"
-- , " border-width: 200px;"
, " background-color: #aaaaaa;"
-- , " color: #ff0000;"
-- , " min-width: 4px;"
, "}"
-- , "scrollbar trough {"
-- , " -GtkRange-slider-width: 200px;"
-- , " -GtkRange-stepper-size: 200px;"
-- , " border-width: 200px;"
-- , " background-color: #00ff00;"
-- , " color: #00ff00;"
-- , " min-width: 50px;"
-- , "}"
-- , "scrollbar slider {"
-- , " -GtkRange-slider-width: 200px;"
-- , " -GtkRange-stepper-size: 200px;"
-- , " border-width: 200px;"
-- , " background-color: #0000ff;"
-- , " color: #0000ff;"
-- , " min-width: 50px;"
-- , "}"
, "tab {"
, " background-color: transparent;"
, "}"
]
let styleData = encodeUtf8 (unlines textLines :: Text)
cssProviderLoadFromData cssProvider styleData
styleContextAddProviderForScreen
screen
cssProvider
(fromIntegral STYLE_PROVIDER_PRIORITY_APPLICATION)
createFontDescFromConfig :: TMConfig -> IO FontDescription
createFontDescFromConfig tmConfig = do
let fontConf = tmConfig ^. lensOptions . lensFontConfig
createFontDesc (fontSize fontConf) (fontFamily fontConf)
createFontDesc :: FontSize -> Text -> IO FontDescription
createFontDesc fontSz fontFam = do
fontDesc <- fontDescriptionNew
fontDescriptionSetFamily fontDesc fontFam
setFontDescSize fontDesc fontSz
pure fontDesc
setFontDescSize :: FontDescription -> FontSize -> IO ()
setFontDescSize fontDesc (FontSizePoints points) =
fontDescriptionSetSize fontDesc $ fromIntegral (points * fromIntegral SCALE)
setFontDescSize fontDesc (FontSizeUnits units) =
fontDescriptionSetAbsoluteSize fontDesc $ units * fromIntegral SCALE
adjustFontDescSize :: (FontSize -> FontSize) -> FontDescription -> IO ()
adjustFontDescSize f fontDesc = do
currFontSz <- fontSizeFromFontDescription fontDesc
let newFontSz = f currFontSz
setFontDescSize fontDesc newFontSz
modifyFontSizeForAllTerms :: (FontSize -> FontSize) -> TMState -> IO ()
modifyFontSizeForAllTerms modFontSizeFunc mvarTMState = do
tmState <- readMVar mvarTMState
let fontDesc = tmState ^. lensTMStateFontDesc
adjustFontDescSize modFontSizeFunc fontDesc
let terms =
tmState ^..
lensTMStateNotebook .
lensTMNotebookTabs .
traverse .
lensTMNotebookTabTerm .
lensTerm
foldMap (\vteTerm -> terminalSetFont vteTerm (Just fontDesc)) terms
fontSizeFromFontDescription :: FontDescription -> IO FontSize
fontSizeFromFontDescription fontDesc = do
currSize <- fontDescriptionGetSize fontDesc
currAbsolute <- fontDescriptionGetSizeIsAbsolute fontDesc
return $ if currAbsolute
then FontSizeUnits $ fromIntegral currSize / fromIntegral SCALE
else
let fontRatio :: Double = fromIntegral currSize / fromIntegral SCALE
in FontSizePoints $ round fontRatio
fontConfigFromFontDescription :: FontDescription -> IO (Maybe FontConfig)
fontConfigFromFontDescription fontDescription = do
fontSize <- fontSizeFromFontDescription fontDescription
maybeFontFamily <- fontDescriptionGetFamily fontDescription
return $ (`FontConfig` fontSize) <$> maybeFontFamily
compareScrolledWinAndTab :: ScrolledWindow -> TMNotebookTab -> Bool
compareScrolledWinAndTab scrollWin flTab =
let ScrolledWindow managedPtrFLTab = tmNotebookTabTermContainer flTab
foreignPtrFLTab = managedForeignPtr managedPtrFLTab
ScrolledWindow managedPtrScrollWin = scrollWin
foreignPtrScrollWin = managedForeignPtr managedPtrScrollWin
in foreignPtrFLTab == foreignPtrScrollWin
updateFLTabPos :: TMState -> Int -> Int -> IO ()
updateFLTabPos mvarTMState oldPos newPos =
modifyMVar_ mvarTMState $ \tmState -> do
let tabs = tmState ^. lensTMStateNotebook . lensTMNotebookTabs
maybeNewTabs = moveFromToFL oldPos newPos tabs
case maybeNewTabs of
Nothing -> do
putStrLn $
"in updateFLTabPos, Strange error: couldn't move tabs.\n" <>
"old pos: " <> tshow oldPos <> "\n" <>
"new pos: " <> tshow newPos <> "\n" <>
"tabs: " <> tshow tabs <> "\n" <>
"maybeNewTabs: " <> tshow maybeNewTabs <> "\n" <>
"tmState: " <> tshow tmState
pure tmState
Just newTabs ->
pure $
tmState &
lensTMStateNotebook . lensTMNotebookTabs .~ newTabs
-- | Try to figure out whether Termonad should exit. This also used to figure
-- out if Termonad should close a given terminal.
--
-- This reads the 'confirmExit' setting from 'ConfigOptions' to check whether
-- the user wants to be notified when either Termonad or a given terminal is
-- about to be closed.
--
-- If 'confirmExit' is 'True', then a dialog is presented to the user asking
-- them if they really want to exit or close the terminal. Their response is
-- sent back as a 'ResponseType'.
--
-- If 'confirmExit' is 'False', then this function always returns
-- 'ResponseTypeYes'.
{- HLINT ignore "Reduce duplication" -}
askShouldExit :: TMState -> IO ResponseType
askShouldExit mvarTMState = do
tmState <- readMVar mvarTMState
let confirm = tmState ^. lensTMStateConfig . lensOptions . lensConfirmExit
if confirm
then confirmationDialogForExit tmState
else pure ResponseTypeYes
where
-- Show the user a dialog telling them there are still terminals running and
-- asking if they really want to exit.
--
-- Return the user's resposne as a 'ResponseType'.
confirmationDialogForExit :: TMState' -> IO ResponseType
confirmationDialogForExit tmState = do
let app = tmState ^. lensTMStateApp
win <- applicationGetActiveWindow app
dialog <- dialogNew
box <- dialogGetContentArea dialog
label <-
labelNew $
Just
"There are still terminals running. Are you sure you want to exit?"
containerAdd box label
widgetShow label
setWidgetMargin label 10
void $
dialogAddButton
dialog
"No, do NOT exit"
(fromIntegral (fromEnum ResponseTypeNo))
void $
dialogAddButton
dialog
"Yes, exit"
(fromIntegral (fromEnum ResponseTypeYes))
windowSetTransientFor dialog win
res <- dialogRun dialog
widgetDestroy dialog
pure $ toEnum (fromIntegral res)
-- | Force Termonad to exit without asking the user whether or not to do so.
forceQuit :: TMState -> IO ()
forceQuit mvarTMState = do
tmState <- readMVar mvarTMState
let app = tmState ^. lensTMStateApp
applicationQuit app
setupTermonad :: TMConfig -> Application -> ApplicationWindow -> Gtk.Builder -> IO ()
setupTermonad tmConfig app win builder = do
termonadIconPath <- getDataFileName "img/termonad-lambda.png"
windowSetDefaultIconFromFile termonadIconPath
setupScreenStyle
box <- objFromBuildUnsafe builder "content_box" Box
fontDesc <- createFontDescFromConfig tmConfig
note <- notebookNew
widgetSetCanFocus note False
-- If this is not set to False, then there will be a one pixel white border
-- shown around the notebook.
notebookSetShowBorder note False
boxPackStart box note True True 0
mvarTMState <- newEmptyTMState tmConfig app win note fontDesc
terminal <- createTerm handleKeyPress mvarTMState
void $ onNotebookPageRemoved note $ \_ _ -> do
pages <- notebookGetNPages note
if pages == 0
then forceQuit mvarTMState
else setShowTabs tmConfig note
void $ onNotebookSwitchPage note $ \_ pageNum -> do
modifyMVar_ mvarTMState $ \tmState -> do
let notebook = tmStateNotebook tmState
tabs = tmNotebookTabs notebook
maybeNewTabs = updateFocusFL (fromIntegral pageNum) tabs
case maybeNewTabs of
Nothing -> pure tmState
Just (tab, newTabs) -> do
widgetGrabFocus $ tab ^. lensTMNotebookTabTerm . lensTerm
pure $
tmState &
lensTMStateNotebook . lensTMNotebookTabs .~ newTabs
void $ onNotebookPageReordered note $ \childWidg pageNum -> do
maybeScrollWin <- castTo ScrolledWindow childWidg
case maybeScrollWin of
Nothing ->
fail $
"In setupTermonad, in callback for onNotebookPageReordered, " <>
"child widget is not a ScrolledWindow.\n" <>
"Don't know how to continue.\n"
Just scrollWin -> do
TMState{tmStateNotebook} <- readMVar mvarTMState
let fl = tmStateNotebook ^. lensTMNotebookTabs
let maybeOldPosition =
findIndexR (compareScrolledWinAndTab scrollWin) (focusList fl)
case maybeOldPosition of
Nothing ->
fail $
"In setupTermonad, in callback for onNotebookPageReordered, " <>
"the ScrolledWindow is not already in the FocusList.\n" <>
"Don't know how to continue.\n"
Just oldPos -> do
updateFLTabPos mvarTMState oldPos (fromIntegral pageNum)
relabelTabs mvarTMState
newTabAction <- simpleActionNew "newtab" Nothing
void $ onSimpleActionActivate newTabAction $ \_ -> void $ createTerm handleKeyPress mvarTMState
actionMapAddAction app newTabAction
applicationSetAccelsForAction app "app.newtab" ["<Shift><Ctrl>T"]
closeTabAction <- simpleActionNew "closetab" Nothing
void $ onSimpleActionActivate closeTabAction $ \_ ->
termExitFocused mvarTMState
actionMapAddAction app closeTabAction
applicationSetAccelsForAction app "app.closetab" ["<Shift><Ctrl>W"]
quitAction <- simpleActionNew "quit" Nothing
void $ onSimpleActionActivate quitAction $ \_ -> do
shouldExit <- askShouldExit mvarTMState
when (shouldExit == ResponseTypeYes) $ forceQuit mvarTMState
actionMapAddAction app quitAction
applicationSetAccelsForAction app "app.quit" ["<Shift><Ctrl>Q"]
copyAction <- simpleActionNew "copy" Nothing
void $ onSimpleActionActivate copyAction $ \_ -> do
maybeTerm <- getFocusedTermFromState mvarTMState
maybe (pure ()) terminalCopyClipboard maybeTerm
actionMapAddAction app copyAction
applicationSetAccelsForAction app "app.copy" ["<Shift><Ctrl>C"]
pasteAction <- simpleActionNew "paste" Nothing
void $ onSimpleActionActivate pasteAction $ \_ -> do
maybeTerm <- getFocusedTermFromState mvarTMState
maybe (pure ()) terminalPasteClipboard maybeTerm
actionMapAddAction app pasteAction
applicationSetAccelsForAction app "app.paste" ["<Shift><Ctrl>V"]
preferencesAction <- simpleActionNew "preferences" Nothing
void $ onSimpleActionActivate preferencesAction (const $ showPreferencesDialog mvarTMState)
actionMapAddAction app preferencesAction
enlargeFontAction <- simpleActionNew "enlargefont" Nothing
void $ onSimpleActionActivate enlargeFontAction $ \_ ->
modifyFontSizeForAllTerms (modFontSize 1) mvarTMState
actionMapAddAction app enlargeFontAction
applicationSetAccelsForAction app "app.enlargefont" ["<Ctrl>plus"]
reduceFontAction <- simpleActionNew "reducefont" Nothing
void $ onSimpleActionActivate reduceFontAction $ \_ ->
modifyFontSizeForAllTerms (modFontSize (-1)) mvarTMState
actionMapAddAction app reduceFontAction
applicationSetAccelsForAction app "app.reducefont" ["<Ctrl>minus"]
findAction <- simpleActionNew "find" Nothing
void $ onSimpleActionActivate findAction $ \_ -> doFind mvarTMState
actionMapAddAction app findAction
applicationSetAccelsForAction app "app.find" ["<Shift><Ctrl>F"]
findAboveAction <- simpleActionNew "findabove" Nothing
void $ onSimpleActionActivate findAboveAction $ \_ -> findAbove mvarTMState
actionMapAddAction app findAboveAction
applicationSetAccelsForAction app "app.findabove" ["<Shift><Ctrl>P"]
findBelowAction <- simpleActionNew "findbelow" Nothing
void $ onSimpleActionActivate findBelowAction $ \_ -> findBelow mvarTMState
actionMapAddAction app findBelowAction
applicationSetAccelsForAction app "app.findbelow" ["<Shift><Ctrl>I"]
aboutAction <- simpleActionNew "about" Nothing
void $ onSimpleActionActivate aboutAction $ \_ -> showAboutDialog app
actionMapAddAction app aboutAction
menuBuilder <- builderNewFromString menuText $ fromIntegral (length menuText)
menuModel <- objFromBuildUnsafe menuBuilder "menubar" MenuModel
applicationSetMenubar app (Just menuModel)
let showMenu = tmConfig ^. lensOptions . lensShowMenu
applicationWindowSetShowMenubar win showMenu
windowSetTitle win "Termonad"
-- This event will happen if the user requests that the top-level Termonad
-- window be closed through their window manager. It will also happen
-- normally when the user tries to close Termonad through normal methods,
-- like clicking "Quit" or closing the last open terminal.
--
-- If you return 'True' from this callback, then Termonad will not exit.
-- If you return 'False' from this callback, then Termonad will continue to
-- exit.
void $ onWidgetDeleteEvent win $ \_ -> do
shouldExit <- askShouldExit mvarTMState
pure $
case shouldExit of
ResponseTypeYes -> False
_ -> True
widgetShowAll win
widgetGrabFocus $ terminal ^. lensTerm
appActivate :: TMConfig -> Application -> IO ()
appActivate tmConfig app = do
uiBuilder <-
builderNewFromString interfaceText $ fromIntegral (length interfaceText)
builderSetApplication uiBuilder app
appWin <- objFromBuildUnsafe uiBuilder "appWin" ApplicationWindow
applicationAddWindow app appWin
setupTermonad tmConfig app appWin uiBuilder
windowPresent appWin
showAboutDialog :: Application -> IO ()
showAboutDialog app = do
win <- applicationGetActiveWindow app
aboutDialog <- aboutDialogNew
windowSetTransientFor aboutDialog win
void $ dialogRun aboutDialog
widgetDestroy aboutDialog
showFindDialog :: Application -> IO (Maybe Text)
showFindDialog app = do
win <- applicationGetActiveWindow app
dialog <- dialogNew
box <- dialogGetContentArea dialog
grid <- gridNew
searchForLabel <- labelNew (Just "Search for regex:")
containerAdd grid searchForLabel
widgetShow searchForLabel
setWidgetMargin searchForLabel 10
searchEntry <- entryNew
gridAttachNextTo grid searchEntry (Just searchForLabel) PositionTypeRight 1 1
widgetShow searchEntry
setWidgetMargin searchEntry 10
-- setWidgetMarginBottom searchEntry 20
void $
onEntryActivate searchEntry $
dialogResponse dialog (fromIntegral (fromEnum ResponseTypeYes))
void $
dialogAddButton
dialog
"Close"
(fromIntegral (fromEnum ResponseTypeNo))
void $
dialogAddButton
dialog
"Find"
(fromIntegral (fromEnum ResponseTypeYes))
containerAdd box grid
widgetShow grid
windowSetTransientFor dialog win
res <- dialogRun dialog
searchString <- entryGetText searchEntry
let maybeSearchString =
case toEnum (fromIntegral res) of
ResponseTypeYes -> Just searchString
_ -> Nothing
widgetDestroy dialog
pure maybeSearchString
doFind :: TMState -> IO ()
doFind mvarTMState = do
tmState <- readMVar mvarTMState
let app = tmStateApp tmState
maybeSearchString <- showFindDialog app
-- putStrLn $ "trying to find: " <> tshow maybeSearchString
maybeTerminal <- getFocusedTermFromState mvarTMState
case (maybeSearchString, maybeTerminal) of
(Just searchString, Just terminal) -> do
-- TODO: Figure out how to import the correct pcre flags.
--
-- If you don't pass the pcre2Multiline flag, VTE gives
-- the following warning:
--
-- (termonad-linux-x86_64:18792): Vte-WARNING **:
-- 21:56:31.193: (vtegtk.cc:2269):void
-- vte_terminal_search_set_regex(VteTerminal*,
-- VteRegex*, guint32): runtime check failed:
-- (regex == nullptr ||
-- _vte_regex_get_compile_flags(regex) & PCRE2_MULTILINE)
--
-- However, if you do add the pcre2Multiline flag,
-- the terminalSearchSetRegex appears to just completely
-- not work.
let pcreFlags = 0
let newRegex =
regexNewForSearch
searchString
(fromIntegral $ length searchString)
pcreFlags
eitherRegex <-
catchRegexError
(fmap Right newRegex)
(\_ errMsg -> pure (Left errMsg))
case eitherRegex of
Left errMsg -> do
let msg = "error when creating regex: " <> errMsg
hPutStrLn stderr msg
Right regex -> do
terminalSearchSetRegex terminal (Just regex) pcreFlags
terminalSearchSetWrapAround terminal True
_matchFound <- terminalSearchFindPrevious terminal
-- TODO: Setup an actual logging framework to show these
-- kinds of log messages. Also make a similar change in
-- findAbove and findBelow.
-- putStrLn $ "was match found: " <> tshow matchFound
pure ()
_ -> pure ()
findAbove :: TMState -> IO ()
findAbove mvarTMState = do
maybeTerminal <- getFocusedTermFromState mvarTMState
case maybeTerminal of
Nothing -> pure ()
Just terminal -> do
_matchFound <- terminalSearchFindPrevious terminal
-- putStrLn $ "was match found: " <> tshow matchFound
pure ()
findBelow :: TMState -> IO ()
findBelow mvarTMState = do
maybeTerminal <- getFocusedTermFromState mvarTMState
case maybeTerminal of
Nothing -> pure ()
Just terminal -> do
_matchFound <- terminalSearchFindNext terminal
-- putStrLn $ "was match found: " <> tshow matchFound
pure ()
setShowMenuBar :: Application -> Bool -> IO ()
setShowMenuBar app visible = do
void $ runMaybeT $ do
win <- MaybeT $ applicationGetActiveWindow app
appWin <- MaybeT $ castTo ApplicationWindow win
lift $ applicationWindowSetShowMenubar appWin visible
-- | 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 = find (\x -> tshow x == label) values
applyNewPreferences :: TMState -> IO ()
applyNewPreferences mvarTMState = do
tmState <- readMVar mvarTMState
let appWin = tmState ^. lensTMStateAppWin
config = tmState ^. lensTMStateConfig
notebook = tmState ^. lensTMStateNotebook . lensTMNotebook
tabFocusList = tmState ^. lensTMStateNotebook . lensTMNotebookTabs
showMenu = config ^. lensOptions . lensShowMenu
applicationWindowSetShowMenubar appWin showMenu
setShowTabs config notebook
-- Sets the remaining preferences to each tab
foldMap (applyNewPreferencesToTab mvarTMState) tabFocusList
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 (options ^. lensCursorBlinkMode)
terminalSetWordCharExceptions term (options ^. lensWordCharExceptions)
terminalSetScrollbackLines term (fromIntegral (options ^. lensScrollbackLen))
let vScrollbarPolicy = showScrollbarToPolicy (options ^. lensShowScrollbar)
scrolledWindowSetPolicy scrolledWin PolicyTypeAutomatic vScrollbarPolicy
-- | 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 (length preferencesText)
preferencesDialog <-
objFromBuildUnsafe preferencesBuilder "preferences" Dialog
confirmExitCheckButton <-
objFromBuildUnsafe preferencesBuilder "confirmExit" CheckButton
showMenuCheckButton <-
objFromBuildUnsafe preferencesBuilder "showMenu" 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 $ options ^. lensShowScrollbar
comboBoxSetActive showTabBarComboBoxText $ options ^. lensShowTabBar
comboBoxSetActive cursorBlinkModeComboBoxText $ options ^. lensCursorBlinkMode
spinButtonSetValue
scrollbackLenSpinButton
(fromIntegral $ options ^. lensScrollbackLen)
toggleButtonSetActive confirmExitCheckButton $ options ^. lensConfirmExit
toggleButtonSetActive showMenuCheckButton $ options ^. lensShowMenu
entryBufferSetText
wordCharExceptionsEntryBuffer
(options ^. lensWordCharExceptions)
(-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 ..]
scrollbackLen <-
fromIntegral <$> spinButtonGetValueAsInt scrollbackLenSpinButton
confirmExit <- toggleButtonGetActive confirmExitCheckButton
showMenu <- toggleButtonGetActive showMenuCheckButton
wordCharExceptions <- entryBufferGetText wordCharExceptionsEntryBuffer
-- Apply the changes to mvarTMState
modifyMVar_ mvarTMState $ pure
. over lensTMStateFontDesc (`fromMaybe` maybeFontDesc)
. over (lensTMStateConfig . lensOptions)
( set lensConfirmExit confirmExit
. set lensShowMenu showMenu
. set lensWordCharExceptions wordCharExceptions
. over lensFontConfig (`fromMaybe` maybeFontConfig)
. set lensScrollbackLen scrollbackLen
. 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
appStartup :: Application -> IO ()
appStartup _app = pure ()
-- | Run Termonad with the given 'TMConfig'.
--
-- Do not perform any of the recompilation operations that the 'defaultMain'
-- function does.
start :: TMConfig -> IO ()
start tmConfig = do
-- app <- appNew (Just "haskell.termonad") [ApplicationFlagsFlagsNone]
-- Make sure the application is not unique, so we can open multiple copies of it.
app <- appNew Nothing [ApplicationFlagsFlagsNone]
void $ onApplicationStartup app (appStartup app)
void $ onApplicationActivate app (appActivate tmConfig app)
void $ applicationRun app Nothing
-- | Run Termonad with the given 'TMConfig'.
--
-- This function will check if there is a @~\/.config\/termonad\/termonad.hs@ file
-- and a @~\/.cache\/termonad\/termonad-linux-x86_64@ binary. Termonad will
-- perform different actions based on whether or not these two files exist.
--
-- Here are the four different possible actions based on the existence of these
-- two files.
--
-- - @~\/.config\/termonad\/termonad.hs@ exists, @~\/.cache\/termonad\/termonad-linux-x86_64@ exists
--
-- The timestamps of these two files are checked. If the
-- @~\/.config\/termonad\/termonad.hs@ file has been modified after the
-- @~\/.cache\/termonad\/termonad-linux-x86_64@ binary, then Termonad will use
-- GHC to recompile the @~\/.config\/termonad\/termonad.hs@ file, producing a
-- new binary at @~\/.cache\/termonad\/termonad-linux-x86_64@. This new binary
-- will be re-executed. The 'TMConfig' passed to this 'defaultMain' will be
-- effectively thrown away.
--
-- If GHC fails to recompile the @~\/.config\/termonad\/termonad.hs@ file, then
-- Termonad will just execute 'start' with the 'TMConfig' passed in.
--
-- If the @~\/.cache\/termonad\/termonad-linux-x86_64@ binary has been modified
-- after the @~\/.config\/termonad\/termonad.hs@ file, then Termonad will
-- re-exec the @~\/.cache\/termonad\/termonad-linux-x86_64@ binary. The
-- 'TMConfig' passed to this 'defaultMain' will be effectively thrown away.
--
-- - @~\/.config\/termonad\/termonad.hs@ exists, @~\/.cache\/termonad\/termonad-linux-x86_64@ does not exist
--
-- Termonad will use GHC to recompile the @~\/.config\/termonad\/termonad.hs@
-- file, producing a new binary at @~\/.cache\/termonad\/termonad-linux-x86_64@.
-- This new binary will be re-executed. The 'TMConfig' passed to this
-- 'defaultMain' will be effectively thrown away.
--
-- If GHC fails to recompile the @~\/.config\/termonad\/termonad.hs@ file, then
-- Termonad will just execute 'start' with the 'TMConfig' passed in.
--
-- - @~\/.config\/termonad\/termonad.hs@ does not exist, @~\/.cache\/termonad\/termonad-linux-x86_64@ exists
--
-- Termonad will ignore the @~\/.cache\/termonad\/termonad-linux-x86_64@ binary
-- and just run 'start' with the 'TMConfig' passed to this function.
--
-- - @~\/.config\/termonad\/termonad.hs@ does not exist, @~\/.cache\/termonad\/termonad-linux-x86_64@ does not exist
--
-- Termonad will run 'start' with the 'TMConfig' passed to this function.
--
-- Other notes:
--
-- 1. That the locations of @~\/.config\/termonad\/termonad.hs@ and
-- @~\/.cache\/termonad\/termonad-linux-x86_64@ may differ depending on your
-- system.
--
-- 2. In your own @~\/.config\/termonad\/termonad.hs@ file, you can use either
-- 'defaultMain' or 'start'. As long as you always execute the system-wide
-- @termonad@ binary (instead of the binary produced as
-- @~\/.cache\/termonad\/termonad-linux-x86_64@), the effect should be the same.
defaultMain :: TMConfig -> IO ()
defaultMain tmConfig = do
let params =
defaultParams
{ projectName = "termonad"
, showError = \(cfg, oldErrs) newErr -> (cfg, oldErrs <> "\n" <> newErr)
, realMain = \(cfg, errs) -> putStrLn (pack errs) *> start cfg
}
eitherRes <- tryIOError $ wrapMain params (tmConfig, "")
case eitherRes of
Left ioErr
| ioeGetErrorType ioErr == doesNotExistErrorType && ioeGetFileName ioErr == Just "ghc" -> do
putStrLn $
"Could not find ghc on your PATH. Ignoring your termonad.hs " <>
"configuration file and running termonad with default settings."
start tmConfig
| otherwise -> do
putStrLn "IO error occurred when trying to run termonad:"
print ioErr
putStrLn "Don't know how to recover. Exiting."
Right _ -> pure ()