{-# LANGUAGE ForeignFunctionInterface #-}

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 :: IO ()
setupScreenStyle = do
  Maybe Screen
maybeScreen <- IO (Maybe Screen)
forall (m :: * -> *). (HasCallStack, MonadIO m) => m (Maybe Screen)
screenGetDefault
  case Maybe Screen
maybeScreen of
    Nothing -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just screen :: Screen
screen -> do
      CssProvider
cssProvider <- IO CssProvider
forall (m :: * -> *). (HasCallStack, MonadIO m) => m CssProvider
cssProviderNew
      let ([Text]
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 :: ByteString
styleData = Text -> ByteString
forall textual binary. Utf8 textual binary => textual -> binary
encodeUtf8 ([Text] -> Text
forall t seq.
(Textual t, Element seq ~ t, MonoFoldable seq) =>
seq -> t
unlines [Text]
textLines :: Text)
      CssProvider -> ByteString -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsCssProvider a) =>
a -> ByteString -> m ()
cssProviderLoadFromData CssProvider
cssProvider ByteString
styleData
      Screen -> CssProvider -> Word32 -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsScreen a, IsStyleProvider b) =>
a -> b -> Word32 -> m ()
styleContextAddProviderForScreen
        Screen
screen
        CssProvider
cssProvider
        (Int32 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
STYLE_PROVIDER_PRIORITY_APPLICATION)

createFontDescFromConfig :: TMConfig -> IO FontDescription
createFontDescFromConfig :: TMConfig -> IO FontDescription
createFontDescFromConfig tmConfig :: TMConfig
tmConfig = do
  let fontConf :: FontConfig
fontConf = TMConfig
tmConfig TMConfig -> Getting FontConfig TMConfig FontConfig -> FontConfig
forall s a. s -> Getting a s a -> a
^. (ConfigOptions -> Const FontConfig ConfigOptions)
-> TMConfig -> Const FontConfig TMConfig
Lens' TMConfig ConfigOptions
lensOptions ((ConfigOptions -> Const FontConfig ConfigOptions)
 -> TMConfig -> Const FontConfig TMConfig)
-> ((FontConfig -> Const FontConfig FontConfig)
    -> ConfigOptions -> Const FontConfig ConfigOptions)
-> Getting FontConfig TMConfig FontConfig
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (FontConfig -> Const FontConfig FontConfig)
-> ConfigOptions -> Const FontConfig ConfigOptions
Lens' ConfigOptions FontConfig
lensFontConfig
  FontSize -> Text -> IO FontDescription
createFontDesc (FontConfig -> FontSize
fontSize FontConfig
fontConf) (FontConfig -> Text
fontFamily FontConfig
fontConf)

createFontDesc :: FontSize -> Text -> IO FontDescription
createFontDesc :: FontSize -> Text -> IO FontDescription
createFontDesc fontSz :: FontSize
fontSz fontFam :: Text
fontFam = do
  FontDescription
fontDesc <- IO FontDescription
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
m FontDescription
fontDescriptionNew
  FontDescription -> Text -> IO ()
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
FontDescription -> Text -> m ()
fontDescriptionSetFamily FontDescription
fontDesc Text
fontFam
  FontDescription -> FontSize -> IO ()
setFontDescSize FontDescription
fontDesc FontSize
fontSz
  FontDescription -> IO FontDescription
forall (f :: * -> *) a. Applicative f => a -> f a
pure FontDescription
fontDesc

setFontDescSize :: FontDescription -> FontSize -> IO ()
setFontDescSize :: FontDescription -> FontSize -> IO ()
setFontDescSize fontDesc :: FontDescription
fontDesc (FontSizePoints points :: Int
points) =
  FontDescription -> Int32 -> IO ()
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
FontDescription -> Int32 -> m ()
fontDescriptionSetSize FontDescription
fontDesc (Int32 -> IO ()) -> Int32 -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
points Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
SCALE)
setFontDescSize fontDesc :: FontDescription
fontDesc (FontSizeUnits units :: Double
units) =
  FontDescription -> Double -> IO ()
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
FontDescription -> Double -> m ()
fontDescriptionSetAbsoluteSize FontDescription
fontDesc (Double -> IO ()) -> Double -> IO ()
forall a b. (a -> b) -> a -> b
$ Double
units Double -> Double -> Double
forall a. Num a => a -> a -> a
* Int32 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
SCALE

adjustFontDescSize :: (FontSize -> FontSize) -> FontDescription -> IO ()
adjustFontDescSize :: (FontSize -> FontSize) -> FontDescription -> IO ()
adjustFontDescSize f :: FontSize -> FontSize
f fontDesc :: FontDescription
fontDesc = do
  FontSize
currFontSz <- FontDescription -> IO FontSize
fontSizeFromFontDescription FontDescription
fontDesc
  let newFontSz :: FontSize
newFontSz = FontSize -> FontSize
f FontSize
currFontSz
  FontDescription -> FontSize -> IO ()
setFontDescSize FontDescription
fontDesc FontSize
newFontSz

modifyFontSizeForAllTerms :: (FontSize -> FontSize) -> TMState -> IO ()
modifyFontSizeForAllTerms :: (FontSize -> FontSize) -> TMState -> IO ()
modifyFontSizeForAllTerms modFontSizeFunc :: FontSize -> FontSize
modFontSizeFunc mvarTMState :: TMState
mvarTMState = do
  TMState'
tmState <- TMState -> IO TMState'
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar TMState
mvarTMState
  let fontDesc :: FontDescription
fontDesc = TMState'
tmState TMState'
-> Getting FontDescription TMState' FontDescription
-> FontDescription
forall s a. s -> Getting a s a -> a
^. Getting FontDescription TMState' FontDescription
Lens' TMState' FontDescription
lensTMStateFontDesc
  (FontSize -> FontSize) -> FontDescription -> IO ()
adjustFontDescSize FontSize -> FontSize
modFontSizeFunc FontDescription
fontDesc
  let terms :: [Terminal]
terms =
        TMState'
tmState TMState'
-> Getting (Endo [Terminal]) TMState' Terminal -> [Terminal]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^..
          (TMNotebook -> Const (Endo [Terminal]) TMNotebook)
-> TMState' -> Const (Endo [Terminal]) TMState'
Lens' TMState' TMNotebook
lensTMStateNotebook ((TMNotebook -> Const (Endo [Terminal]) TMNotebook)
 -> TMState' -> Const (Endo [Terminal]) TMState')
-> ((Terminal -> Const (Endo [Terminal]) Terminal)
    -> TMNotebook -> Const (Endo [Terminal]) TMNotebook)
-> Getting (Endo [Terminal]) TMState' Terminal
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
          (FocusList TMNotebookTab
 -> Const (Endo [Terminal]) (FocusList TMNotebookTab))
-> TMNotebook -> Const (Endo [Terminal]) TMNotebook
Lens' TMNotebook (FocusList TMNotebookTab)
lensTMNotebookTabs ((FocusList TMNotebookTab
  -> Const (Endo [Terminal]) (FocusList TMNotebookTab))
 -> TMNotebook -> Const (Endo [Terminal]) TMNotebook)
-> ((Terminal -> Const (Endo [Terminal]) Terminal)
    -> FocusList TMNotebookTab
    -> Const (Endo [Terminal]) (FocusList TMNotebookTab))
-> (Terminal -> Const (Endo [Terminal]) Terminal)
-> TMNotebook
-> Const (Endo [Terminal]) TMNotebook
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
          (TMNotebookTab -> Const (Endo [Terminal]) TMNotebookTab)
-> FocusList TMNotebookTab
-> Const (Endo [Terminal]) (FocusList TMNotebookTab)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((TMNotebookTab -> Const (Endo [Terminal]) TMNotebookTab)
 -> FocusList TMNotebookTab
 -> Const (Endo [Terminal]) (FocusList TMNotebookTab))
-> ((Terminal -> Const (Endo [Terminal]) Terminal)
    -> TMNotebookTab -> Const (Endo [Terminal]) TMNotebookTab)
-> (Terminal -> Const (Endo [Terminal]) Terminal)
-> FocusList TMNotebookTab
-> Const (Endo [Terminal]) (FocusList TMNotebookTab)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
          (TMTerm -> Const (Endo [Terminal]) TMTerm)
-> TMNotebookTab -> Const (Endo [Terminal]) TMNotebookTab
Lens' TMNotebookTab TMTerm
lensTMNotebookTabTerm ((TMTerm -> Const (Endo [Terminal]) TMTerm)
 -> TMNotebookTab -> Const (Endo [Terminal]) TMNotebookTab)
-> ((Terminal -> Const (Endo [Terminal]) Terminal)
    -> TMTerm -> Const (Endo [Terminal]) TMTerm)
-> (Terminal -> Const (Endo [Terminal]) Terminal)
-> TMNotebookTab
-> Const (Endo [Terminal]) TMNotebookTab
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
          (Terminal -> Const (Endo [Terminal]) Terminal)
-> TMTerm -> Const (Endo [Terminal]) TMTerm
Lens' TMTerm Terminal
lensTerm
  (Element [Terminal] -> IO ()) -> [Terminal] -> IO ()
forall mono m.
(MonoFoldable mono, Monoid m) =>
(Element mono -> m) -> mono -> m
foldMap (\vteTerm :: Element [Terminal]
vteTerm -> Terminal -> Maybe FontDescription -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsTerminal a) =>
a -> Maybe FontDescription -> m ()
terminalSetFont Element [Terminal]
Terminal
vteTerm (FontDescription -> Maybe FontDescription
forall a. a -> Maybe a
Just FontDescription
fontDesc)) [Terminal]
terms

fontSizeFromFontDescription :: FontDescription -> IO FontSize
fontSizeFromFontDescription :: FontDescription -> IO FontSize
fontSizeFromFontDescription fontDesc :: FontDescription
fontDesc = do
  Int32
currSize <- FontDescription -> IO Int32
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
FontDescription -> m Int32
fontDescriptionGetSize FontDescription
fontDesc
  Bool
currAbsolute <- FontDescription -> IO Bool
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
FontDescription -> m Bool
fontDescriptionGetSizeIsAbsolute FontDescription
fontDesc
  FontSize -> IO FontSize
forall (m :: * -> *) a. Monad m => a -> m a
return (FontSize -> IO FontSize) -> FontSize -> IO FontSize
forall a b. (a -> b) -> a -> b
$ if Bool
currAbsolute
             then Double -> FontSize
FontSizeUnits (Double -> FontSize) -> Double -> FontSize
forall a b. (a -> b) -> a -> b
$ Int32 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
currSize Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int32 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
SCALE
             else
               let Double
fontRatio :: Double = Int32 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
currSize Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int32 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
SCALE
               in Int -> FontSize
FontSizePoints (Int -> FontSize) -> Int -> FontSize
forall a b. (a -> b) -> a -> b
$ Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round Double
fontRatio

fontConfigFromFontDescription :: FontDescription -> IO (Maybe FontConfig)
fontConfigFromFontDescription :: FontDescription -> IO (Maybe FontConfig)
fontConfigFromFontDescription fontDescription :: FontDescription
fontDescription = do
  FontSize
fontSize <- FontDescription -> IO FontSize
fontSizeFromFontDescription FontDescription
fontDescription
  Maybe Text
maybeFontFamily <- FontDescription -> IO (Maybe Text)
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
FontDescription -> m (Maybe Text)
fontDescriptionGetFamily FontDescription
fontDescription
  Maybe FontConfig -> IO (Maybe FontConfig)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FontConfig -> IO (Maybe FontConfig))
-> Maybe FontConfig -> IO (Maybe FontConfig)
forall a b. (a -> b) -> a -> b
$ (Text -> FontSize -> FontConfig
`FontConfig` FontSize
fontSize) (Text -> FontConfig) -> Maybe Text -> Maybe FontConfig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
maybeFontFamily

compareScrolledWinAndTab :: ScrolledWindow -> TMNotebookTab -> Bool
compareScrolledWinAndTab :: ScrolledWindow -> TMNotebookTab -> Bool
compareScrolledWinAndTab scrollWin :: ScrolledWindow
scrollWin flTab :: TMNotebookTab
flTab =
  let ScrolledWindow managedPtrFLTab :: ManagedPtr ScrolledWindow
managedPtrFLTab = TMNotebookTab -> ScrolledWindow
tmNotebookTabTermContainer TMNotebookTab
flTab
      foreignPtrFLTab :: ForeignPtr ScrolledWindow
foreignPtrFLTab = ManagedPtr ScrolledWindow -> ForeignPtr ScrolledWindow
forall a. ManagedPtr a -> ForeignPtr a
managedForeignPtr ManagedPtr ScrolledWindow
managedPtrFLTab
      ScrolledWindow managedPtrScrollWin :: ManagedPtr ScrolledWindow
managedPtrScrollWin = ScrolledWindow
scrollWin
      foreignPtrScrollWin :: ForeignPtr ScrolledWindow
foreignPtrScrollWin = ManagedPtr ScrolledWindow -> ForeignPtr ScrolledWindow
forall a. ManagedPtr a -> ForeignPtr a
managedForeignPtr ManagedPtr ScrolledWindow
managedPtrScrollWin
  in ForeignPtr ScrolledWindow
