{-# 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 {"
, Text
Item [Text]
" background-color: #aaaaaa;"
, Text
Item [Text]
"}"
, 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)
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
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)
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 ()
Application -> SimpleAction -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsActionMap a, IsAction b) =>
a -> b -> m ()
actionMapAddAction Application
app SimpleAction
newWindowAction
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
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
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 ()
start :: TMConfig -> IO ()
start :: TMConfig -> IO ()
start TMConfig
tmConfig = do
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