{-# LANGUAGE ForeignFunctionInterface #-}
module Termonad.App where
import Termonad.Prelude
import Config.Dyre (defaultParams, projectName, realMain, showError, wrapMain)
import Control.Lens ((&), (.~), (^.), (^..), over, set, view)
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 {"
, " background-color: #aaaaaa;"
, "}"
, "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
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
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)
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
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"
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
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
maybeTerminal <- getFocusedTermFromState mvarTMState
case (maybeSearchString, maybeTerminal) of
(Just searchString, Just terminal) -> do
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
pure ()
_ -> pure ()
findAbove :: TMState -> IO ()
findAbove mvarTMState = do
maybeTerminal <- getFocusedTermFromState mvarTMState
case maybeTerminal of
Nothing -> pure ()
Just terminal -> do
_matchFound <- terminalSearchFindPrevious terminal
pure ()
findBelow :: TMState -> IO ()
findBelow mvarTMState = do
maybeTerminal <- getFocusedTermFromState mvarTMState
case maybeTerminal of
Nothing -> pure ()
Just terminal -> do
_matchFound <- terminalSearchFindNext terminal
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
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
comboBoxSetActive :: Show a => ComboBoxText -> a -> IO ()
comboBoxSetActive cb item = void $ comboBoxSetActiveId cb (Just $ tshow item)
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
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
showPreferencesDialog :: TMState -> IO ()
showPreferencesDialog mvarTMState = do
tmState <- readMVar mvarTMState
let app = tmState ^. lensTMStateApp
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
executablePath <- getExecutablePath
let hasTermonadHs = takeFileName executablePath == "termonad-linux-x86_64"
widgetSetVisible warningLabel hasTermonadHs
maybeWin <- applicationGetActiveWindow app
windowSetTransientFor preferencesDialog maybeWin
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)
res <- dialogRun preferencesDialog
when (toEnum (fromIntegral res) == ResponseTypeAccept) $ do
maybeFontDesc <- fontChooserGetFontDesc fontButton
maybeFontConfig <-
liftM 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
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)
)
withMVar mvarTMState $ saveToPreferencesFile . view lensTMStateConfig
applyNewPreferences mvarTMState
widgetDestroy preferencesDialog
appStartup :: Application -> IO ()
appStartup _app = pure ()
start :: TMConfig -> IO ()
start tmConfig = do
app <- appNew Nothing [ApplicationFlagsFlagsNone]
void $ onApplicationStartup app (appStartup app)
void $ onApplicationActivate app (appActivate tmConfig app)
void $ applicationRun app Nothing
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 ()