foreignPtrFLTab ForeignPtr ScrolledWindow -> ForeignPtr ScrolledWindow -> Bool
forall a. Eq a => a -> a -> Bool
== ForeignPtr ScrolledWindow
foreignPtrScrollWin

updateFLTabPos :: TMState -> Int -> Int -> IO ()
updateFLTabPos :: TMState -> Int -> Int -> IO ()
updateFLTabPos mvarTMState :: TMState
mvarTMState oldPos :: Int
oldPos newPos :: Int
newPos =
  TMState -> (TMState' -> IO TMState') -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
MVar a -> (a -> m a) -> m ()
modifyMVar_ TMState
mvarTMState ((TMState' -> IO TMState') -> IO ())
-> (TMState' -> IO TMState') -> IO ()
forall a b. (a -> b) -> a -> b
$ \tmState :: TMState'
tmState -> do
    let tabs :: FocusList TMNotebookTab
tabs = TMState'
tmState TMState'
-> Getting
     (FocusList TMNotebookTab) TMState' (FocusList TMNotebookTab)
-> FocusList TMNotebookTab
forall s a. s -> Getting a s a -> a
^. (TMNotebook -> Const (FocusList TMNotebookTab) TMNotebook)
-> TMState' -> Const (FocusList TMNotebookTab) TMState'
Lens' TMState' TMNotebook
lensTMStateNotebook ((TMNotebook -> Const (FocusList TMNotebookTab) TMNotebook)
 -> TMState' -> Const (FocusList TMNotebookTab) TMState')
-> ((FocusList TMNotebookTab
     -> Const (FocusList TMNotebookTab) (FocusList TMNotebookTab))
    -> TMNotebook -> Const (FocusList TMNotebookTab) TMNotebook)
-> Getting
     (FocusList TMNotebookTab) TMState' (FocusList TMNotebookTab)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (FocusList TMNotebookTab
 -> Const (FocusList TMNotebookTab) (FocusList TMNotebookTab))
-> TMNotebook -> Const (FocusList TMNotebookTab) TMNotebook
Lens' TMNotebook (FocusList TMNotebookTab)
lensTMNotebookTabs
        maybeNewTabs :: Maybe (FocusList TMNotebookTab)
maybeNewTabs = Int
-> Int
-> FocusList TMNotebookTab
-> Maybe (FocusList TMNotebookTab)
forall a.
Show a =>
Int -> Int -> FocusList a -> Maybe (FocusList a)
moveFromToFL Int
oldPos Int
newPos FocusList TMNotebookTab
tabs
    case Maybe (FocusList TMNotebookTab)
maybeNewTabs of
      Nothing -> do
        Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
          "in updateFLTabPos, Strange error: couldn't move tabs.\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
          "old pos: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
oldPos Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
          "new pos: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
newPos Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
          "tabs: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FocusList TMNotebookTab -> Text
forall a. Show a => a -> Text
tshow FocusList TMNotebookTab
tabs Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
          "maybeNewTabs: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe (FocusList TMNotebookTab) -> Text
forall a. Show a => a -> Text
tshow Maybe (FocusList TMNotebookTab)
maybeNewTabs Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
          "tmState: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TMState' -> Text
forall a. Show a => a -> Text
tshow TMState'
tmState
        TMState' -> IO TMState'
forall (f :: * -> *) a. Applicative f => a -> f a
pure TMState'
tmState
      Just newTabs :: FocusList TMNotebookTab
newTabs ->
        TMState' -> IO TMState'
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TMState' -> IO TMState') -> TMState' -> IO TMState'
forall a b. (a -> b) -> a -> b
$
          TMState'
tmState TMState' -> (TMState' -> TMState') -> TMState'
forall a b. a -> (a -> b) -> b
&
            (TMNotebook -> Identity TMNotebook)
-> TMState' -> Identity TMState'
Lens' TMState' TMNotebook
lensTMStateNotebook ((TMNotebook -> Identity TMNotebook)
 -> TMState' -> Identity TMState')
-> ((FocusList TMNotebookTab -> Identity (FocusList TMNotebookTab))
    -> TMNotebook -> Identity TMNotebook)
-> (FocusList TMNotebookTab -> Identity (FocusList TMNotebookTab))
-> TMState'
-> Identity TMState'
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (FocusList TMNotebookTab -> Identity (FocusList TMNotebookTab))
-> TMNotebook -> Identity TMNotebook
Lens' TMNotebook (FocusList TMNotebookTab)
lensTMNotebookTabs ((FocusList TMNotebookTab -> Identity (FocusList TMNotebookTab))
 -> TMState' -> Identity TMState')
-> FocusList TMNotebookTab -> TMState' -> TMState'
forall s t a b. ASetter s t a b -> b -> s -> t
.~ FocusList TMNotebookTab
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'.
askShouldExit :: TMState -> IO ResponseType
askShouldExit :: TMState -> IO ResponseType
askShouldExit mvarTMState :: TMState
mvarTMState = do
  TMState'
tmState <- TMState -> IO TMState'
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar TMState
mvarTMState
  let confirm :: Bool
confirm = TMState'
tmState TMState' -> Getting Bool TMState' Bool -> Bool
forall s a. s -> Getting a s a -> a
^. (TMConfig -> Const Bool TMConfig)
-> TMState' -> Const Bool TMState'
Lens' TMState' TMConfig
lensTMStateConfig ((TMConfig -> Const Bool TMConfig)
 -> TMState' -> Const Bool TMState')
-> ((Bool -> Const Bool Bool) -> TMConfig -> Const Bool TMConfig)
-> Getting Bool TMState' Bool
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (ConfigOptions -> Const Bool ConfigOptions)
-> TMConfig -> Const Bool TMConfig
Lens' TMConfig ConfigOptions
lensOptions ((ConfigOptions -> Const Bool ConfigOptions)
 -> TMConfig -> Const Bool TMConfig)
-> ((Bool -> Const Bool Bool)
    -> ConfigOptions -> Const Bool ConfigOptions)
-> (Bool -> Const Bool Bool)
-> TMConfig
-> Const Bool TMConfig
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Bool -> Const Bool Bool)
-> ConfigOptions -> Const Bool ConfigOptions
Lens' ConfigOptions Bool
lensConfirmExit
  if Bool
confirm
    then TMState' -> IO ResponseType
confirmationDialogForExit TMState'
tmState
    else ResponseType -> IO ResponseType
forall (f :: * -> *) a. Applicative f => a -> f a
pure ResponseType
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' -> IO ResponseType
confirmationDialogForExit tmState :: TMState'
tmState = do
      let app :: Application
app = TMState'
tmState TMState' -> Getting Application TMState' Application -> Application
forall s a. s -> Getting a s a -> a
^. Getting Application TMState' Application
Lens' TMState' Application
lensTMStateApp
      Maybe Window
win <- Application -> IO (Maybe Window)
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsApplication a) =>
a -> m (Maybe Window)
applicationGetActiveWindow Application
app
      Dialog
dialog <- IO Dialog
forall (m :: * -> *). (HasCallStack, MonadIO m) => m Dialog
dialogNew
      Box
box <- Dialog -> IO Box
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsDialog a) =>
a -> m Box
dialogGetContentArea Dialog
dialog
      Label
label <-
        Maybe Text -> IO Label
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Maybe Text -> m Label
labelNew (Maybe Text -> IO Label) -> Maybe Text -> IO Label
forall a b. (a -> b) -> a -> b
$
          Text -> Maybe Text
forall a. a -> Maybe a
Just
            "There are still terminals running.  Are you sure you want to exit?"
      Box -> Label -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
containerAdd Box
box Label
label
      Label -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
widgetShow Label
label
      Label -> Int32 -> IO ()
forall (m :: * -> *) o.
(MonadIO m, IsWidget o) =>
o -> Int32 -> m ()
setWidgetMargin Label
label 10
      IO Widget -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Widget -> IO ()) -> IO Widget -> IO ()
forall a b. (a -> b) -> a -> b
$
        Dialog -> Text -> Int32 -> IO Widget
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsDialog a) =>
a -> Text -> Int32 -> m Widget
dialogAddButton
          Dialog
dialog
          "No, do NOT exit"
          (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ResponseType -> Int
forall a. Enum a => a -> Int
fromEnum ResponseType
ResponseTypeNo))
      IO Widget -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Widget -> IO ()) -> IO Widget -> IO ()
forall a b. (a -> b) -> a -> b
$
        Dialog -> Text -> Int32 -> IO Widget
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsDialog a) =>
a -> Text -> Int32 -> m Widget
dialogAddButton
          Dialog
dialog
          "Yes, exit"
          (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ResponseType -> Int
forall a. Enum a => a -> Int
fromEnum ResponseType
ResponseTypeYes))
      Dialog -> Maybe Window -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsWindow a, IsWindow b) =>
a -> Maybe b -> m ()
windowSetTransientFor Dialog
dialog Maybe Window
win
      Int32
res <- Dialog -> IO Int32
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsDialog a) =>
a -> m Int32
dialogRun Dialog
dialog
      Dialog -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
widgetDestroy Dialog
dialog
      ResponseType -> IO ResponseType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ResponseType -> IO ResponseType)
-> ResponseType -> IO ResponseType
forall a b. (a -> b) -> a -> b
$ Int -> ResponseType
forall a. Enum a => Int -> a
toEnum (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
res)

-- | Force Termonad to exit without asking the user whether or not to do so.
forceQuit :: TMState -> IO ()
forceQuit :: TMState -> IO ()
forceQuit mvarTMState :: TMState
mvarTMState = do
  TMState'
tmState <- TMState -> IO TMState'
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar TMState
mvarTMState
  let app :: Application
app = TMState'
tmState TMState' -> Getting Application TMState' Application -> Application
forall s a. s -> Getting a s a -> a
^. Getting Application TMState' Application
Lens' TMState' Application
lensTMStateApp
  Application -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsApplication a) =>
a -> m ()
applicationQuit Application
app

setupTermonad :: TMConfig -> Application -> ApplicationWindow -> Gtk.Builder -> IO ()
setupTermonad :: TMConfig -> Application -> ApplicationWindow -> Builder -> IO ()
setupTermonad tmConfig :: TMConfig
tmConfig app :: Application
app win :: ApplicationWindow
win builder :: Builder
builder = do
  FilePath
termonadIconPath <- FilePath -> IO FilePath
getDataFileName "img/termonad-lambda.png"
  FilePath -> IO ()
forall (m :: * -> *). (HasCallStack, MonadIO m) => FilePath -> m ()
windowSetDefaultIconFromFile FilePath
termonadIconPath

  IO ()
setupScreenStyle
  Box
box <- Builder -> Text -> (ManagedPtr Box -> Box) -> IO Box
forall o.
GObject o =>
Builder -> Text -> (ManagedPtr o -> o) -> IO o
objFromBuildUnsafe Builder
builder "content_box" ManagedPtr Box -> Box
Box
  FontDescription
fontDesc <- TMConfig -> IO FontDescription
createFontDescFromConfig TMConfig
tmConfig
  Notebook
note <- IO Notebook
forall (m :: * -> *). (HasCallStack, MonadIO m) => m Notebook
notebookNew
  Notebook -> Bool -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> Bool -> m ()
widgetSetCanFocus Notebook
note Bool
False
  -- If this is not set to False, then there will be a one pixel white border
  -- shown around the notebook.
  Notebook -> Bool -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsNotebook a) =>
a -> Bool -> m ()
notebookSetShowBorder Notebook
note Bool
False
  Box -> Notebook -> Bool -> Bool -> Word32 -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsBox a, IsWidget b) =>
a -> b -> Bool -> Bool -> Word32 -> m ()
boxPackStart Box
box Notebook
note Bool
True Bool
True 0

  TMState
mvarTMState <- TMConfig
-> Application
-> ApplicationWindow
-> Notebook
-> FontDescription
-> IO TMState
newEmptyTMState TMConfig
tmConfig Application
app ApplicationWindow
win Notebook
note FontDescription
fontDesc
  TMTerm
terminal <- (TMState -> EventKey -> IO Bool) -> TMState -> IO TMTerm
createTerm TMState -> EventKey -> IO Bool
handleKeyPress TMState
mvarTMState

  IO SignalHandlerId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO SignalHandlerId -> IO ()) -> IO SignalHandlerId -> IO ()
forall a b. (a -> b) -> a -> b
$ Notebook -> NotebookPageRemovedCallback -> IO SignalHandlerId
forall a (m :: * -> *).
(IsNotebook a, MonadIO m) =>
a -> NotebookPageRemovedCallback -> m SignalHandlerId
onNotebookPageRemoved Notebook
note (NotebookPageRemovedCallback -> IO SignalHandlerId)
-> NotebookPageRemovedCallback -> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ \_ _ -> do
    Int32
pages <- Notebook -> IO Int32
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsNotebook a) =>
a -> m Int32
notebookGetNPages Notebook
note
    if Int32
pages Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
== 0
      then TMState -> IO ()
forceQuit TMState
mvarTMState
      else TMConfig -> Notebook -> IO ()
