{-# LANGUAGE TemplateHaskell #-}

module Termonad.App where

import Termonad.Prelude

import Control.Lens ((^.))
import Data.FileEmbed (embedFile)
import qualified Data.Text as Text
import Data.Text.Encoding (encodeUtf8)
import GI.Gdk (screenGetDefault)
import GI.Gio
  ( ApplicationFlags(ApplicationFlagsFlagsNone)
  , MenuModel(MenuModel)
  , actionMapAddAction
  , applicationQuit
  , applicationRun
  , onApplicationActivate
  , onApplicationStartup
  , onSimpleActionActivate
  , simpleActionNew
  )
import GI.Gtk
  ( Application
  , ApplicationWindow(ApplicationWindow)
  , Box(Box)
  , Notebook
  , ResponseType(ResponseTypeNo, ResponseTypeYes)
  , pattern STYLE_PROVIDER_PRIORITY_APPLICATION
  , applicationAddWindow
  , applicationGetActiveWindow
  , applicationSetAccelsForAction
  , applicationSetMenubar
  , applicationWindowSetShowMenubar
  , boxPackStart
  , builderNewFromString
  , builderSetApplication
  , containerAdd
  , cssProviderLoadFromData
  , cssProviderNew
  , dialogAddButton
  , dialogGetContentArea
  , dialogNew
  , dialogRun
  , labelNew
  , notebookGetNPages
  , notebookNew
  , notebookSetShowBorder
  , onNotebookPageRemoved
  , onWidgetDeleteEvent
  , setWidgetMargin
  , styleContextAddProviderForScreen
  , widgetDestroy
  , widgetGrabFocus
  , widgetSetCanFocus
  , widgetShow
  , widgetShowAll
  , windowPresent
  , windowSetDefaultIcon
  , windowSetTitle
  , windowSetTransientFor
  )
import qualified GI.Gtk as Gtk
import Termonad.Gtk (appNew, imgToPixbuf, objFromBuildUnsafe)
import Termonad.Keys (handleKeyPress)
import Termonad.Lenses
  ( lensConfirmExit
  , lensOptions
  , lensShowMenu
  , lensTMStateApp
  , lensTMStateConfig
  , lensTerm
  )
import Termonad.Preferences (showPreferencesDialog)
import Termonad.Term (createTerm, setShowTabs)
import Termonad.Types
  ( TMConfig
  , TMState
  , TMState'
  , TMWindowId
  , createFontDescFromConfig
  , modFontSize
  , newEmptyTMState
  )
import Termonad.XML (interfaceText, menuText)
import Termonad.Window (showAboutDialog, modifyFontSizeForAllTerms, setupWindowCallbacks)

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
    Maybe Screen
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just Screen
screen -> do
      CssProvider
cssProvider <- IO CssProvider
forall (m :: * -> *). (HasCallStack, MonadIO m) => m CssProvider
cssProviderNew
      let ([Text]
textLines :: [Text]) =
            [
              Text
Item [Text]
"scrollbar {"
            -- , "  -GtkRange-slider-width: 200px;"
            -- , "  -GtkRange-stepper-size: 200px;"
            -- , "  border-width: 200px;"
            , Text
Item [Text]
"  background-color: #aaaaaa;"
            -- , "  color: #ff0000;"
            -- , "  min-width: 4px;"
            , Text
Item [Text]
"}"
            -- , "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;"
            -- , "}"
            , Text
Item [Text]
"tab {"
            , Text
Item [Text]
"  background-color: transparent;"
            , Text
Item [Text]
"}"
            ]
      let styleData :: ByteString
styleData = Text -> ByteString
encodeUtf8 ([Text] -> Text
Text.unlines [Text]
textLines)
      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)

-- | 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 <- TMState -> IO TMState'
forall a. MVar a -> IO 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 b c a. (b -> c) -> (a -> b) -> 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
. (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 a. a -> IO a
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 = 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
            Text
"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 Int32
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
          Text
"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
          Text
"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 a. a -> IO a
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 TMState
mvarTMState = do
  TMState'
tmState <- TMState -> IO TMState'
forall a. MVar a -> IO 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

setupAppCallbacks :: TMState -> TMConfig -> Application -> ApplicationWindow -> Notebook -> TMWindowId -> IO ()
setupAppCallbacks :: TMState
-> TMConfig
-> Application
-> ApplicationWindow
-> Notebook
-> TMWindowId
-> IO ()
setupAppCallbacks TMState
mvarTMState TMConfig
tmConfig Application
app ApplicationWindow
win Notebook
note TMWindowId
tmWinId = do
  SimpleAction
newWindowAction <- Text -> Maybe VariantType -> IO SimpleAction
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Text -> Maybe VariantType -> m SimpleAction
simpleActionNew Text
"newwin" 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
-> ((?self::SimpleAction) => SimpleActionActivateCallback)
-> IO SignalHandlerId
forall a (m :: * -> *).
(IsSimpleAction a, MonadIO m) =>
a
-> ((?self::a) => SimpleActionActivateCallback)
-> m SignalHandlerId
onSimpleActionActivate SimpleAction
newWindowAction (((?self::SimpleAction) => SimpleActionActivateCallback)
 -> IO SignalHandlerId)
-> ((?self::SimpleAction) => SimpleActionActivateCallback)
-> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ \Maybe GVariant
_ ->
    () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    -- void $ createTerm handleKeyPress mvarTMState tmWinId
  Application -> SimpleAction -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsActionMap a, IsAction b) =>
