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
  , terminalSetBoldIsBright
  , terminalSetCursorBlinkMode
  , terminalSetFont
  , terminalSetScrollbackLines
  , terminalSetWordCharExceptions
  , terminalSetAllowBold
  )
import System.Environment (getExecutablePath)
import System.FilePath (takeFileName)

import Paths_termonad (getDataFileName)
import Termonad.Gtk (appNew, objFromBuildUnsafe, terminalSetEnableSixelIfExists)
import Termonad.Keys (handleKeyPress)
import Termonad.Lenses
  ( lensBoldIsBright
  , lensEnableSixel
  , lensAllowBold
  , 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
  , termNextPage
  , termPrevPage
  , termExitFocused
  , setShowTabs
  , showScrollbarToPolicy
  )
import Termonad.Types
  ( ConfigOptions(..)
  , 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
  maybeScreen <- IO (Maybe Screen)
forall (m :: * -> *). (HasCallStack, MonadIO m) => m (Maybe Screen)
screenGetDefault
  case maybeScreen of
    Maybe Screen
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just Screen
screen -> do
      cssProvider <- IO CssProvider
forall (m :: * -> *). (HasCallStack, MonadIO m) => m CssProvider
cssProviderNew
      let (textLines :: [Text]) =
            [
              "scrollbar {"
            -- , "  -GtkRange-slider-width: 200px;"
            -- , "  -GtkRange-stepper-size: 200px;"
            -- , "  border-width: 200px;"
            , "  background-color: #aaaaaa;"
            -- , "  color: #ff0000;"
            -- , "  min-width: 4px;"
            , "}"
            -- , "scrollbar trough {"
            -- , "  -GtkRange-slider-width: 200px;"
            -- , "  -GtkRange-stepper-size: 200px;"
            -- , "  border-width: 200px;"
            -- , "  background-color: #00ff00;"
            -- , "  color: #00ff00;"
            -- , "  min-width: 50px;"
            -- , "}"
            -- , "scrollbar slider {"
            -- , "  -GtkRange-slider-width: 200px;"
            -- , "  -GtkRange-stepper-size: 200px;"
            -- , "  border-width: 200px;"
            -- , "  background-color: #0000ff;"
            -- , "  color: #0000ff;"
            -- , "  min-width: 50px;"
            -- , "}"
            , "tab {"
            , "  background-color: transparent;"
            , "}"
            ]
      let styleData = Text -> ByteString
forall textual binary. Utf8 textual binary => textual -> binary
encodeUtf8 ([Text] -> Text
forall seq. (Element seq ~ Text, MonoFoldable seq) => seq -> Text
forall t seq.
(Textual t, Element seq ~ t, MonoFoldable seq) =>
seq -> t
unlines [Text]
textLines :: Text)
      cssProviderLoadFromData cssProvider styleData
      styleContextAddProviderForScreen
        screen
        cssProvider
        (fromIntegral STYLE_PROVIDER_PRIORITY_APPLICATION)

createFontDescFromConfig :: TMConfig -> IO FontDescription
createFontDescFromConfig :: TMConfig -> IO FontDescription
createFontDescFromConfig 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 b c a. (b -> c) -> (a -> b) -> a -> c
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 FontSize
fontSz Text
fontFam = do
  fontDesc <- IO FontDescription
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
m FontDescription
fontDescriptionNew
  fontDescriptionSetFamily fontDesc fontFam
  setFontDescSize fontDesc fontSz
  pure fontDesc

setFontDescSize :: FontDescription -> FontSize -> IO ()
setFontDescSize :: FontDescription -> FontSize -> IO ()
setFontDescSize FontDescription
fontDesc (FontSizePoints 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 FontDescription
fontDesc (FontSizeUnits 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 FontSize -> FontSize
f FontDescription
fontDesc = do
  currFontSz <- FontDescription -> IO FontSize
fontSizeFromFontDescription FontDescription
fontDesc
  let newFontSz = FontSize -> FontSize
f FontSize
currFontSz
  setFontDescSize fontDesc newFontSz

modifyFontSizeForAllTerms :: (FontSize -> FontSize) -> TMState -> IO ()
modifyFontSizeForAllTerms :: (FontSize -> FontSize) -> TMState -> IO ()
modifyFontSizeForAllTerms FontSize -> FontSize
modFontSizeFunc TMState
mvarTMState = do
  tmState <- TMState -> IO TMState'
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar TMState
mvarTMState
  let 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
  adjustFontDescSize modFontSizeFunc fontDesc
  let 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 b c a. (b -> c) -> (a -> b) -> a -> c
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 b c a. (b -> c) -> (a -> b) -> a -> c
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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> FocusList a -> f (FocusList 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 b c a. (b -> c) -> (a -> b) -> a -> c
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 b c a. (b -> c) -> (a -> b) -> a -> c
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
  foldMap (\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)) terms

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

fontConfigFromFontDescription :: FontDescription -> IO (Maybe FontConfig)
fontConfigFromFontDescription :: FontDescription -> IO (Maybe FontConfig)
fontConfigFromFontDescription FontDescription
fontDescription = do
  fontSize <- FontDescription -> IO FontSize
fontSizeFromFontDescription FontDescription
fontDescription
  maybeFontFamily <- fontDescriptionGetFamily fontDescription
  return $ (`FontConfig` fontSize) <$> maybeFontFamily

compareScrolledWinAndTab :: ScrolledWindow -> TMNotebookTab -> Bool
compareScrolledWinAndTab :: ScrolledWindow -> TMNotebookTab -> Bool
compareScrolledWinAndTab ScrolledWindow
scrollWin TMNotebookTab
flTab =
  let ScrolledWindow 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 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 TMState
mvarTMState Int
oldPos 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 -> 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 b c a. (b -> c) -> (a -> b) -> a -> c
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
      Maybe (FocusList TMNotebookTab)
Nothing -> do
        Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
          Text
"in updateFLTabPos, Strange error: couldn't move tabs.\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
          Text
"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
<> Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
          Text
"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
<> Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
          Text
"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
<> Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
          Text
"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
<> Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
          Text
"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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TMState'
tmState
      Just FocusList TMNotebookTab
newTabs ->
        TMState' -> IO TMState'
forall a. a -> IO a
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 b c a. (b -> c) -> (a -> b) -> a -> c
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'.
{- HLINT ignore "Reduce duplication" -}
askShouldExit :: TMState -> IO ResponseType
askShouldExit :: TMState -> IO ResponseType
askShouldExit TMState
mvarTMState = do
  tmState <- TMState -> IO TMState'
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar TMState
mvarTMState
  let 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 b c a. (b -> c) -> (a -> b) -> a -> c
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 b c a. (b -> c) -> (a -> b) -> a -> c
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 confirm
    then confirmationDialogForExit tmState
    else pure ResponseTypeYes
  where
    -- Show the user a dialog telling them there are still terminals running and
    -- asking if they really want to exit.
    --
    -- Return the user's resposne as a 'ResponseType'.
    confirmationDialogForExit :: TMState' -> IO ResponseType
    confirmationDialogForExit :: TMState' -> IO ResponseType
confirmationDialogForExit 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
      win <- Application -> IO (Maybe Window)
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsApplication a) =>
a -> m (Maybe Window)
applicationGetActiveWindow Application
app
      dialog <- dialogNew
      box <- dialogGetContentArea dialog
      label <-
        labelNew $
          Just
            "There are still terminals running.  Are you sure you want to exit?"
      containerAdd box label
      widgetShow label
      setWidgetMargin label 10
      void $
        dialogAddButton
          dialog
          "No, do NOT exit"
          (fromIntegral (fromEnum ResponseTypeNo))
      void $
        dialogAddButton
          dialog
          "Yes, exit"
          (fromIntegral (fromEnum ResponseTypeYes))
      windowSetTransientFor dialog win
      res <- dialogRun dialog
      widgetDestroy dialog
      pure $ toEnum (fromIntegral res)

-- | Force Termonad to exit without asking the user whether or not to do so.
forceQuit :: TMState -> IO ()
forceQuit :: TMState -> IO ()
forceQuit TMState
mvarTMState = do
  tmState <- TMState -> IO TMState'
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar TMState
mvarTMState
  let 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
  applicationQuit app

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

  setupScreenStyle
  box <- objFromBuildUnsafe builder "content_box" Box
  fontDesc <- createFontDescFromConfig tmConfig
  note <- notebookNew
  widgetSetCanFocus note False
  -- If this is not set to False, then there will be a one pixel white border
  -- shown around the notebook.
  notebookSetShowBorder note False
  boxPackStart box note True True 0

  mvarTMState <- newEmptyTMState tmConfig app win note fontDesc
  terminal <- createTerm handleKeyPress mvarTMState

  void $ onNotebookPageRemoved note $ \Widget
_ Word32
_ -> do
    pages <- Notebook -> IO Int32
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsNotebook a) =>
a -> m Int32
notebookGetNPages Notebook
note
    if pages == 0
      then forceQuit mvarTMState
      else setShowTabs tmConfig note

  void $ onNotebookSwitchPage note $ \Widget
_ 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 -> 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
        Maybe (TMNotebookTab, FocusList TMNotebookTab)
Nothing -> TMState' -> IO TMState'
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TMState'
tmState
        Just (TMNotebookTab
tab, 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 b c a. (b -> c) -> (a -> b) -> a -> c
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 a. a -> IO a
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 b c a. (b -> c) -> (a -> b) -> a -> c
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

  void $ onNotebookPageReordered note $ \Widget
childWidg Word32
pageNum -> do
    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 maybeScrollWin of
      Maybe ScrolledWindow
Nothing ->
        FilePath -> IO ()
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
          FilePath
"In setupTermonad, in callback for onNotebookPageReordered, " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<>
          FilePath
"child widget is not a ScrolledWindow.\n" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<>
          FilePath
"Don't know how to continue.\n"
      Just ScrolledWindow
scrollWin -> do
        TMState{tmStateNotebook} <- TMState -> IO TMState'
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar TMState
mvarTMState
        let 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 =
              (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 maybeOldPosition of
          Maybe Int
Nothing ->
            FilePath -> IO ()
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
              FilePath
"In setupTermonad, in callback for onNotebookPageReordered, " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<>
              FilePath
"the ScrolledWindow is not already in the FocusList.\n" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<>
              FilePath
"Don't know how to continue.\n"
          Just 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

  newTabAction <- simpleActionNew "newtab" Nothing
  void $ onSimpleActionActivate newTabAction $ \Maybe GVariant
_ -> 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
  actionMapAddAction app newTabAction
  applicationSetAccelsForAction app "app.newtab" ["<Shift><Ctrl>T"]

  nextPageAction <- simpleActionNew "nextpage" Nothing
  void $ onSimpleActionActivate nextPageAction $ \Maybe GVariant
_ ->
    TMState -> IO ()
termNextPage TMState
mvarTMState
  actionMapAddAction app nextPageAction
  applicationSetAccelsForAction app "app.nextpage" ["<Ctrl>Page_Down"]

  prevPageAction <- simpleActionNew "prevpage" Nothing
  void $ onSimpleActionActivate prevPageAction $ \Maybe GVariant
_ ->
    TMState -> IO ()
termPrevPage TMState
mvarTMState
  actionMapAddAction app prevPageAction
  applicationSetAccelsForAction app "app.prevpage" ["<Ctrl>Page_Up"]

  closeTabAction <- simpleActionNew "closetab" Nothing
  void $ onSimpleActionActivate closeTabAction $ \Maybe GVariant
_ ->
    TMState -> IO ()
termExitFocused TMState
mvarTMState
  actionMapAddAction app closeTabAction
  applicationSetAccelsForAction app "app.closetab" ["<Shift><Ctrl>W"]

  quitAction <- simpleActionNew "quit" Nothing
  void $ onSimpleActionActivate quitAction $ \Maybe GVariant
_ -> do
    shouldExit <- TMState -> IO ResponseType
askShouldExit TMState
mvarTMState
    when (shouldExit == ResponseTypeYes) $ forceQuit mvarTMState
  actionMapAddAction app quitAction
  applicationSetAccelsForAction app "app.quit" ["<Shift><Ctrl>Q"]

  copyAction <- simpleActionNew "copy" Nothing
  void $ onSimpleActionActivate copyAction $ \Maybe GVariant
_ -> do
    maybeTerm <- TMState -> IO (Maybe Terminal)
getFocusedTermFromState TMState
mvarTMState
    maybe (pure ()) terminalCopyClipboard maybeTerm
  actionMapAddAction app copyAction
  applicationSetAccelsForAction app "app.copy" ["<Shift><Ctrl>C"]

  pasteAction <- simpleActionNew "paste" Nothing
  void $ onSimpleActionActivate pasteAction $ \Maybe GVariant
_ -> do
    maybeTerm <- TMState -> IO (Maybe Terminal)
getFocusedTermFromState TMState
mvarTMState
    maybe (pure ()) terminalPasteClipboard maybeTerm
  actionMapAddAction app pasteAction
  applicationSetAccelsForAction app "app.paste" ["<Shift><Ctrl>V"]

  preferencesAction <- simpleActionNew "preferences" Nothing
  void $ onSimpleActionActivate preferencesAction (const $ showPreferencesDialog mvarTMState)
  actionMapAddAction app preferencesAction

  enlargeFontAction <- simpleActionNew "enlargefont" Nothing
  void $ onSimpleActionActivate enlargeFontAction $ \Maybe GVariant
_ ->
    (FontSize -> FontSize) -> TMState -> IO ()
modifyFontSizeForAllTerms (Int -> FontSize -> FontSize
modFontSize Int
1) TMState
mvarTMState
  actionMapAddAction app enlargeFontAction
  applicationSetAccelsForAction app "app.enlargefont" ["<Ctrl>plus"]

  reduceFontAction <- simpleActionNew "reducefont" Nothing
  void $ onSimpleActionActivate reduceFontAction $ \Maybe GVariant
_ ->
    (FontSize -> FontSize) -> TMState -> IO ()
modifyFontSizeForAllTerms (Int -> FontSize -> FontSize
modFontSize (-Int
1)) TMState
mvarTMState
  actionMapAddAction app reduceFontAction
  applicationSetAccelsForAction app "app.reducefont" ["<Ctrl>minus"]

  findAction <- simpleActionNew "find" Nothing
  void $ onSimpleActionActivate findAction $ \Maybe GVariant
_ -> TMState -> IO ()
doFind TMState
mvarTMState
  actionMapAddAction app findAction
  applicationSetAccelsForAction app "app.find" ["<Shift><Ctrl>F"]

  findAboveAction <- simpleActionNew "findabove" Nothing
  void $ onSimpleActionActivate findAboveAction $ \Maybe GVariant
_ -> TMState -> IO ()
findAbove TMState
mvarTMState
  actionMapAddAction app findAboveAction
  applicationSetAccelsForAction app "app.findabove" ["<Shift><Ctrl>P"]

  findBelowAction <- simpleActionNew "findbelow" Nothing
  void $ onSimpleActionActivate findBelowAction $ \Maybe GVariant
_ -> TMState -> IO ()
findBelow TMState
mvarTMState
  actionMapAddAction app findBelowAction
  applicationSetAccelsForAction app "app.findbelow" ["<Shift><Ctrl>I"]

  aboutAction <- simpleActionNew "about" Nothing
  void $ onSimpleActionActivate aboutAction $ \Maybe GVariant
_ -> Application -> IO ()
showAboutDialog Application
app
  actionMapAddAction app aboutAction

  menuBuilder <- builderNewFromString menuText $ fromIntegral (length menuText)
  menuModel <- objFromBuildUnsafe menuBuilder "menubar" MenuModel
  applicationSetMenubar app (Just menuModel)
  let 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 b c a. (b -> c) -> (a -> b) -> a -> c
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
  applicationWindowSetShowMenubar win showMenu

  windowSetTitle win "Termonad"

  -- This event will happen if the user requests that the top-level Termonad
  -- window be closed through their window manager. It will also happen
  -- normally when the user tries to close Termonad through normal methods,
  -- like clicking "Quit" or closing the last open terminal.
  --
  -- If you return 'True' from this callback, then Termonad will not exit.
  -- If you return 'False' from this callback, then Termonad will continue to
  -- exit.
  void $ onWidgetDeleteEvent win $ \Event
_ -> do
    shouldExit <- TMState -> IO ResponseType
askShouldExit TMState
mvarTMState
    pure $
      case shouldExit of
        ResponseType
ResponseTypeYes -> Bool
False
        ResponseType
_ -> Bool
True

  widgetShowAll win
  widgetGrabFocus $ terminal ^. lensTerm

appActivate :: TMConfig -> Application -> IO ()
appActivate :: TMConfig -> Application -> IO ()
appActivate TMConfig
tmConfig Application
app = do
  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)
  builderSetApplication uiBuilder app
  appWin <- objFromBuildUnsafe uiBuilder "appWin" ApplicationWindow
  applicationAddWindow app appWin
  setupTermonad tmConfig app appWin uiBuilder
  windowPresent appWin

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

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

  searchForLabel <- labelNew (Just "Search for regex:")
  containerAdd grid searchForLabel
  widgetShow searchForLabel
  setWidgetMargin searchForLabel 10

  searchEntry <- entryNew
  gridAttachNextTo grid searchEntry (Just searchForLabel) PositionTypeRight 1 1
  widgetShow searchEntry
  setWidgetMargin searchEntry 10
  -- setWidgetMarginBottom searchEntry 20
  void $
    onEntryActivate searchEntry $
      dialogResponse dialog (fromIntegral (fromEnum ResponseTypeYes))

  void $
    dialogAddButton
      dialog
      "Close"
      (fromIntegral (fromEnum ResponseTypeNo))
  void $
    dialogAddButton
      dialog
      "Find"
      (fromIntegral (fromEnum ResponseTypeYes))

  containerAdd box grid
  widgetShow grid
  windowSetTransientFor dialog win
  res <- dialogRun dialog

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

  widgetDestroy dialog

  pure maybeSearchString

doFind :: TMState -> IO ()
doFind :: TMState -> IO ()
doFind TMState
mvarTMState = do
  tmState <- TMState -> IO TMState'
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar TMState
mvarTMState
  let app = TMState' -> Application
tmStateApp TMState'
tmState
  maybeSearchString <- showFindDialog app
  -- putStrLn $ "trying to find: " <> tshow maybeSearchString
  maybeTerminal <- getFocusedTermFromState mvarTMState
  case (maybeSearchString, maybeTerminal) of
    (Just Text
searchString, Just 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 = Word32
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
      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 a b. (a -> b) -> IO a -> IO b
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)
          (\RegexError
_ Text
errMsg -> Either Text Regex -> IO (Either Text Regex)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Either Text Regex
forall a b. a -> Either a b
Left Text
errMsg))
      case eitherRegex of
        Left Text
errMsg -> do
          let msg :: Text
msg = Text
"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 -> 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
          _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
          pure ()
    (Maybe Text, Maybe Terminal)
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

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

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

setShowMenuBar :: Application -> Bool -> IO ()
setShowMenuBar :: Application -> Bool -> IO ()
setShowMenuBar Application
app 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
    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
    appWin <- MaybeT $ castTo ApplicationWindow win
    lift $ applicationWindowSetShowMenubar appWin visible

-- | Fill a combo box with ids and labels
--
-- The ids are stored in the combobox as 'Text', so their type should be an
-- instance of the 'Show' type class.
comboBoxFill :: forall a. Show a => ComboBoxText -> [(a, Text)] -> IO ()
comboBoxFill :: forall a. Show a => ComboBoxText -> [(a, Text)] -> IO ()
comboBoxFill 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 (a
value, 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 :: forall a. Show a => ComboBoxText -> a -> IO ()
comboBoxSetActive ComboBoxText
cb 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 :: forall a. (Show a, Enum a) => ComboBoxText -> [a] -> IO (Maybe a)
comboBoxGetActive ComboBoxText
cb [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 Maybe Text
maybeId = Maybe Text
maybeId Maybe Text -> (Text -> Maybe a) -> Maybe a
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
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 Text
label = (Element [a] -> Bool) -> [a] -> Maybe (Element [a])
forall seq.
SemiSequence seq =>
(Element seq -> Bool) -> seq -> Maybe (Element seq)
find (\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 TMState
mvarTMState = do
  tmState <- TMState -> IO TMState'
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar TMState
mvarTMState
  let 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 = 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 = TMState'
tmState TMState' -> Getting Notebook TMState' Notebook -> Notebook
forall s a. s -> Getting a s a -> a
^. (TMNotebook -> Const Notebook TMNotebook)
-> TMState' -> Const Notebook TMState'
Lens' TMState' TMNotebook
lensTMStateNotebook ((TMNotebook -> Const Notebook TMNotebook)
 -> TMState' -> Const Notebook TMState')
-> ((Notebook -> Const Notebook Notebook)
    -> TMNotebook -> Const Notebook TMNotebook)
-> Getting Notebook TMState' Notebook
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Notebook -> Const Notebook Notebook)
-> TMNotebook -> Const Notebook TMNotebook
Lens' TMNotebook Notebook
lensTMNotebook
      tabFocusList = 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 b c a. (b -> c) -> (a -> b) -> a -> c
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
      showMenu = TMConfig
config  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 b c a. (b -> c) -> (a -> b) -> a -> c
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
  applicationWindowSetShowMenubar appWin showMenu
  setShowTabs config notebook
  -- Sets the remaining preferences to each tab
  foldMap (applyNewPreferencesToTab mvarTMState) tabFocusList

applyNewPreferencesToTab :: TMState -> TMNotebookTab -> IO ()
applyNewPreferencesToTab :: TMState -> TMNotebookTab -> IO ()
applyNewPreferencesToTab TMState
mvarTMState TMNotebookTab
tab = do
  tmState <- TMState -> IO TMState'
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar TMState
mvarTMState
  let 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 = 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 b c a. (b -> c) -> (a -> b) -> a -> c
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
      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 = 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')
-> ((ConfigOptions -> Const ConfigOptions ConfigOptions)
    -> TMConfig -> Const ConfigOptions TMConfig)
-> Getting ConfigOptions TMState' ConfigOptions
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (ConfigOptions -> Const ConfigOptions ConfigOptions)
-> TMConfig -> Const ConfigOptions TMConfig
Lens' TMConfig ConfigOptions
lensOptions
  terminalSetFont term (Just fontDesc)
  terminalSetCursorBlinkMode term (cursorBlinkMode options)
  terminalSetWordCharExceptions term (wordCharExceptions options)
  terminalSetScrollbackLines term (fromIntegral (scrollbackLen options))
  terminalSetBoldIsBright term (boldIsBright options)
  terminalSetEnableSixelIfExists term (enableSixel options)
  terminalSetAllowBold term (allowBold options)

  let vScrollbarPolicy = 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)
  scrolledWindowSetPolicy scrolledWin PolicyTypeAutomatic vScrollbarPolicy

-- | Show the preferences dialog.
--
-- When the user clicks on the Ok button, it copies the new settings to TMState.
-- Then apply them to the current terminals.
showPreferencesDialog :: TMState -> IO ()
showPreferencesDialog :: TMState -> IO ()
showPreferencesDialog TMState
mvarTMState = do
  -- Get app out of mvar
  tmState <- TMState -> IO TMState'
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar TMState
mvarTMState
  let 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
  preferencesBuilder <-
    builderNewFromString preferencesText $ fromIntegral (length preferencesText)
  preferencesDialog <-
    objFromBuildUnsafe preferencesBuilder "preferences" Dialog
  confirmExitCheckButton <-
    objFromBuildUnsafe preferencesBuilder "confirmExit" CheckButton
  showMenuCheckButton <-
    objFromBuildUnsafe preferencesBuilder "showMenu" CheckButton
  boldIsBrightCheckButton <-
    objFromBuildUnsafe preferencesBuilder "boldIsBright" CheckButton
  enableSixelCheckButton <-
    objFromBuildUnsafe preferencesBuilder "enableSixel" CheckButton
  allowBoldCheckButton <-
    objFromBuildUnsafe preferencesBuilder "allowBold" CheckButton
  wordCharExceptionsEntryBuffer <-
    objFromBuildUnsafe preferencesBuilder "wordCharExceptions" Entry >>=
      getEntryBuffer
  fontButton <- objFromBuildUnsafe preferencesBuilder "font" FontButton
  showScrollbarComboBoxText <-
    objFromBuildUnsafe preferencesBuilder "showScrollbar" ComboBoxText
  comboBoxFill
    showScrollbarComboBoxText
    [ (ShowScrollbarNever, "Never")
    , (ShowScrollbarAlways, "Always")
    , (ShowScrollbarIfNeeded, "If needed")
    ]
  showTabBarComboBoxText <-
    objFromBuildUnsafe preferencesBuilder "showTabBar" ComboBoxText
  comboBoxFill
    showTabBarComboBoxText
    [ (ShowTabBarNever, "Never")
    , (ShowTabBarAlways, "Always")
    , (ShowTabBarIfNeeded, "If needed")
    ]
  cursorBlinkModeComboBoxText <-
    objFromBuildUnsafe preferencesBuilder "cursorBlinkMode" ComboBoxText
  comboBoxFill
    cursorBlinkModeComboBoxText
    [ (CursorBlinkModeSystem, "System")
    , (CursorBlinkModeOn, "On")
    , (CursorBlinkModeOff, "Off")
    ]
  scrollbackLenSpinButton <-
    objFromBuildUnsafe preferencesBuilder "scrollbackLen" SpinButton
  adjustmentNew 0 0 (fromIntegral (maxBound :: Int)) 1 10 0 >>=
    spinButtonSetAdjustment scrollbackLenSpinButton
  warningLabel <- objFromBuildUnsafe preferencesBuilder "warning" Label

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

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

  -- Init with current state
  fontChooserSetFontDesc fontButton (tmState ^. lensTMStateFontDesc)
  let options = TMState'
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')
-> ((ConfigOptions -> Const ConfigOptions ConfigOptions)
    -> TMConfig -> Const ConfigOptions TMConfig)
-> Getting ConfigOptions TMState' ConfigOptions
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (ConfigOptions -> Const ConfigOptions ConfigOptions)
-> TMConfig -> Const ConfigOptions TMConfig
Lens' TMConfig ConfigOptions
lensOptions
  comboBoxSetActive showScrollbarComboBoxText $ showScrollbar options
  comboBoxSetActive showTabBarComboBoxText $ showTabBar options
  comboBoxSetActive cursorBlinkModeComboBoxText $ cursorBlinkMode options
  spinButtonSetValue scrollbackLenSpinButton (fromIntegral $ scrollbackLen options)
  toggleButtonSetActive confirmExitCheckButton $ confirmExit options
  toggleButtonSetActive showMenuCheckButton $ showMenu options
  toggleButtonSetActive boldIsBrightCheckButton $ boldIsBright options
  toggleButtonSetActive enableSixelCheckButton $ enableSixel options
  toggleButtonSetActive allowBoldCheckButton $ allowBold options
  entryBufferSetText wordCharExceptionsEntryBuffer (wordCharExceptions options) (-1)

  -- Run dialog then close
  res <- dialogRun preferencesDialog

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

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

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

    -- Update the app with new settings
    applyNewPreferences mvarTMState

  widgetDestroy preferencesDialog

appStartup :: Application -> IO ()
appStartup :: Application -> IO ()
appStartup Application
_app = () -> IO ()
forall a. a -> IO a
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 = do
  -- app <- appNew (Just "haskell.termonad") [ApplicationFlagsFlagsNone]
  -- Make sure the application is not unique, so we can open multiple copies of it.
  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]
  void $ onApplicationStartup app (appStartup app)
  void $ onApplicationActivate app (appActivate tmConfig app)
  void $ applicationRun app Nothing

-- | Run Termonad with the given 'TMConfig'.
--
-- This function will check if there is a @~\/.config\/termonad\/termonad.hs@ file
-- and a @~\/.cache\/termonad\/termonad-linux-x86_64@ binary.  Termonad will
-- perform different actions based on whether or not these two files exist.
--
-- Here are the four different possible actions based on the existence of these
-- two files.
--
-- - @~\/.config\/termonad\/termonad.hs@ exists, @~\/.cache\/termonad\/termonad-linux-x86_64@ exists
--
--     The timestamps of these two files are checked.  If the
--     @~\/.config\/termonad\/termonad.hs@ file has been modified after the
--     @~\/.cache\/termonad\/termonad-linux-x86_64@ binary, then Termonad will use
--     GHC to recompile the @~\/.config\/termonad\/termonad.hs@ file, producing a
--     new binary at @~\/.cache\/termonad\/termonad-linux-x86_64@.  This new binary
--     will be re-executed.  The 'TMConfig' passed to this 'defaultMain' will be
--     effectively thrown away.
--
--     If GHC fails to recompile the @~\/.config\/termonad\/termonad.hs@ file, then
--     Termonad will just execute 'start' with the 'TMConfig' passed in.
--
--     If the @~\/.cache\/termonad\/termonad-linux-x86_64@ binary has been modified
--     after the @~\/.config\/termonad\/termonad.hs@ file, then Termonad will
--     re-exec the @~\/.cache\/termonad\/termonad-linux-x86_64@ binary.  The
--     'TMConfig' passed to this 'defaultMain' will be effectively thrown away.
--
-- - @~\/.config\/termonad\/termonad.hs@ exists, @~\/.cache\/termonad\/termonad-linux-x86_64@ does not exist
--
--     Termonad will use GHC to recompile the @~\/.config\/termonad\/termonad.hs@
--     file, producing a new binary at @~\/.cache\/termonad\/termonad-linux-x86_64@.
--     This new binary will be re-executed.  The 'TMConfig' passed to this
--     'defaultMain' will be effectively thrown away.
--
--     If GHC fails to recompile the @~\/.config\/termonad\/termonad.hs@ file, then
--     Termonad will just execute 'start' with the 'TMConfig' passed in.
--
-- - @~\/.config\/termonad\/termonad.hs@ does not exist, @~\/.cache\/termonad\/termonad-linux-x86_64@ exists
--
--     Termonad will ignore the @~\/.cache\/termonad\/termonad-linux-x86_64@ binary
--     and just run 'start' with the 'TMConfig' passed to this function.
--
-- - @~\/.config\/termonad\/termonad.hs@ does not exist, @~\/.cache\/termonad\/termonad-linux-x86_64@ does not exist
--
--     Termonad will run 'start' with the 'TMConfig' passed to this function.
--
-- Other notes:
--
-- 1. That the locations of @~\/.config\/termonad\/termonad.hs@ and
--    @~\/.cache\/termonad\/termonad-linux-x86_64@ may differ depending on your
--    system.
--
-- 2. In your own @~\/.config\/termonad\/termonad.hs@ file, you can use either
--    'defaultMain' or 'start'.  As long as you always execute the system-wide
--    @termonad@ binary (instead of the binary produced as
--    @~\/.cache\/termonad\/termonad-linux-x86_64@), the effect should be the same.
defaultMain :: TMConfig -> IO ()
defaultMain :: TMConfig -> IO ()
defaultMain TMConfig
tmConfig = do
  let params :: Params (TMConfig, FilePath) ()
params =
        Params (ZonkAny 1) (ZonkAny 0)
forall cfgType a. Params cfgType a
defaultParams
          { projectName = "termonad"
          , showError = \(TMConfig
cfg, FilePath
oldErrs) FilePath
newErr -> (TMConfig
cfg, FilePath
oldErrs FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"\n" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
newErr)
          , realMain = \(TMConfig
cfg, 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 a b. IO a -> IO b -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> TMConfig -> IO ()
start TMConfig
cfg
          }
  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 a. Params cfgType a -> cfgType -> IO a
wrapMain Params (TMConfig, FilePath) ()
params (TMConfig
tmConfig, FilePath
"")
  case eitherRes of
    Left 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 FilePath
"ghc" -> do
          Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
            Text
"Could not find ghc on your PATH.  Ignoring your termonad.hs " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
            Text
"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 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 Text
"Don't know how to recover.  Exiting."
    Right ()
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()