setShowTabs TMConfig
tmConfig Notebook
note

  IO SignalHandlerId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO SignalHandlerId -> IO ()) -> IO SignalHandlerId -> IO ()
forall a b. (a -> b) -> a -> b
$ Notebook -> NotebookPageRemovedCallback -> IO SignalHandlerId
forall a (m :: * -> *).
(IsNotebook a, MonadIO m) =>
a -> NotebookPageRemovedCallback -> m SignalHandlerId
onNotebookSwitchPage Notebook
note (NotebookPageRemovedCallback -> IO SignalHandlerId)
-> NotebookPageRemovedCallback -> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ \_ pageNum :: Word32
pageNum -> do
    TMState -> (TMState' -> IO TMState') -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
MVar a -> (a -> m a) -> m ()
modifyMVar_ TMState
mvarTMState ((TMState' -> IO TMState') -> IO ())
-> (TMState' -> IO TMState') -> IO ()
forall a b. (a -> b) -> a -> b
$ \tmState :: TMState'
tmState -> do
      let notebook :: TMNotebook
notebook = TMState' -> TMNotebook
tmStateNotebook TMState'
tmState
          tabs :: FocusList TMNotebookTab
tabs = TMNotebook -> FocusList TMNotebookTab
tmNotebookTabs TMNotebook
notebook
          maybeNewTabs :: Maybe (TMNotebookTab, FocusList TMNotebookTab)
maybeNewTabs = Int
-> FocusList TMNotebookTab
-> Maybe (TMNotebookTab, FocusList TMNotebookTab)
forall a. Int -> FocusList a -> Maybe (a, FocusList a)
updateFocusFL (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
pageNum) FocusList TMNotebookTab
tabs
      case Maybe (TMNotebookTab, FocusList TMNotebookTab)
maybeNewTabs of
        Nothing -> TMState' -> IO TMState'
forall (f :: * -> *) a. Applicative f => a -> f a
pure TMState'
tmState
        Just (tab :: TMNotebookTab
tab, newTabs :: FocusList TMNotebookTab
newTabs) -> do
          Terminal -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
widgetGrabFocus (Terminal -> IO ()) -> Terminal -> IO ()
forall a b. (a -> b) -> a -> b
$ TMNotebookTab
tab TMNotebookTab
-> Getting Terminal TMNotebookTab Terminal -> Terminal
forall s a. s -> Getting a s a -> a
^. (TMTerm -> Const Terminal TMTerm)
-> TMNotebookTab -> Const Terminal TMNotebookTab
Lens' TMNotebookTab TMTerm
lensTMNotebookTabTerm ((TMTerm -> Const Terminal TMTerm)
 -> TMNotebookTab -> Const Terminal TMNotebookTab)
-> ((Terminal -> Const Terminal Terminal)
    -> TMTerm -> Const Terminal TMTerm)
-> Getting Terminal TMNotebookTab Terminal
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Terminal -> Const Terminal Terminal)
-> TMTerm -> Const Terminal TMTerm
Lens' TMTerm Terminal
lensTerm
          TMState' -> IO TMState'
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TMState' -> IO TMState') -> TMState' -> IO TMState'
forall a b. (a -> b) -> a -> b
$
            TMState'
tmState TMState' -> (TMState' -> TMState') -> TMState'
forall a b. a -> (a -> b) -> b
&
              (TMNotebook -> Identity TMNotebook)
-> TMState' -> Identity TMState'
Lens' TMState' TMNotebook
lensTMStateNotebook ((TMNotebook -> Identity TMNotebook)
 -> TMState' -> Identity TMState')
-> ((FocusList TMNotebookTab -> Identity (FocusList TMNotebookTab))
    -> TMNotebook -> Identity TMNotebook)
-> (FocusList TMNotebookTab -> Identity (FocusList TMNotebookTab))
-> TMState'
-> Identity TMState'
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (FocusList TMNotebookTab -> Identity (FocusList TMNotebookTab))
-> TMNotebook -> Identity TMNotebook
Lens' TMNotebook (FocusList TMNotebookTab)
lensTMNotebookTabs ((FocusList TMNotebookTab -> Identity (FocusList TMNotebookTab))
 -> TMState' -> Identity TMState')
-> FocusList TMNotebookTab -> TMState' -> TMState'
forall s t a b. ASetter s t a b -> b -> s -> t
.~ FocusList TMNotebookTab
newTabs

  IO SignalHandlerId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO SignalHandlerId -> IO ()) -> IO SignalHandlerId -> IO ()
forall a b. (a -> b) -> a -> b
$ Notebook -> NotebookPageRemovedCallback -> IO SignalHandlerId
forall a (m :: * -> *).
(IsNotebook a, MonadIO m) =>
a -> NotebookPageRemovedCallback -> m SignalHandlerId
onNotebookPageReordered Notebook
note (NotebookPageRemovedCallback -> IO SignalHandlerId)
-> NotebookPageRemovedCallback -> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ \childWidg :: Widget
childWidg pageNum :: Word32
pageNum -> do
    Maybe ScrolledWindow
maybeScrollWin <- (ManagedPtr ScrolledWindow -> ScrolledWindow)
-> Widget -> IO (Maybe ScrolledWindow)
forall o o'.
(HasCallStack, ManagedPtrNewtype o, TypedObject o,
 ManagedPtrNewtype o', TypedObject o', GObject o') =>
(ManagedPtr o' -> o') -> o -> IO (Maybe o')
castTo ManagedPtr ScrolledWindow -> ScrolledWindow
ScrolledWindow Widget
childWidg
    case Maybe ScrolledWindow
maybeScrollWin of
      Nothing ->
        FilePath -> IO ()
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
          "In setupTermonad, in callback for onNotebookPageReordered, " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<>
          "child widget is not a ScrolledWindow.\n" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<>
          "Don't know how to continue.\n"
      Just scrollWin :: ScrolledWindow
scrollWin -> do
        TMState{TMNotebook
tmStateNotebook :: TMNotebook
tmStateNotebook :: TMState' -> TMNotebook
tmStateNotebook} <- TMState -> IO TMState'
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar TMState
mvarTMState
        let fl :: FocusList TMNotebookTab
fl = TMNotebook
tmStateNotebook TMNotebook
-> ((FocusList TMNotebookTab
     -> Const (FocusList TMNotebookTab) (FocusList TMNotebookTab))
    -> TMNotebook -> Const (FocusList TMNotebookTab) TMNotebook)
-> FocusList TMNotebookTab
forall s a. s -> Getting a s a -> a
^. (FocusList TMNotebookTab
 -> Const (FocusList TMNotebookTab) (FocusList TMNotebookTab))
-> TMNotebook -> Const (FocusList TMNotebookTab) TMNotebook
Lens' TMNotebook (FocusList TMNotebookTab)
lensTMNotebookTabs
        let maybeOldPosition :: Maybe Int
maybeOldPosition =
              (TMNotebookTab -> Bool) -> Seq TMNotebookTab -> Maybe Int
forall a. (a -> Bool) -> Seq a -> Maybe Int
findIndexR (ScrolledWindow -> TMNotebookTab -> Bool
compareScrolledWinAndTab ScrolledWindow
scrollWin) (FocusList TMNotebookTab -> Seq TMNotebookTab
forall a. FocusList a -> Seq a
focusList FocusList TMNotebookTab
fl)
        case Maybe Int
maybeOldPosition of
          Nothing ->
            FilePath -> IO ()
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
              "In setupTermonad, in callback for onNotebookPageReordered, " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<>
              "the ScrolledWindow is not already in the FocusList.\n" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<>
              "Don't know how to continue.\n"
          Just oldPos :: Int
oldPos -> do
            TMState -> Int -> Int -> IO ()
updateFLTabPos TMState
mvarTMState Int
oldPos (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
pageNum)
            TMState -> IO ()
relabelTabs TMState
mvarTMState

  SimpleAction
newTabAction <- Text -> Maybe VariantType -> IO SimpleAction
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Text -> Maybe VariantType -> m SimpleAction
simpleActionNew "newtab" Maybe VariantType
forall a. Maybe a
Nothing
  IO SignalHandlerId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO SignalHandlerId -> IO ()) -> IO SignalHandlerId -> IO ()
forall a b. (a -> b) -> a -> b
$ SimpleAction -> SimpleActionActivateCallback -> IO SignalHandlerId
forall a (m :: * -> *).
(IsSimpleAction a, MonadIO m) =>
a -> SimpleActionActivateCallback -> m SignalHandlerId
onSimpleActionActivate SimpleAction
newTabAction (SimpleActionActivateCallback -> IO SignalHandlerId)
-> SimpleActionActivateCallback -> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ \_ -> IO TMTerm -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO TMTerm -> IO ()) -> IO TMTerm -> IO ()
forall a b. (a -> b) -> a -> b
$ (TMState -> EventKey -> IO Bool) -> TMState -> IO TMTerm
createTerm TMState -> EventKey -> IO Bool
handleKeyPress TMState
mvarTMState
  Application -> SimpleAction -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsActionMap a, IsAction b) =>
a -> b -> m ()
actionMapAddAction Application
app SimpleAction
newTabAction
  Application -> Text -> [Text] -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsApplication a) =>
a -> Text -> [Text] -> m ()
applicationSetAccelsForAction Application
app "app.newtab" ["<Shift><Ctrl>T"]

  SimpleAction
closeTabAction <- Text -> Maybe VariantType -> IO SimpleAction
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Text -> Maybe VariantType -> m SimpleAction
simpleActionNew "closetab" Maybe VariantType
forall a. Maybe a
Nothing
  IO SignalHandlerId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO SignalHandlerId -> IO ()) -> IO SignalHandlerId -> IO ()
forall a b. (a -> b) -> a -> b
$ SimpleAction -> SimpleActionActivateCallback -> IO SignalHandlerId
forall a (m :: * -> *).
(IsSimpleAction a, MonadIO m) =>
a -> SimpleActionActivateCallback -> m SignalHandlerId
onSimpleActionActivate SimpleAction
closeTabAction (SimpleActionActivateCallback -> IO SignalHandlerId)
-> SimpleActionActivateCallback -> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ \_ ->
    TMState -> IO ()
termExitFocused TMState
mvarTMState
  Application -> SimpleAction -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsActionMap a, IsAction b) =>
a -> b -> m ()
actionMapAddAction Application
app SimpleAction
closeTabAction
  Application -> Text -> [Text] -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsApplication a) =>
a -> Text -> [Text] -> m ()
applicationSetAccelsForAction Application
app "app.closetab" ["<Shift><Ctrl>W"]

  SimpleAction
quitAction <- Text -> Maybe VariantType -> IO SimpleAction
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Text -> Maybe VariantType -> m SimpleAction
simpleActionNew "quit" Maybe VariantType
forall a. Maybe a
Nothing
  IO SignalHandlerId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO SignalHandlerId -> IO ()) -> IO SignalHandlerId -> IO ()
forall a b. (a -> b) -> a -> b
$ SimpleAction -> SimpleActionActivateCallback -> IO SignalHandlerId
forall a (m :: * -> *).
(IsSimpleAction a, MonadIO m) =>
a -> SimpleActionActivateCallback -> m SignalHandlerId
onSimpleActionActivate SimpleAction
quitAction (SimpleActionActivateCallback -> IO SignalHandlerId)
-> SimpleActionActivateCallback -> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ \_ -> do
    ResponseType
shouldExit <- TMState -> IO ResponseType
askShouldExit TMState
mvarTMState
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ResponseType
shouldExit ResponseType -> ResponseType -> Bool
forall a. Eq a => a -> a -> Bool
== ResponseType
ResponseTypeYes) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMState -> IO ()
forceQuit TMState
mvarTMState
  Application -> SimpleAction -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsActionMap a, IsAction b) =>
a -> b -> m ()
actionMapAddAction Application
app SimpleAction
quitAction
  Application -> Text -> [Text] -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsApplication a) =>
a -> Text -> [Text] -> m ()
applicationSetAccelsForAction Application
app "app.quit" ["<Shift><Ctrl>Q"]

  SimpleAction
copyAction <- Text -> Maybe VariantType -> IO SimpleAction
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Text -> Maybe VariantType -> m SimpleAction
simpleActionNew "copy" Maybe VariantType
forall a. Maybe a
Nothing
  IO SignalHandlerId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO SignalHandlerId -> IO ()) -> IO SignalHandlerId -> IO ()
forall a b. (a -> b) -> a -> b
$ SimpleAction -> SimpleActionActivateCallback -> IO SignalHandlerId
forall a (m :: * -> *).
(IsSimpleAction a, MonadIO m) =>
a -> SimpleActionActivateCallback -> m SignalHandlerId
onSimpleActionActivate SimpleAction
copyAction (SimpleActionActivateCallback -> IO SignalHandlerId)
-> SimpleActionActivateCallback -> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ \_ -> do
    Maybe Terminal
maybeTerm <- TMState -> IO (Maybe Terminal)
getFocusedTermFromState TMState
mvarTMState
    IO () -> (Terminal -> IO ()) -> Maybe Terminal -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) Terminal -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsTerminal a) =>