a -> b -> m ()
actionMapAddAction Application
app SimpleAction
newWindowAction
  -- TODO: Uncomment this when adding the actual functionality
  -- for creating new windows.
  -- applicationSetAccelsForAction app "app.newwin" ["<Shift><Ctrl>N"]

  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
-> ((?self::Notebook) => NotebookPageRemovedCallback)
-> IO SignalHandlerId
forall a (m :: * -> *).
(IsNotebook a, MonadIO m) =>
a
-> ((?self::a) => NotebookPageRemovedCallback) -> m SignalHandlerId
onNotebookPageRemoved Notebook
note (((?self::Notebook) => NotebookPageRemovedCallback)
 -> IO SignalHandlerId)
-> ((?self::Notebook) => NotebookPageRemovedCallback)
-> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ \Widget
_ Word32
_ -> 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
== Int32
0
      then TMState -> IO ()
forceQuit TMState
mvarTMState
      else TMConfig -> Notebook -> IO ()
setShowTabs TMConfig
tmConfig Notebook
note

  SimpleAction
quitAction <- Text -> Maybe VariantType -> IO SimpleAction
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Text -> Maybe VariantType -> m SimpleAction
simpleActionNew Text
"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
-> ((?self::SimpleAction) => SimpleActionActivateCallback)
-> IO SignalHandlerId
forall a (m :: * -> *).
(IsSimpleAction a, MonadIO m) =>
a
-> ((?self::a) => SimpleActionActivateCallback)
-> m SignalHandlerId
onSimpleActionActivate SimpleAction
quitAction (((?self::SimpleAction) => SimpleActionActivateCallback)
 -> IO SignalHandlerId)
-> ((?self::SimpleAction) => SimpleActionActivateCallback)
-> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ \Maybe GVariant
_ -> 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 Text
"app.quit" [Text
Item [Text]
"<Shift><Ctrl>Q"]

  SimpleAction