a -> m ()
terminalCopyClipboard Maybe Terminal
maybeTerm
  Application -> SimpleAction -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsActionMap a, IsAction b) =>
a -> b -> m ()
actionMapAddAction Application
app SimpleAction
copyAction
  Application -> Text -> [Text] -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsApplication a) =>
a -> Text -> [Text] -> m ()
applicationSetAccelsForAction Application
app "app.copy" ["<Shift><Ctrl>C"]

  SimpleAction
pasteAction <- Text -> Maybe VariantType -> IO SimpleAction
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Text -> Maybe VariantType -> m SimpleAction
simpleActionNew "paste" Maybe VariantType
forall a. Maybe a
Nothing
  IO SignalHandlerId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO SignalHandlerId -> IO ()) -> IO SignalHandlerId -> IO ()
forall a b. (a -> b) -> a -> b
$ SimpleAction -> SimpleActionActivateCallback -> IO SignalHandlerId
forall a (m :: * -> *).
(IsSimpleAction a, MonadIO m) =>
a -> SimpleActionActivateCallback -> m SignalHandlerId
onSimpleActionActivate SimpleAction
pasteAction (SimpleActionActivateCallback -> IO SignalHandlerId)
-> SimpleActionActivateCallback -> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ \_ -> do
    Maybe Terminal
maybeTerm <- TMState -> IO (Maybe Terminal)
getFocusedTermFromState TMState
mvarTMState
    IO () -> (Terminal -> IO ()) -> Maybe Terminal -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) Terminal -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsTerminal a) =>
a -> m ()
terminalPasteClipboard Maybe Terminal
maybeTerm
  Application -> SimpleAction -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsActionMap a, IsAction b) =>
a -> b -> m ()
actionMapAddAction Application
app SimpleAction
pasteAction
  Application -> Text -> [Text] -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsApplication a) =>
a -> Text -> [Text] -> m ()
applicationSetAccelsForAction Application
app "app.paste" ["<Shift><Ctrl>V"]

  SimpleAction
preferencesAction <- Text -> Maybe VariantType -> IO SimpleAction
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Text -> Maybe VariantType -> m SimpleAction
simpleActionNew "preferences" Maybe VariantType
forall a. Maybe a
Nothing
  IO SignalHandlerId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO SignalHandlerId -> IO ()) -> IO SignalHandlerId -> IO ()
forall a b. (a -> b) -> a -> b
$ SimpleAction -> SimpleActionActivateCallback -> IO SignalHandlerId
forall a (m :: * -> *).
(IsSimpleAction a, MonadIO m) =>
a -> SimpleActionActivateCallback -> m SignalHandlerId
onSimpleActionActivate SimpleAction
preferencesAction (IO () -> SimpleActionActivateCallback
forall a b. a -> b -> a
const (IO () -> SimpleActionActivateCallback)
-> IO () -> SimpleActionActivateCallback
forall a b. (a -> b) -> a -> b
$ TMState -> IO ()
showPreferencesDialog TMState
mvarTMState)
  Application -> SimpleAction -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsActionMap a, IsAction b) =>
a -> b -> m ()
actionMapAddAction Application
app SimpleAction
preferencesAction

  SimpleAction
enlargeFontAction <- Text -> Maybe VariantType -> IO SimpleAction
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Text -> Maybe VariantType -> m SimpleAction
simpleActionNew "enlargefont" Maybe VariantType
forall a. Maybe a
Nothing
  IO SignalHandlerId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO SignalHandlerId -> IO ()) -> IO SignalHandlerId -> IO ()
forall a b. (a -> b) -> a -> b
$ SimpleAction -> SimpleActionActivateCallback -> IO SignalHandlerId
forall a (m :: * -> *).
(IsSimpleAction a, MonadIO m) =>
a -> SimpleActionActivateCallback -> m SignalHandlerId
onSimpleActionActivate SimpleAction
enlargeFontAction (SimpleActionActivateCallback -> IO SignalHandlerId)
-> SimpleActionActivateCallback -> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ \_ ->
    (FontSize -> FontSize) -> TMState -> IO ()
modifyFontSizeForAllTerms (Int -> FontSize -> FontSize
modFontSize 1) TMState
mvarTMState
  Application -> SimpleAction -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsActionMap a, IsAction b) =>
a -> b -> m ()
actionMapAddAction Application
app SimpleAction
enlargeFontAction
  Application -> Text -> [Text] -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsApplication a) =>
a -> Text -> [Text] -> m ()
applicationSetAccelsForAction Application
app "app.enlargefont" ["<Ctrl>plus"]

  SimpleAction
reduceFontAction <- Text -> Maybe VariantType -> IO SimpleAction
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Text -> Maybe VariantType -> m SimpleAction
simpleActionNew "reducefont" Maybe VariantType
forall a. Maybe a
Nothing
  IO SignalHandlerId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO SignalHandlerId -> IO ()) -> IO SignalHandlerId -> IO ()
forall a b. (a -> b) -> a -> b
$ SimpleAction -> SimpleActionActivateCallback -> IO SignalHandlerId
forall a (m :: * -> *).
(IsSimpleAction a, MonadIO m) =>
a -> SimpleActionActivateCallback -> m SignalHandlerId
onSimpleActionActivate SimpleAction
reduceFontAction (SimpleActionActivateCallback -> IO SignalHandlerId)
-> SimpleActionActivateCallback -> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ \_ ->
    (FontSize -> FontSize) -> TMState -> IO ()
modifyFontSizeForAllTerms (Int -> FontSize -> FontSize
modFontSize (-1)) TMState
mvarTMState
  Application -> SimpleAction -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsActionMap a, IsAction b) =>
a -> b -> m ()
actionMapAddAction Application
app SimpleAction
reduceFontAction
  Application -> Text -> [Text] -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsApplication a) =>
a -> Text -> [Text] -> m ()
applicationSetAccelsForAction Application
app "app.reducefont" ["<Ctrl>minus"]

  SimpleAction
findAction <- Text -> Maybe VariantType -> IO SimpleAction
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Text -> Maybe VariantType -> m SimpleAction
simpleActionNew "find" Maybe VariantType
forall a. Maybe a
Nothing
  IO SignalHandlerId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO SignalHandlerId -> IO ()) -> IO SignalHandlerId -> IO ()
forall a b. (a -> b) -> a -> b
$ SimpleAction -> SimpleActionActivateCallback -> IO SignalHandlerId
forall a (m :: * -> *).
(IsSimpleAction a, MonadIO m) =>
a -> SimpleActionActivateCallback -> m SignalHandlerId
onSimpleActionActivate SimpleAction
findAction (SimpleActionActivateCallback -> IO SignalHandlerId)
-> SimpleActionActivateCallback -> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ \_ -> TMState -> IO ()
doFind TMState
mvarTMState
  Application -> SimpleAction -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsActionMap a, IsAction b) =>
a -> b -> m ()
actionMapAddAction Application
app SimpleAction
findAction
  Application -> Text -> [Text] -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsApplication a) =>
a -> Text -> [Text] -> m ()
applicationSetAccelsForAction Application
app "app.find" ["<Shift><Ctrl>F"]

  SimpleAction
findAboveAction <- Text -> Maybe VariantType -> IO SimpleAction
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Text -> Maybe VariantType -> m SimpleAction
simpleActionNew "findabove" Maybe VariantType
forall a. Maybe a
Nothing
  IO SignalHandlerId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO SignalHandlerId -> IO ()) -> IO SignalHandlerId -> IO ()
forall a b. (a -> b) -> a -> b
$ SimpleAction -> SimpleActionActivateCallback -> IO SignalHandlerId
forall a (m :: * -> *).
(IsSimpleAction a, MonadIO m) =>
a -> SimpleActionActivateCallback -> m SignalHandlerId
onSimpleActionActivate SimpleAction
findAboveAction (SimpleActionActivateCallback -> IO SignalHandlerId)
-> SimpleActionActivateCallback -> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ \_ -> TMState -> IO ()
findAbove TMState
mvarTMState
  Application -> SimpleAction -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsActionMap a, IsAction b) =>
a -> b -> m ()
actionMapAddAction Application
app SimpleAction
findAboveAction
  Application -> Text -> [Text] -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsApplication a) =>
a -> Text -> [Text] -> m ()
applicationSetAccelsForAction Application
app "app.findabove" ["<Shift><Ctrl>P"]

  SimpleAction
findBelowAction <- Text -> Maybe VariantType -> IO SimpleAction
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Text -> Maybe VariantType -> m SimpleAction
simpleActionNew "findbelow" Maybe VariantType
forall a. Maybe a
Nothing
  IO SignalHandlerId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO SignalHandlerId -> IO ()) -> IO SignalHandlerId -> IO ()
forall a b. (a -> b) -> a -> b
$ SimpleAction -> SimpleActionActivateCallback -> IO SignalHandlerId
forall a (m :: * -> *).
(IsSimpleAction a, MonadIO m) =>
a -> SimpleActionActivateCallback -> m SignalHandlerId
onSimpleActionActivate SimpleAction
findBelowAction (SimpleActionActivateCallback -> IO SignalHandlerId)
-> SimpleActionActivateCallback -> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ \_ -> TMState -> IO ()
findBelow TMState
mvarTMState
  Application -> SimpleAction -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsActionMap a, IsAction b) =>
a -> b -> m ()
actionMapAddAction Application
app SimpleAction
findBelowAction
  Application -> Text -> [Text] -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsApplication a) =>
a -> Text -> [Text] -> m ()
applicationSetAccelsForAction Application
app "app.findbelow" ["<Shift><Ctrl>I"]

  SimpleAction
aboutAction <- Text -> Maybe VariantType -> IO SimpleAction
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Text -> Maybe VariantType -> m SimpleAction
simpleActionNew "about" Maybe VariantType
forall a. Maybe a
Nothing
  IO SignalHandlerId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO SignalHandlerId -> IO ()) -> IO SignalHandlerId -> IO ()
forall a b. (a -> b) -> a -> b
$ SimpleAction -> SimpleActionActivateCallback -> IO SignalHandlerId
forall a (m :: * -> *).
(IsSimpleAction a, MonadIO m) =>
a -> SimpleActionActivateCallback -> m SignalHandlerId
onSimpleActionActivate SimpleAction
aboutAction (SimpleActionActivateCallback -> IO SignalHandlerId)
-> SimpleActionActivateCallback -> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ \_ -> Application -> IO ()
showAboutDialog Application
app
  Application -> SimpleAction -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsActionMap a, IsAction b) =>
a -> b -> m ()
actionMapAddAction Application
app SimpleAction
aboutAction

  Builder
menuBuilder <- Text -> Int64 -> IO Builder
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Text -> Int64 -> m Builder
builderNewFromString Text
menuText (Int64 -> IO Builder) -> Int64 -> IO Builder
forall a b. (a -> b) -> a -> b
$ Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Text -> Int
forall mono. MonoFoldable mono => mono -> Int
length Text
menuText)
  MenuModel
menuModel <- Builder
-> Text -> (ManagedPtr MenuModel -> MenuModel) -> IO MenuModel
forall o.
GObject o =>
Builder -> Text -> (ManagedPtr o -> o) -> IO o
objFromBuildUnsafe Builder
menuBuilder "menubar" ManagedPtr MenuModel -> MenuModel
MenuModel
  Application -> Maybe MenuModel -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsApplication a, IsMenuModel b) =>
a -> Maybe b -> m ()
applicationSetMenubar Application
app (MenuModel -> Maybe MenuModel
forall a. a -> Maybe a
Just MenuModel
menuModel)
  let showMenu :: Bool
showMenu = TMConfig
tmConfig TMConfig
-> ((Bool -> Const Bool Bool) -> TMConfig -> Const Bool TMConfig)
-> Bool
forall s a. s -> Getting a s a -> a
^. (ConfigOptions -> Const Bool ConfigOptions)
-> TMConfig -> Const Bool TMConfig
Lens' TMConfig ConfigOptions
lensOptions ((ConfigOptions -> Const Bool ConfigOptions)
 -> TMConfig -> Const Bool TMConfig)
-> ((Bool -> Const Bool Bool)
    -> ConfigOptions -> Const Bool ConfigOptions)
-> (Bool -> Const Bool Bool)
-> TMConfig
-> Const Bool TMConfig
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Bool -> Const Bool Bool)
-> ConfigOptions -> Const Bool ConfigOptions
Lens' ConfigOptions Bool
lensShowMenu
  ApplicationWindow -> Bool -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsApplicationWindow a) =>
a -> Bool -> m ()
applicationWindowSetShowMenubar ApplicationWindow
win Bool
showMenu

  ApplicationWindow -> Text -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWindow a) =>
a -> Text -> m ()
windowSetTitle ApplicationWindow
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.
  IO SignalHandlerId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO SignalHandlerId -> IO ()) -> IO SignalHandlerId -> IO ()
forall a b. (a -> b) -> a -> b
$ ApplicationWindow
-> WidgetDeleteEventCallback -> IO SignalHandlerId
forall a (m :: * -> *).
(IsWidget a, MonadIO m) =>
a -> WidgetDeleteEventCallback -> m SignalHandlerId
onWidgetDeleteEvent ApplicationWindow
win (WidgetDeleteEventCallback -> IO SignalHandlerId)
-> WidgetDeleteEventCallback -> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ \_ -> do
    ResponseType
shouldExit <- TMState -> IO ResponseType
askShouldExit TMState
mvarTMState
    Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$
      case ResponseType
shouldExit of
        ResponseTypeYes -> Bool
False
        _ -> Bool
True

  ApplicationWindow -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
widgetShowAll ApplicationWindow
win
  Terminal -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
widgetGrabFocus (Terminal -> IO ()) -> Terminal -> IO ()
forall a b. (a -> b) -> a -> b
$ TMTerm
terminal TMTerm
-> ((Terminal -> Const Terminal Terminal)
    -> TMTerm -> Const Terminal TMTerm)
-> Terminal
forall s a. s -> Getting a s a -> a
^. (Terminal -> Const Terminal Terminal)
-> TMTerm -> Const Terminal TMTerm
Lens' TMTerm Terminal
lensTerm

appActivate :: TMConfig -> Application -> IO ()
appActivate :: TMConfig -> Application -> IO ()
appActivate tmConfig :: TMConfig
tmConfig app :: Application
app = do
  Builder
uiBuilder <-
    Text -> Int64 -> IO Builder
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Text -> Int64 -> m Builder
builderNewFromString Text
interfaceText (Int64 -> IO Builder) -> Int64 -> IO Builder
forall a b. (a -> b) -> a -> b
$ Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Text -> Int
forall mono. MonoFoldable mono => mono -> Int
length Text
interfaceText)
  Builder -> Application -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsBuilder a, IsApplication b) =>
a -> b -> m ()
builderSetApplication Builder
uiBuilder Application
app
  ApplicationWindow
appWin <- Builder
-> Text
-> (ManagedPtr ApplicationWindow -> ApplicationWindow)
-> IO ApplicationWindow
forall o.
GObject o =>
Builder -> Text -> (ManagedPtr o -> o) -> IO o
objFromBuildUnsafe Builder
uiBuilder "appWin" ManagedPtr ApplicationWindow -> ApplicationWindow
ApplicationWindow
  Application -> ApplicationWindow -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsApplication a, IsWindow b) =>
a -> b -> m ()
applicationAddWindow Application
app ApplicationWindow
appWin
  TMConfig -> Application -> ApplicationWindow -> Builder -> IO ()
setupTermonad TMConfig
tmConfig Application
app ApplicationWindow
appWin Builder
uiBuilder
  ApplicationWindow -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWindow a) =>
a -> m ()
windowPresent ApplicationWindow
appWin

showAboutDialog :: Application -> IO ()
showAboutDialog :: Application -> IO ()
showAboutDialog app :: Application
app = do
  Maybe Window
win <- Application -> IO (Maybe Window)
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsApplication a) =>
a -> m (Maybe Window)
applicationGetActiveWindow Application
app
  AboutDialog
aboutDialog <- IO AboutDialog
forall (m :: * -> *). (HasCallStack, MonadIO m) => m AboutDialog
aboutDialogNew
  AboutDialog -> Maybe Window -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsWindow a, IsWindow b) =>
a -> Maybe b -> m ()
windowSetTransientFor AboutDialog
aboutDialog Maybe Window
win
  IO Int32 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int32 -> IO ()) -> IO Int32 -> IO ()
forall a b. (a -> b) -> a -> b
$ AboutDialog -> IO Int32
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsDialog a) =>
a -> m Int32
dialogRun AboutDialog
aboutDialog
  AboutDialog -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
widgetDestroy AboutDialog
aboutDialog

showFindDialog :: Application -> IO (Maybe Text)
showFindDialog :: Application -> IO (Maybe Text)
showFindDialog app :: Application
app = do
  Maybe Window
win <- Application -> IO (Maybe Window)
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsApplication a) =>
a -> m (Maybe Window)
applicationGetActiveWindow Application
app
  Dialog
dialog <- IO Dialog
forall (m :: * -> *). (HasCallStack, MonadIO m) => m Dialog
dialogNew
  Box
box <- Dialog -> IO Box
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsDialog a) =>
a -> m Box
dialogGetContentArea Dialog
dialog
  Grid
grid <- IO Grid
forall (m :: * -> *). (HasCallStack, MonadIO m) => m Grid
gridNew

  Label
searchForLabel <- Maybe Text -> IO Label
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Maybe Text -> m Label
labelNew (Text -> Maybe Text
forall a. a -> Maybe a
Just "Search for regex:")
  Grid -> Label -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
containerAdd Grid
grid Label
searchForLabel
  Label -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
widgetShow Label
searchForLabel
  Label -> Int32 -> IO ()
forall (m :: * -> *) o.
(MonadIO m, IsWidget o) =>
o -> Int32 -> m ()
setWidgetMargin Label
searchForLabel 10

  Entry
searchEntry <- IO Entry
forall (m :: * -> *). (HasCallStack, MonadIO m) => m Entry
entryNew
  Grid
-> Entry -> Maybe Label -> PositionType -> Int32 -> Int32 -> IO ()
forall (m :: * -> *) a b c.
(HasCallStack, MonadIO m, IsGrid a, IsWidget b, IsWidget c) =>
a -> b -> Maybe c -> PositionType -> Int32 -> Int32 -> m ()
gridAttachNextTo Grid
grid Entry
searchEntry (Label -> Maybe Label
forall a. a -> Maybe a
Just Label
searchForLabel) PositionType
PositionTypeRight 1 1
  Entry -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
widgetShow Entry
searchEntry
  Entry -> Int32 -> IO ()
forall (m :: * -> *) o.
(MonadIO m, IsWidget o) =>
o -> Int32 -> m ()
setWidgetMargin Entry
searchEntry 10
  -- setWidgetMarginBottom searchEntry 20
  IO SignalHandlerId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO SignalHandlerId -> IO ()) -> IO SignalHandlerId -> IO ()
forall a b. (a -> b) -> a -> b
$
    Entry -> IO () -> IO SignalHandlerId
forall a (m :: * -> *).
(IsEntry a, MonadIO m) =>
a -> IO () -> m SignalHandlerId
onEntryActivate Entry
searchEntry (IO () -> IO SignalHandlerId) -> IO () -> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$
      Dialog -> Int32 -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsDialog a) =>
a -> Int32 -> m ()
dialogResponse Dialog
dialog (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ResponseType -> Int
forall a. Enum a => a -> Int
fromEnum ResponseType
ResponseTypeYes))

  IO Widget -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Widget -> IO ()) -> IO Widget -> IO ()
forall a b. (a -> b) -> a -> b
$
    Dialog -> Text -> Int32 -> IO Widget
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsDialog a) =>
a -> Text -> Int32 -> m Widget
dialogAddButton
      Dialog
dialog
      "Close"
      (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ResponseType -> Int
forall a. Enum a => a -> Int
fromEnum ResponseType
ResponseTypeNo))
  IO Widget -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Widget -> IO ()) -> IO Widget -> IO ()
forall a b. (a -> b) -> a -> b
$
    Dialog -> Text -> Int32 -> IO Widget
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsDialog a) =>
a -> Text -> Int32 -> m Widget
dialogAddButton
      Dialog
dialog
      "Find"
      (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ResponseType -> Int
forall a. Enum a => a -> Int
fromEnum ResponseType
ResponseTypeYes))

  Box -> Grid -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
containerAdd Box
box Grid
grid
  Grid -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
widgetShow Grid
grid
  Dialog -> Maybe Window -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsWindow a, IsWindow b) =>
a -> Maybe b -> m ()
windowSetTransientFor Dialog
dialog Maybe Window
win
  Int32
res <- Dialog -> IO Int32
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsDialog a) =>
a -> m Int32
dialogRun Dialog
dialog

  Text
searchString <- Entry -> IO Text
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsEntry a) =>
a -> m Text
entryGetText Entry
searchEntry
  let maybeSearchString :: Maybe Text
maybeSearchString =
        case Int -> ResponseType
forall a. Enum a => Int -> a
toEnum (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
res) of
          ResponseTypeYes -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
searchString
          _ -> Maybe Text
forall a. Maybe a
Nothing

  Dialog -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
widgetDestroy Dialog
dialog

  Maybe Text -> IO (Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
maybeSearchString

doFind :: TMState -> IO ()
doFind :: TMState -> IO ()
doFind mvarTMState :: TMState
mvarTMState = do
  TMState'
tmState <- TMState -> IO TMState'
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar TMState
mvarTMState
  let app :: Application
app = TMState' -> Application
tmStateApp TMState'
tmState
  Maybe Text
maybeSearchString <- Application -> IO (Maybe Text)
showFindDialog Application
app
  -- putStrLn $ "trying to find: " <> tshow maybeSearchString
  Maybe Terminal
maybeTerminal <- TMState -> IO (Maybe Terminal)
getFocusedTermFromState TMState
mvarTMState
  case (Maybe Text
maybeSearchString, Maybe Terminal
maybeTerminal) of
    (Just searchString :: Text
searchString, Just terminal :: Terminal
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 :: Word32
pcreFlags = 0
      let newRegex :: IO Regex
newRegex =
            Text -> Int64 -> Word32 -> IO Regex
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Text -> Int64 -> Word32 -> m Regex
regexNewForSearch
              Text
searchString
              (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int64) -> Int -> Int64
forall a b. (a -> b) -> a -> b
$ Text -> Int
forall mono. MonoFoldable mono => mono -> Int
length Text
searchString)
              Word32
pcreFlags
      Either Text Regex
eitherRegex <-
        IO (Either Text Regex)
-> (RegexError -> Text -> IO (Either Text Regex))
-> IO (Either Text Regex)
forall a. IO a -> (RegexError -> Text -> IO a) -> IO a
catchRegexError
          ((Regex -> Either Text Regex) -> IO Regex -> IO (Either Text Regex)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Regex -> Either Text Regex
forall a b. b -> Either a b
Right IO Regex
newRegex)
          (\_ errMsg :: Text
errMsg -> Either Text Regex -> IO (Either Text Regex)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Either Text Regex
forall a b. a -> Either a b
Left Text
errMsg))
      case Either Text Regex
eitherRegex of
        Left errMsg :: Text
errMsg -> do
          let msg :: Text
msg = "error when creating regex: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
errMsg
          Handle -> Text -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> Text -> m ()
hPutStrLn Handle
stderr Text
msg
        Right regex :: Regex
regex -> do
          Terminal -> Maybe Regex -> Word32 -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsTerminal a) =>
a -> Maybe Regex -> Word32 -> m ()
terminalSearchSetRegex Terminal
terminal (Regex -> Maybe Regex
forall a. a -> Maybe a
Just Regex
regex) Word32
pcreFlags
          Terminal -> Bool -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsTerminal a) =>
a -> Bool -> m ()
terminalSearchSetWrapAround Terminal
terminal Bool
True
          Bool
_matchFound <- Terminal -> IO Bool
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsTerminal a) =>
a -> m Bool
terminalSearchFindPrevious Terminal
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
          () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    _ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

findAbove :: TMState -> IO ()
findAbove :: TMState -> IO ()
findAbove mvarTMState :: TMState
mvarTMState = do
  Maybe Terminal
maybeTerminal <- TMState -> IO (Maybe Terminal)
getFocusedTermFromState TMState
mvarTMState
  case Maybe Terminal
maybeTerminal of
    Nothing -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just terminal :: Terminal
terminal -> do
      Bool
_matchFound <- Terminal -> IO Bool
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsTerminal a) =>
a -> m Bool
terminalSearchFindPrevious Terminal
terminal
      -- putStrLn $ "was match found: " <> tshow matchFound
      () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

findBelow :: TMState -> IO ()
findBelow :: TMState -> IO ()
findBelow mvarTMState :: TMState
mvarTMState = do
  Maybe Terminal
maybeTerminal <- TMState -> IO (Maybe Terminal)
getFocusedTermFromState TMState
mvarTMState
  case Maybe Terminal
maybeTerminal of
    Nothing -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just terminal :: Terminal
terminal -> do
      Bool
_matchFound <- Terminal -> IO Bool
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsTerminal a) =>
a -> m Bool
terminalSearchFindNext Terminal
terminal
      -- putStrLn $ "was match found: " <> tshow matchFound
      () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

setShowMenuBar :: Application -> Bool -> IO ()
setShowMenuBar :: Application -> Bool -> IO ()
setShowMenuBar app :: Application
app visible :: Bool
visible = do
  IO (Maybe ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe ()) -> IO ()) -> IO (Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ MaybeT IO () -> IO (Maybe ())
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO () -> IO (Maybe ())) -> MaybeT IO () -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ do
    Window
win <- IO (Maybe Window) -> MaybeT IO Window
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe Window) -> MaybeT IO Window)
-> IO (Maybe Window) -> MaybeT IO Window
forall a b. (a -> b) -> a -> b
$ Application -> IO (Maybe Window)
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsApplication a) =>
a -> m (Maybe Window)
applicationGetActiveWindow Application
app
    ApplicationWindow