preferencesAction <- Text -> Maybe VariantType -> IO SimpleAction
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Text -> Maybe VariantType -> m SimpleAction
simpleActionNew Text
"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
-> ((?self::SimpleAction) => SimpleActionActivateCallback)
-> IO SignalHandlerId
forall a (m :: * -> *).
(IsSimpleAction a, MonadIO m) =>
a
-> ((?self::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 Text
"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
-> ((?self::SimpleAction) => SimpleActionActivateCallback)
-> IO SignalHandlerId
forall a (m :: * -> *).
(IsSimpleAction a, MonadIO m) =>
a
-> ((?self::a) => SimpleActionActivateCallback)
-> m SignalHandlerId
onSimpleActionActivate SimpleAction
enlargeFontAction (((?self::SimpleAction) => SimpleActionActivateCallback)
 -> IO SignalHandlerId)
-> ((?self::SimpleAction) => SimpleActionActivateCallback)
-> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ \Maybe GVariant
_ ->
    (FontSize -> FontSize) -> TMState -> TMWindowId -> IO ()
modifyFontSizeForAllTerms (Int -> FontSize -> FontSize
modFontSize Int
1) TMState
mvarTMState TMWindowId
tmWinId
  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 Text
"app.enlargefont" [Text
Item [Text]
"<Ctrl>plus"]

  SimpleAction
reduceFontAction <- Text -> Maybe VariantType -> IO SimpleAction
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Text -> Maybe VariantType -> m SimpleAction
simpleActionNew Text
"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
-> ((?self::SimpleAction) => SimpleActionActivateCallback)
-> IO SignalHandlerId
forall a (m :: * -> *).
(IsSimpleAction a, MonadIO m) =>
a
-> ((?self::a) => SimpleActionActivateCallback)
-> m SignalHandlerId
onSimpleActionActivate SimpleAction
reduceFontAction (((?self::SimpleAction) => SimpleActionActivateCallback)
 -> IO SignalHandlerId)
-> ((?self::SimpleAction) => SimpleActionActivateCallback)
-> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ \Maybe GVariant
_ ->
    (FontSize -> FontSize) -> TMState -> TMWindowId -> IO ()
modifyFontSizeForAllTerms (Int -> FontSize -> FontSize
modFontSize (-Int
1)) TMState
mvarTMState TMWindowId
tmWinId
  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 Text
"app.reducefont" [Text
Item [Text]
"<Ctrl>minus"]

  SimpleAction
aboutAction <- Text -> Maybe VariantType -> IO SimpleAction
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Text -> Maybe VariantType -> m SimpleAction
simpleActionNew Text
"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
-> ((?self::SimpleAction) => SimpleActionActivateCallback)
-> IO SignalHandlerId
forall a (m :: * -> *).
(IsSimpleAction a, MonadIO m) =>
a
-> ((?self::a) => SimpleActionActivateCallback)
-> m SignalHandlerId
onSimpleActionActivate SimpleAction
aboutAction (((?self::SimpleAction) => SimpleActionActivateCallback)
 -> IO SignalHandlerId)
-> ((?self::SimpleAction) => SimpleActionActivateCallback)
-> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ \Maybe GVariant
_ -> ApplicationWindow -> IO ()
showAboutDialog ApplicationWindow
win
  Application -> SimpleAction -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsActionMap a, IsAction b) =>
a -> b -> m ()
actionMapAddAction Application
app SimpleAction
aboutAction

  -- 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
-> ((?self::ApplicationWindow) => WidgetDeleteEventCallback)
-> IO SignalHandlerId
forall a (m :: * -> *).
(IsWidget a, MonadIO m) =>
a -> ((?self::a) => WidgetDeleteEventCallback) -> m SignalHandlerId
onWidgetDeleteEvent ApplicationWindow
win (((?self::ApplicationWindow) => WidgetDeleteEventCallback)
 -> IO SignalHandlerId)
-> ((?self::ApplicationWindow) => WidgetDeleteEventCallback)
-> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ \Event
_ -> do
    ResponseType
shouldExit <- TMState -> IO ResponseType
askShouldExit TMState
mvarTMState
    Bool -> IO Bool
forall a. a -> IO a
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
        ResponseType
ResponseTypeYes -> Bool
False
        ResponseType
_ -> Bool
True

setupTermonad :: TMConfig -> Application -> ApplicationWindow -> Gtk.Builder -> IO ()
setupTermonad :: TMConfig -> Application -> ApplicationWindow -> Builder -> IO ()
setupTermonad TMConfig
tmConfig Application
app ApplicationWindow
win Builder
builder = do
  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 Text
"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 Word32
0

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

  TMState
-> TMConfig
-> Application
-> ApplicationWindow
-> Notebook
-> TMWindowId
-> IO ()
setupAppCallbacks TMState
mvarTMState TMConfig
tmConfig Application
app ApplicationWindow
win Notebook
note TMWindowId
tmWinId
  TMState
-> Application
-> ApplicationWindow
-> Notebook
-> TMWindowId
-> IO ()
setupWindowCallbacks TMState
mvarTMState Application
app ApplicationWindow
win Notebook
note TMWindowId
tmWinId

  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
Text.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 Text
"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 b c a. (b -> c) -> (a -> b) -> 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 Text
"Termonad"

  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 -> Getting Terminal TMTerm Terminal -> Terminal
forall s a. s -> Getting a s a -> a
^. Getting Terminal TMTerm Terminal
Lens' TMTerm Terminal
lensTerm

appActivate :: TMConfig -> Application -> IO ()
appActivate :: TMConfig -> Application -> IO ()
appActivate TMConfig
tmConfig Application
app = do
  let img :: ByteString
img = $(embedFile "img/termonad-lambda.png")
  Pixbuf
iconPixbuf <- ByteString -> IO Pixbuf
imgToPixbuf ByteString
img
  Pixbuf -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsPixbuf a) =>
a -> m ()
windowSetDefaultIcon Pixbuf
iconPixbuf
  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
Text.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 Text
"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

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 'Termonad.Startup.defaultMain'
-- function does.
--
-- This function __does not__ parse command line arguments.
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.
  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
-> ((?self::Application) => IO ()) -> IO SignalHandlerId
forall a (m :: * -> *).
(IsApplication a, MonadIO m) =>
a -> ((?self::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
-> ((?self::Application) => IO ()) -> IO SignalHandlerId
forall a (m :: * -> *).
(IsApplication a, MonadIO m) =>
a -> ((?self::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 [[Char]] -> IO Int32
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsApplication a) =>
a -> Maybe [[Char]] -> m Int32
applicationRun Application
app Maybe [[Char]]
forall a. Maybe a
Nothing