appWin <- IO (Maybe ApplicationWindow) -> MaybeT IO ApplicationWindow
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe ApplicationWindow) -> MaybeT IO ApplicationWindow)
-> IO (Maybe ApplicationWindow) -> MaybeT IO ApplicationWindow
forall a b. (a -> b) -> a -> b
$ (ManagedPtr ApplicationWindow -> ApplicationWindow)
-> Window -> IO (Maybe ApplicationWindow)
forall o o'.
(HasCallStack, ManagedPtrNewtype o, TypedObject o,
 ManagedPtrNewtype o', TypedObject o', GObject o') =>
(ManagedPtr o' -> o') -> o -> IO (Maybe o')
castTo ManagedPtr ApplicationWindow -> ApplicationWindow
ApplicationWindow Window
win
    IO () -> MaybeT IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> MaybeT IO ()) -> IO () -> MaybeT IO ()
forall a b. (a -> b) -> a -> b
$ ApplicationWindow -> Bool -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsApplicationWindow a) =>
a -> Bool -> m ()
applicationWindowSetShowMenubar ApplicationWindow
appWin Bool
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 :: ComboBoxText -> [(a, Text)] -> IO ()
comboBoxFill comboBox :: ComboBoxText
comboBox = (Element [(a, Text)] -> IO ()) -> [(a, Text)] -> IO ()
forall mono (m :: * -> *).
(MonoFoldable mono, Applicative m) =>
(Element mono -> m ()) -> mono -> m ()
mapM_ (a, Text) -> IO ()
Element [(a, Text)] -> IO ()
go
  where
    go :: (a, Text) -> IO ()
    go :: (a, Text) -> IO ()
go (value :: a
value, textId :: Text
textId) =
      ComboBoxText -> Maybe Text -> Text -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsComboBoxText a) =>
a -> Maybe Text -> Text -> m ()
comboBoxTextAppend ComboBoxText
comboBox (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ a -> Text
forall a. Show a => a -> Text
tshow a
value) Text
textId

-- | Set the current active item in a combobox given an input id.
comboBoxSetActive :: Show a => ComboBoxText -> a -> IO ()
comboBoxSetActive :: ComboBoxText -> a -> IO ()
comboBoxSetActive cb :: ComboBoxText
cb item :: a
item = IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ ComboBoxText -> Maybe Text -> IO Bool
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsComboBox a) =>
a -> Maybe Text -> m Bool
comboBoxSetActiveId ComboBoxText
cb (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ a -> Text
forall a. Show a => a -> Text
tshow a
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 :: ComboBoxText -> [a] -> IO (Maybe a)
comboBoxGetActive cb :: ComboBoxText
cb values :: [a]
values = Maybe Text -> Maybe a
findEnumFromMaybeId (Maybe Text -> Maybe a) -> IO (Maybe Text) -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ComboBoxText -> IO (Maybe Text)
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsComboBox a) =>
a -> m (Maybe Text)
comboBoxGetActiveId ComboBoxText
cb
  where
    findEnumFromMaybeId :: Maybe Text -> Maybe a
    findEnumFromMaybeId :: Maybe Text -> Maybe a
findEnumFromMaybeId maybeId :: Maybe Text
maybeId = Maybe Text
maybeId Maybe Text -> (Text -> Maybe a) -> Maybe a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe a
findEnumFromId

    findEnumFromId :: Text -> Maybe a
    findEnumFromId :: Text -> Maybe a
findEnumFromId label :: Text
label = (Element [a] -> Bool) -> [a] -> Maybe (Element [a])
forall seq.
SemiSequence seq =>
(Element seq -> Bool) -> seq -> Maybe (Element seq)
find (\x :: Element [a]
x -> a -> Text
forall a. Show a => a -> Text
tshow a
Element [a]
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
label) [a]
values

applyNewPreferences :: TMState -> IO ()
applyNewPreferences :: TMState -> IO ()
applyNewPreferences mvarTMState :: TMState
mvarTMState = do
  TMState'
tmState <- TMState -> IO TMState'
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar TMState
mvarTMState
  let appWin :: ApplicationWindow
appWin = TMState'
tmState TMState'
-> Getting ApplicationWindow TMState' ApplicationWindow
-> ApplicationWindow
forall s a. s -> Getting a s a -> a
^. Getting ApplicationWindow TMState' ApplicationWindow
Lens' TMState' ApplicationWindow
lensTMStateAppWin
      config :: TMConfig
config = TMState'
tmState TMState' -> Getting TMConfig TMState' TMConfig -> TMConfig
forall s a. s -> Getting a s a -> a
^. Getting TMConfig TMState' TMConfig
Lens' TMState' TMConfig
lensTMStateConfig
      notebook :: Notebook
notebook = TMState'
tmState TMState' -> Getting TMNotebook TMState' TMNotebook -> TMNotebook
forall s a. s -> Getting a s a -> a
^. Getting TMNotebook TMState' TMNotebook
Lens' TMState' TMNotebook
lensTMStateNotebook TMNotebook -> Getting Notebook TMNotebook Notebook -> Notebook
forall s a. s -> Getting a s a -> a
^. Getting Notebook TMNotebook Notebook
Lens' TMNotebook Notebook
lensTMNotebook
      tabFocusList :: FocusList TMNotebookTab
tabFocusList = TMState'
tmState TMState' -> Getting TMNotebook TMState' TMNotebook -> TMNotebook
forall s a. s -> Getting a s a -> a
^. Getting TMNotebook TMState' TMNotebook
Lens' TMState' TMNotebook
lensTMStateNotebook TMNotebook
-> ((FocusList TMNotebookTab
     -> Const (FocusList TMNotebookTab) (FocusList TMNotebookTab))
    -> TMNotebook -> Const (FocusList TMNotebookTab) TMNotebook)
-> FocusList TMNotebookTab
forall s a. s -> Getting a s a -> a
^. (FocusList TMNotebookTab
 -> Const (FocusList TMNotebookTab) (FocusList TMNotebookTab))
-> TMNotebook -> Const (FocusList TMNotebookTab) TMNotebook
Lens' TMNotebook (FocusList TMNotebookTab)
lensTMNotebookTabs
      showMenu :: Bool
showMenu = TMConfig
config  TMConfig
-> Getting ConfigOptions TMConfig ConfigOptions -> ConfigOptions
forall s a. s -> Getting a s a -> a
^. Getting ConfigOptions TMConfig ConfigOptions
Lens' TMConfig ConfigOptions
lensOptions ConfigOptions
-> ((Bool -> Const Bool Bool)
    -> ConfigOptions -> Const Bool ConfigOptions)
-> Bool
forall s a. s -> Getting a s a -> a
^. (Bool -> Const Bool Bool)
-> ConfigOptions -> Const Bool ConfigOptions
Lens' ConfigOptions Bool
lensShowMenu
  ApplicationWindow -> Bool -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsApplicationWindow a) =>
a -> Bool -> m ()
applicationWindowSetShowMenubar ApplicationWindow
appWin Bool
showMenu
  TMConfig -> Notebook -> IO ()
setShowTabs TMConfig
config Notebook
notebook
  -- Sets the remaining preferences to each tab
  (Element (FocusList TMNotebookTab) -> IO ())
-> FocusList TMNotebookTab -> IO ()
forall mono m.
(MonoFoldable mono, Monoid m) =>
(Element mono -> m) -> mono -> m
foldMap (TMState -> TMNotebookTab -> IO ()
applyNewPreferencesToTab TMState
mvarTMState) FocusList TMNotebookTab
tabFocusList

applyNewPreferencesToTab :: TMState -> TMNotebookTab -> IO ()
applyNewPreferencesToTab :: TMState -> TMNotebookTab -> IO ()
applyNewPreferencesToTab mvarTMState :: TMState
mvarTMState tab :: TMNotebookTab
tab = do
  TMState'
tmState <- TMState -> IO TMState'
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar TMState
mvarTMState
  let fontDesc :: FontDescription
fontDesc = TMState'
tmState TMState'
-> Getting FontDescription TMState' FontDescription
-> FontDescription
forall s a. s -> Getting a s a -> a
^. Getting FontDescription TMState' FontDescription
Lens' TMState' FontDescription
lensTMStateFontDesc
      term :: Terminal
term = TMNotebookTab
tab TMNotebookTab -> Getting TMTerm TMNotebookTab TMTerm -> TMTerm
forall s a. s -> Getting a s a -> a
^. Getting TMTerm TMNotebookTab TMTerm
Lens' TMNotebookTab TMTerm
lensTMNotebookTabTerm TMTerm
-> ((Terminal -> Const Terminal Terminal)
    -> TMTerm -> Const Terminal TMTerm)
-> Terminal
forall s a. s -> Getting a s a -> a
^. (Terminal -> Const Terminal Terminal)
-> TMTerm -> Const Terminal TMTerm
Lens' TMTerm Terminal
lensTerm
      scrolledWin :: ScrolledWindow
scrolledWin = TMNotebookTab
tab TMNotebookTab
-> Getting ScrolledWindow TMNotebookTab ScrolledWindow
-> ScrolledWindow
forall s a. s -> Getting a s a -> a
^. Getting ScrolledWindow TMNotebookTab ScrolledWindow
Lens' TMNotebookTab ScrolledWindow
lensTMNotebookTabTermContainer
      options :: ConfigOptions
options = TMState'
tmState TMState' -> Getting TMConfig TMState' TMConfig -> TMConfig
forall s a. s -> Getting a s a -> a
^. Getting TMConfig TMState' TMConfig
Lens' TMState' TMConfig
lensTMStateConfig TMConfig
-> Getting ConfigOptions TMConfig ConfigOptions -> ConfigOptions
forall s a. s -> Getting a s a -> a
^. Getting ConfigOptions TMConfig ConfigOptions
Lens' TMConfig ConfigOptions
lensOptions
  Terminal -> Maybe FontDescription -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsTerminal a) =>
a -> Maybe FontDescription -> m ()
terminalSetFont Terminal
term (FontDescription -> Maybe FontDescription
forall a. a -> Maybe a
Just FontDescription
fontDesc)
  Terminal -> CursorBlinkMode -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsTerminal a) =>
a -> CursorBlinkMode -> m ()
terminalSetCursorBlinkMode Terminal
term (ConfigOptions
options ConfigOptions
-> Getting CursorBlinkMode ConfigOptions CursorBlinkMode
-> CursorBlinkMode
forall s a. s -> Getting a s a -> a
^. Getting CursorBlinkMode ConfigOptions CursorBlinkMode
Lens' ConfigOptions CursorBlinkMode
lensCursorBlinkMode)
  Terminal -> Text -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsTerminal a) =>
a -> Text -> m ()
terminalSetWordCharExceptions Terminal
term (ConfigOptions
options ConfigOptions -> Getting Text ConfigOptions Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text ConfigOptions Text
Lens' ConfigOptions Text
lensWordCharExceptions)
  Terminal -> CLong -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsTerminal a) =>
a -> CLong -> m ()
terminalSetScrollbackLines Terminal
term (Integer -> CLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ConfigOptions
options ConfigOptions -> Getting Integer ConfigOptions Integer -> Integer
forall s a. s -> Getting a s a -> a
^. Getting Integer ConfigOptions Integer
Lens' ConfigOptions Integer
lensScrollbackLen))
  let vScrollbarPolicy :: PolicyType
vScrollbarPolicy = ShowScrollbar -> PolicyType
showScrollbarToPolicy (ConfigOptions
options ConfigOptions
-> Getting ShowScrollbar ConfigOptions ShowScrollbar
-> ShowScrollbar
forall s a. s -> Getting a s a -> a
^. Getting ShowScrollbar ConfigOptions ShowScrollbar
Lens' ConfigOptions ShowScrollbar
lensShowScrollbar)
  ScrolledWindow -> PolicyType -> PolicyType -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsScrolledWindow a) =>
a -> PolicyType -> PolicyType -> m ()
scrolledWindowSetPolicy ScrolledWindow
scrolledWin PolicyType
PolicyTypeAutomatic PolicyType
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 :: TMState -> IO ()
showPreferencesDialog mvarTMState :: TMState
mvarTMState = do
  -- Get app out of mvar
  TMState'
tmState <- TMState -> IO TMState'
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar TMState
mvarTMState
  let app :: Application
app = TMState'
tmState TMState' -> Getting Application TMState' Application -> Application
forall s a. s -> Getting a s a -> a
^. Getting Application TMState' Application
Lens' TMState' Application
lensTMStateApp

  -- Create the preference dialog and get some widgets
  Builder
preferencesBuilder <-
    Text -> Int64 -> IO Builder
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Text -> Int64 -> m Builder
builderNewFromString Text
preferencesText (Int64 -> IO Builder) -> Int64 -> IO Builder
forall a b. (a -> b) -> a -> b
$ Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Text -> Int
forall mono. MonoFoldable mono => mono -> Int
length Text
preferencesText)
  Dialog
preferencesDialog <-
    Builder -> Text -> (ManagedPtr Dialog -> Dialog) -> IO Dialog
forall o.
GObject o =>
Builder -> Text -> (ManagedPtr o -> o) -> IO o
objFromBuildUnsafe Builder
preferencesBuilder "preferences" ManagedPtr Dialog -> Dialog
Dialog
  CheckButton
confirmExitCheckButton <-
    Builder
-> Text
-> (ManagedPtr CheckButton -> CheckButton)
-> IO CheckButton
forall o.
GObject o =>
Builder -> Text -> (ManagedPtr o -> o) -> IO o
objFromBuildUnsafe Builder
preferencesBuilder "confirmExit" ManagedPtr CheckButton -> CheckButton
CheckButton
  CheckButton
showMenuCheckButton <-
    Builder
-> Text
-> (ManagedPtr CheckButton -> CheckButton)
-> IO CheckButton
forall o.
GObject o =>
Builder -> Text -> (ManagedPtr o -> o) -> IO o
objFromBuildUnsafe Builder
preferencesBuilder "showMenu" ManagedPtr CheckButton -> CheckButton
CheckButton
  EntryBuffer
wordCharExceptionsEntryBuffer <-
    Builder -> Text -> (ManagedPtr Entry -> Entry) -> IO Entry
forall o.
GObject o =>
Builder -> Text -> (ManagedPtr o -> o) -> IO o
objFromBuildUnsafe Builder
preferencesBuilder "wordCharExceptions" ManagedPtr Entry -> Entry
Entry IO Entry -> (Entry -> IO EntryBuffer) -> IO EntryBuffer
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
      Entry -> IO EntryBuffer
forall (m :: * -> *) o.
(MonadIO m, IsEntry o) =>
o -> m EntryBuffer
getEntryBuffer
  FontButton
fontButton <- Builder
-> Text -> (ManagedPtr FontButton -> FontButton) -> IO FontButton
forall o.
GObject o =>
Builder -> Text -> (ManagedPtr o -> o) -> IO o
objFromBuildUnsafe Builder
preferencesBuilder "font" ManagedPtr FontButton -> FontButton
FontButton
  ComboBoxText
showScrollbarComboBoxText <-
    Builder
-> Text
-> (ManagedPtr ComboBoxText -> ComboBoxText)
-> IO ComboBoxText
forall o.
GObject o =>
Builder -> Text -> (ManagedPtr o -> o) -> IO o
objFromBuildUnsafe Builder
preferencesBuilder "showScrollbar" ManagedPtr ComboBoxText -> ComboBoxText
ComboBoxText
  ComboBoxText -> [(ShowScrollbar, Text)] -> IO ()
forall a. Show a => ComboBoxText -> [(a, Text)] -> IO ()
comboBoxFill
    ComboBoxText
showScrollbarComboBoxText
    [ (ShowScrollbar
ShowScrollbarNever, "Never")
    , (ShowScrollbar
ShowScrollbarAlways, "Always")
    , (ShowScrollbar
ShowScrollbarIfNeeded, "If needed")
    ]
  ComboBoxText
showTabBarComboBoxText <-
    Builder
-> Text
-> (ManagedPtr ComboBoxText -> ComboBoxText)
-> IO ComboBoxText
forall o.
GObject o =>
Builder -> Text -> (ManagedPtr o -> o) -> IO o
objFromBuildUnsafe Builder
preferencesBuilder "showTabBar" ManagedPtr ComboBoxText -> ComboBoxText
ComboBoxText
  ComboBoxText -> [(ShowTabBar, Text)] -> IO ()
forall a. Show a => ComboBoxText -> [(a, Text)] -> IO ()
comboBoxFill
    ComboBoxText
showTabBarComboBoxText
    [ (ShowTabBar
ShowTabBarNever, "Never")
    , (ShowTabBar
ShowTabBarAlways, "Always")
    , (ShowTabBar
ShowTabBarIfNeeded, "If needed")
    ]
  ComboBoxText
cursorBlinkModeComboBoxText <-
    Builder
-> Text
-> (ManagedPtr ComboBoxText -> ComboBoxText)
-> IO ComboBoxText
forall o.
GObject o =>
Builder -> Text -> (ManagedPtr o -> o) -> IO o
objFromBuildUnsafe Builder
preferencesBuilder "cursorBlinkMode" ManagedPtr ComboBoxText -> ComboBoxText
ComboBoxText
  ComboBoxText -> [(CursorBlinkMode, Text)] -> IO ()
forall a. Show a => ComboBoxText -> [(a, Text)] -> IO ()
comboBoxFill
    ComboBoxText
cursorBlinkModeComboBoxText
    [ (CursorBlinkMode
CursorBlinkModeSystem, "System")
    , (CursorBlinkMode
CursorBlinkModeOn, "On")
    , (CursorBlinkMode
CursorBlinkModeOff, "Off")
    ]
  SpinButton
scrollbackLenSpinButton <-
    Builder
-> Text -> (ManagedPtr SpinButton -> SpinButton) -> IO SpinButton
forall o.
GObject o =>
Builder -> Text -> (ManagedPtr o -> o) -> IO o
objFromBuildUnsafe Builder
preferencesBuilder "scrollbackLen" ManagedPtr SpinButton -> SpinButton
SpinButton
  Double
-> Double -> Double -> Double -> Double -> Double -> IO Adjustment
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Double
-> Double -> Double -> Double -> Double -> Double -> m Adjustment
adjustmentNew 0 0 (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
forall a. Bounded a => a
maxBound :: Int)) 1 10 0 IO Adjustment -> (Adjustment -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    SpinButton -> Adjustment -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsSpinButton a, IsAdjustment b) =>
a -> b -> m ()
spinButtonSetAdjustment SpinButton
scrollbackLenSpinButton
  Label
warningLabel <- Builder -> Text -> (ManagedPtr Label -> Label) -> IO Label
forall o.
GObject o =>
Builder -> Text -> (ManagedPtr o -> o) -> IO o
objFromBuildUnsafe Builder
preferencesBuilder "warning" ManagedPtr Label -> Label
Label

  -- We show the warning label only if the user has launched termonad with a
  -- termonad.hs file
  FilePath
executablePath <- IO FilePath
getExecutablePath
  let hasTermonadHs :: Bool
hasTermonadHs = FilePath -> FilePath
takeFileName FilePath
executablePath FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "termonad-linux-x86_64"
  Label -> Bool -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> Bool -> m ()
widgetSetVisible Label
warningLabel Bool
hasTermonadHs

  -- Make the dialog modal
  Maybe Window
maybeWin <- Application -> IO (Maybe Window)
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsApplication a) =>
a -> m (Maybe Window)
applicationGetActiveWindow Application
app
  Dialog -> Maybe Window -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsWindow a, IsWindow b) =>
a -> Maybe b -> m ()
windowSetTransientFor Dialog
preferencesDialog Maybe Window
maybeWin

  -- Init with current state
  FontButton -> FontDescription -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsFontChooser a) =>
a -> FontDescription -> m ()
fontChooserSetFontDesc FontButton
fontButton (TMState'
tmState TMState'
-> Getting FontDescription TMState' FontDescription
-> FontDescription
forall s a. s -> Getting a s a -> a
^. Getting FontDescription TMState' FontDescription
Lens' TMState' FontDescription
lensTMStateFontDesc)
  let options :: ConfigOptions
options = TMState'
tmState TMState'
-> Getting ConfigOptions TMState' ConfigOptions -> ConfigOptions
forall s a. s -> Getting a s a -> a
^. (TMConfig -> Const ConfigOptions TMConfig)
-> TMState' -> Const ConfigOptions TMState'
Lens' TMState' TMConfig
lensTMStateConfig ((TMConfig -> Const ConfigOptions TMConfig)
 -> TMState' -> Const ConfigOptions TMState')
-> Getting ConfigOptions TMConfig ConfigOptions
-> Getting ConfigOptions TMState' ConfigOptions
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Getting ConfigOptions TMConfig ConfigOptions
Lens' TMConfig ConfigOptions
lensOptions
  ComboBoxText -> ShowScrollbar -> IO ()
forall a. Show a => ComboBoxText -> a -> IO ()
comboBoxSetActive ComboBoxText
showScrollbarComboBoxText (ShowScrollbar -> IO ()) -> ShowScrollbar -> IO ()
forall a b. (a -> b) -> a -> b
$ ConfigOptions
options ConfigOptions
-> Getting ShowScrollbar ConfigOptions ShowScrollbar
-> ShowScrollbar
forall s a. s -> Getting a s a -> a
^. Getting ShowScrollbar ConfigOptions ShowScrollbar
Lens' ConfigOptions ShowScrollbar
lensShowScrollbar
  ComboBoxText -> ShowTabBar -> IO ()
forall a. Show a => ComboBoxText -> a -> IO ()
comboBoxSetActive ComboBoxText
showTabBarComboBoxText (ShowTabBar -> IO ()) -> ShowTabBar -> IO ()
forall a b. (a -> b) -> a -> b
$ ConfigOptions
options ConfigOptions
-> Getting ShowTabBar ConfigOptions ShowTabBar -> ShowTabBar
forall s a. s -> Getting a s a -> a
^. Getting ShowTabBar ConfigOptions ShowTabBar
Lens' ConfigOptions ShowTabBar
lensShowTabBar
  ComboBoxText -> CursorBlinkMode -> IO ()
forall a. Show a => ComboBoxText -> a -> IO ()
comboBoxSetActive ComboBoxText
cursorBlinkModeComboBoxText (CursorBlinkMode -> IO ()) -> CursorBlinkMode -> IO ()
forall a b. (a -> b) -> a -> b
$ ConfigOptions
options ConfigOptions
-> Getting CursorBlinkMode ConfigOptions CursorBlinkMode
-> CursorBlinkMode
forall s a. s -> Getting a s a -> a
^. Getting CursorBlinkMode ConfigOptions CursorBlinkMode
Lens' ConfigOptions CursorBlinkMode
lensCursorBlinkMode
  SpinButton -> Double -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsSpinButton a) =>
a -> Double -> m ()
spinButtonSetValue
    SpinButton
scrollbackLenSpinButton
    (Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Double) -> Integer -> Double
forall a b. (a -> b) -> a -> b
$ ConfigOptions
options ConfigOptions -> Getting Integer ConfigOptions Integer -> Integer
forall s a. s -> Getting a s a -> a
^. Getting Integer ConfigOptions Integer
Lens' ConfigOptions Integer
lensScrollbackLen)
  CheckButton -> Bool -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsToggleButton a) =>
a -> Bool -> m ()
toggleButtonSetActive CheckButton
confirmExitCheckButton (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ ConfigOptions
options ConfigOptions
-> ((Bool -> Const Bool Bool)
    -> ConfigOptions -> Const Bool ConfigOptions)
-> Bool
forall s a. s -> Getting a s a -> a
^. (Bool -> Const Bool Bool)
-> ConfigOptions -> Const Bool ConfigOptions
Lens' ConfigOptions Bool
lensConfirmExit
  CheckButton -> Bool -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsToggleButton a) =>
a -> Bool -> m ()
toggleButtonSetActive CheckButton
showMenuCheckButton (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ ConfigOptions
options ConfigOptions
-> ((Bool -> Const Bool Bool)
    -> ConfigOptions -> Const Bool ConfigOptions)
-> Bool
forall s a. s -> Getting a s a -> a
^. (Bool -> Const Bool Bool)
-> ConfigOptions -> Const Bool ConfigOptions
Lens' ConfigOptions Bool
lensShowMenu
  EntryBuffer -> Text -> Int32 -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsEntryBuffer a) =>
a -> Text -> Int32 -> m ()
entryBufferSetText
    EntryBuffer
wordCharExceptionsEntryBuffer
    (ConfigOptions
options ConfigOptions -> Getting Text ConfigOptions Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text ConfigOptions Text
Lens' ConfigOptions Text
lensWordCharExceptions)
    (-1)

  -- Run dialog then close
  Int32
res <- Dialog -> IO Int32
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsDialog a) =>
a -> m Int32
dialogRun Dialog
preferencesDialog

  -- When closing the dialog get the new settings
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int -> ResponseType
forall a. Enum a => Int -> a
toEnum (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
res) ResponseType -> ResponseType -> Bool
forall a. Eq a => a -> a -> Bool
== ResponseType
ResponseTypeAccept) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Maybe FontDescription
maybeFontDesc <- FontButton -> IO (Maybe FontDescription)
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsFontChooser a) =>
a -> m (Maybe FontDescription)
fontChooserGetFontDesc FontButton
fontButton
    Maybe FontConfig
maybeFontConfig <-
      (Maybe (Maybe FontConfig) -> Maybe FontConfig)
-> IO (Maybe (Maybe FontConfig)) -> IO (Maybe FontConfig)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Maybe (Maybe FontConfig) -> Maybe FontConfig
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (Maybe (Maybe FontConfig)) -> IO (Maybe FontConfig))
-> IO (Maybe (Maybe FontConfig)) -> IO (Maybe FontConfig)
forall a b. (a -> b) -> a -> b
$ (FontDescription -> IO (Maybe FontConfig))
-> Maybe FontDescription -> IO (Maybe (Maybe FontConfig))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FontDescription -> IO (Maybe FontConfig)
fontConfigFromFontDescription Maybe FontDescription
maybeFontDesc
    Maybe ShowScrollbar
maybeShowScrollbar <-
      ComboBoxText -> [ShowScrollbar] -> IO (Maybe ShowScrollbar)
forall a. (Show a, Enum a) => ComboBoxText -> [a] -> IO (Maybe a)
comboBoxGetActive ComboBoxText
showScrollbarComboBoxText [Item [ShowScrollbar]
ShowScrollbar
ShowScrollbarNever ..]
    Maybe ShowTabBar
maybeShowTabBar <-
      ComboBoxText -> [ShowTabBar] -> IO (Maybe ShowTabBar)
forall a. (Show a, Enum a) => ComboBoxText -> [a] -> IO (Maybe a)
comboBoxGetActive ComboBoxText
showTabBarComboBoxText [Item [ShowTabBar]
ShowTabBar
ShowTabBarNever ..]
    Maybe CursorBlinkMode
maybeCursorBlinkMode <-
      ComboBoxText -> [CursorBlinkMode] -> IO (Maybe CursorBlinkMode)
forall a. (Show a, Enum a) => ComboBoxText -> [a] -> IO (Maybe a)
comboBoxGetActive ComboBoxText
cursorBlinkModeComboBoxText [Item [CursorBlinkMode]
CursorBlinkMode
CursorBlinkModeSystem ..]
    Integer
scrollbackLen <-
      Int32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Integer) -> IO Int32 -> IO Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpinButton -> IO Int32
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsSpinButton a) =>
a -> m Int32
spinButtonGetValueAsInt SpinButton
scrollbackLenSpinButton
    Bool
confirmExit <- CheckButton -> IO Bool
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsToggleButton a) =>
a -> m Bool
toggleButtonGetActive CheckButton
confirmExitCheckButton
    Bool
showMenu <- CheckButton -> IO Bool
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsToggleButton a) =>
a -> m Bool
toggleButtonGetActive CheckButton
showMenuCheckButton
    Text
wordCharExceptions <- EntryBuffer -> IO Text
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsEntryBuffer a) =>
a -> m Text
entryBufferGetText EntryBuffer
wordCharExceptionsEntryBuffer

    -- Apply the changes to mvarTMState
    TMState -> (TMState' -> IO TMState') -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
MVar a -> (a -> m a) -> m ()
modifyMVar_ TMState
mvarTMState ((TMState' -> IO TMState') -> IO ())
-> (TMState' -> IO TMState') -> IO ()
forall a b. (a -> b) -> a -> b
$ TMState' -> IO TMState'
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      (TMState' -> IO TMState')
-> (TMState' -> TMState') -> TMState' -> IO TMState'
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ASetter TMState' TMState' FontDescription FontDescription
-> (FontDescription -> FontDescription) -> TMState' -> TMState'
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter TMState' TMState' FontDescription FontDescription
Lens' TMState' FontDescription
lensTMStateFontDesc (FontDescription -> Maybe FontDescription -> FontDescription
forall a. a -> Maybe a -> a
`fromMaybe` Maybe FontDescription
maybeFontDesc)
      (TMState' -> TMState')
-> (TMState' -> TMState') -> TMState' -> TMState'
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ASetter TMState' TMState' ConfigOptions ConfigOptions
-> (ConfigOptions -> ConfigOptions) -> TMState' -> TMState'
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((TMConfig -> Identity TMConfig) -> TMState' -> Identity TMState'
Lens' TMState' TMConfig
lensTMStateConfig ((TMConfig -> Identity TMConfig) -> TMState' -> Identity TMState')
-> ((ConfigOptions -> Identity ConfigOptions)
    -> TMConfig -> Identity TMConfig)
-> ASetter TMState' TMState' ConfigOptions ConfigOptions
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (ConfigOptions -> Identity ConfigOptions)
-> TMConfig -> Identity TMConfig
Lens' TMConfig ConfigOptions
lensOptions)
        ( ASetter ConfigOptions ConfigOptions Bool Bool
-> Bool -> ConfigOptions -> ConfigOptions
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter ConfigOptions ConfigOptions Bool Bool
Lens' ConfigOptions Bool
lensConfirmExit Bool
confirmExit
        (ConfigOptions -> ConfigOptions)
-> (ConfigOptions -> ConfigOptions)
-> ConfigOptions
-> ConfigOptions
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ASetter ConfigOptions ConfigOptions Bool Bool
-> Bool -> ConfigOptions -> ConfigOptions
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter ConfigOptions ConfigOptions Bool Bool
Lens' ConfigOptions Bool
lensShowMenu Bool
showMenu
        (ConfigOptions -> ConfigOptions)
-> (ConfigOptions -> ConfigOptions)
-> ConfigOptions
-> ConfigOptions
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ASetter ConfigOptions ConfigOptions Text Text
-> Text -> ConfigOptions -> ConfigOptions
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter ConfigOptions ConfigOptions Text Text
Lens' ConfigOptions Text
lensWordCharExceptions Text
wordCharExceptions
        (ConfigOptions -> ConfigOptions)
-> (ConfigOptions -> ConfigOptions)
-> ConfigOptions
-> ConfigOptions
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ASetter ConfigOptions ConfigOptions FontConfig FontConfig
-> (FontConfig -> FontConfig) -> ConfigOptions -> ConfigOptions
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter ConfigOptions ConfigOptions FontConfig FontConfig
Lens' ConfigOptions FontConfig
lensFontConfig (FontConfig -> Maybe FontConfig -> FontConfig
forall a. a -> Maybe a -> a
`fromMaybe` Maybe FontConfig
maybeFontConfig)
        (ConfigOptions -> ConfigOptions)
-> (ConfigOptions -> ConfigOptions)
-> ConfigOptions
-> ConfigOptions
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ASetter ConfigOptions ConfigOptions Integer Integer
-> Integer -> ConfigOptions -> ConfigOptions
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter ConfigOptions ConfigOptions Integer Integer
Lens' ConfigOptions Integer
lensScrollbackLen Integer
scrollbackLen
        (ConfigOptions -> ConfigOptions)
-> (ConfigOptions -> ConfigOptions)
-> ConfigOptions
-> ConfigOptions
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ASetter ConfigOptions ConfigOptions ShowScrollbar ShowScrollbar
-> (ShowScrollbar -> ShowScrollbar)
-> ConfigOptions
-> ConfigOptions
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter ConfigOptions ConfigOptions ShowScrollbar ShowScrollbar
Lens' ConfigOptions ShowScrollbar
lensShowScrollbar (ShowScrollbar -> Maybe ShowScrollbar -> ShowScrollbar
forall a. a -> Maybe a -> a
`fromMaybe` Maybe ShowScrollbar
maybeShowScrollbar)
        (ConfigOptions -> ConfigOptions)
-> (ConfigOptions -> ConfigOptions)
-> ConfigOptions
-> ConfigOptions
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ASetter ConfigOptions ConfigOptions ShowTabBar ShowTabBar
-> (ShowTabBar -> ShowTabBar) -> ConfigOptions -> ConfigOptions
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter ConfigOptions ConfigOptions ShowTabBar ShowTabBar
Lens' ConfigOptions ShowTabBar
lensShowTabBar (ShowTabBar -> Maybe ShowTabBar -> ShowTabBar
forall a. a -> Maybe a -> a
`fromMaybe` Maybe ShowTabBar
maybeShowTabBar)
        (ConfigOptions -> ConfigOptions)
-> (ConfigOptions -> ConfigOptions)
-> ConfigOptions
-> ConfigOptions
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ASetter ConfigOptions ConfigOptions CursorBlinkMode CursorBlinkMode
-> (CursorBlinkMode -> CursorBlinkMode)
-> ConfigOptions
-> ConfigOptions
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter ConfigOptions ConfigOptions CursorBlinkMode CursorBlinkMode
Lens' ConfigOptions CursorBlinkMode
lensCursorBlinkMode (CursorBlinkMode -> Maybe CursorBlinkMode -> CursorBlinkMode
forall a. a -> Maybe a -> a
`fromMaybe` Maybe CursorBlinkMode
maybeCursorBlinkMode)
        )

    -- Save the changes to the preferences files
    TMState -> (TMState' -> IO ()) -> IO ()
forall (m :: * -> *) a b.
MonadUnliftIO m =>
MVar a -> (a -> m b) -> m b
withMVar TMState
mvarTMState ((TMState' -> IO ()) -> IO ()) -> (TMState' -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ TMConfig -> IO ()
saveToPreferencesFile (TMConfig -> IO ()) -> (TMState' -> TMConfig) -> TMState' -> IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Getting TMConfig TMState' TMConfig -> TMState' -> TMConfig
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting TMConfig TMState' TMConfig
Lens' TMState' TMConfig
lensTMStateConfig

    -- Update the app with new settings
    TMState -> IO ()
applyNewPreferences TMState
mvarTMState

  Dialog -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
widgetDestroy Dialog
preferencesDialog

appStartup :: Application -> IO ()
appStartup :: Application -> IO ()
appStartup _app :: Application
_app = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
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 -> IO ()
start tmConfig :: TMConfig
tmConfig = do
  -- app <- appNew (Just "haskell.termonad") [ApplicationFlagsFlagsNone]
  -- Make sure the application is not unique, so we can open multiple copies of it.
  Application
app <- Maybe Text -> [ApplicationFlags] -> IO Application
forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadFail m) =>
Maybe Text -> [ApplicationFlags] -> m Application
appNew Maybe Text
forall a. Maybe a
Nothing [Item [ApplicationFlags]
ApplicationFlags
ApplicationFlagsFlagsNone]
  IO SignalHandlerId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO SignalHandlerId -> IO ()) -> IO SignalHandlerId -> IO ()
forall a b. (a -> b) -> a -> b
$ Application -> IO () -> IO SignalHandlerId
forall a (m :: * -> *).
(IsApplication a, MonadIO m) =>
a -> IO () -> m SignalHandlerId
onApplicationStartup Application
app (Application -> IO ()
appStartup Application
app)
  IO SignalHandlerId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO SignalHandlerId -> IO ()) -> IO SignalHandlerId -> IO ()
forall a b. (a -> b) -> a -> b
$ Application -> IO () -> IO SignalHandlerId
forall a (m :: * -> *).
(IsApplication a, MonadIO m) =>
a -> IO () -> m SignalHandlerId
onApplicationActivate Application
app (TMConfig -> Application -> IO ()
appActivate TMConfig
tmConfig Application
app)
  IO Int32 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int32 -> IO ()) -> IO Int32 -> IO ()
forall a b. (a -> b) -> a -> b
$ Application -> Maybe [FilePath] -> IO Int32
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsApplication a) =>
a -> Maybe [FilePath] -> m Int32
applicationRun Application
app Maybe [FilePath]
forall a. Maybe a
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 -> IO ()
defaultMain tmConfig :: TMConfig
tmConfig = do
  let params :: Params (TMConfig, FilePath)
params =
        Params Any
forall cfgType. Params cfgType
defaultParams
          { projectName :: FilePath
projectName = "termonad"
          , showError :: (TMConfig, FilePath) -> FilePath -> (TMConfig, FilePath)
showError = \(cfg :: TMConfig
cfg, oldErrs :: FilePath
oldErrs) newErr :: FilePath
newErr -> (TMConfig
cfg, FilePath
oldErrs FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> "\n" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
newErr)
          , realMain :: (TMConfig, FilePath) -> IO ()
realMain = \(cfg :: TMConfig
cfg, errs :: FilePath
errs) -> Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putStrLn ([Element Text] -> Text
forall seq. IsSequence seq => [Element seq] -> seq
pack FilePath
[Element Text]
errs) IO () -> IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> TMConfig -> IO ()
start TMConfig
cfg
          }
  Either IOError ()
eitherRes <- IO () -> IO (Either IOError ())
forall a. IO a -> IO (Either IOError a)
tryIOError (IO () -> IO (Either IOError ()))
-> IO () -> IO (Either IOError ())
forall a b. (a -> b) -> a -> b
$ Params (TMConfig, FilePath) -> (TMConfig, FilePath) -> IO ()
forall cfgType. Params cfgType -> cfgType -> IO ()
wrapMain Params (TMConfig, FilePath)
params (TMConfig
tmConfig, "")
  case Either IOError ()
eitherRes of
    Left ioErr :: IOError
ioErr
      | IOError -> IOErrorType
ioeGetErrorType IOError
ioErr IOErrorType -> IOErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== IOErrorType
doesNotExistErrorType Bool -> Bool -> Bool
&& IOError -> Maybe FilePath
ioeGetFileName IOError
ioErr Maybe FilePath -> Maybe FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just "ghc" -> do
          Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
            "Could not find ghc on your PATH.  Ignoring your termonad.hs " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
            "configuration file and running termonad with default settings."
          TMConfig -> IO ()
start TMConfig
tmConfig
      | Bool
otherwise -> do
          Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ "IO error occurred when trying to run termonad:"
          IOError -> IO ()
forall a (m :: * -> *). (Show a, MonadIO m) => a -> m ()
print IOError
ioErr
          Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putStrLn "Don't know how to recover.  Exiting."
    Right _ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()