module Termonad.App where
import Termonad.Prelude
import Config.Dyre (defaultParams, projectName, realMain, showError, wrapMain)
import Control.Lens ((&), (.~), (^.), (^..))
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)
, ResponseType(ResponseTypeNo, ResponseTypeYes)
, ScrolledWindow(ScrolledWindow)
, pattern STYLE_PROVIDER_PRIORITY_APPLICATION
, aboutDialogNew
, applicationAddWindow
, applicationGetActiveWindow
, applicationSetAccelsForAction
, applicationSetMenubar
, boxPackStart
, builderNewFromString
, builderSetApplication
, containerAdd
, cssProviderLoadFromData
, cssProviderNew
, dialogAddButton
, dialogGetContentArea
, dialogNew
, dialogRun
, labelNew
, notebookGetNPages
, notebookNew
, onNotebookPageRemoved
, onNotebookPageReordered
, onNotebookSwitchPage
, onWidgetDeleteEvent
, setWidgetMargin
, styleContextAddProviderForScreen
, widgetDestroy
, widgetGrabFocus
, widgetSetCanFocus
, widgetShow
, widgetShowAll
, windowPresent
, windowSetDefaultIconFromFile
, windowSetTitle
, windowSetTransientFor
)
import qualified GI.Gtk as Gtk
import GI.Pango
( FontDescription
, pattern SCALE
, fontDescriptionGetSize
, fontDescriptionGetSizeIsAbsolute
, fontDescriptionNew
, fontDescriptionSetFamily
, fontDescriptionSetSize
, fontDescriptionSetAbsoluteSize
)
import GI.Vte
( Terminal
, terminalCopyClipboard
, terminalPasteClipboard
, terminalSetFont
)
import Paths_termonad (getDataFileName)
import Termonad.Gtk (appNew, objFromBuildUnsafe)
import Termonad.Keys (handleKeyPress)
import Termonad.Lenses
( lensConfirmExit
, lensFontConfig
, lensOptions
, lensShowMenu
, lensTMNotebookTabTerm
, lensTMNotebookTabs
, lensTMStateApp
, lensTMStateConfig
, lensTMStateFontDesc
, lensTMStateNotebook
, lensTerm
)
import Termonad.Term (createTerm, relabelTabs, termExitFocused, setShowTabs)
import Termonad.Types
( FontConfig(fontFamily, fontSize)
, FontSize(FontSizePoints, FontSizeUnits)
, TMConfig
, TMNotebookTab
, TMState
, TMState'(TMState)
, getFocusedTermFromState
, modFontSize
, newEmptyTMState
, tmNotebookTabTermContainer
, tmNotebookTabs
, tmStateNotebook
)
import Termonad.XML (interfaceText, menuText)
setupScreenStyle :: IO ()
setupScreenStyle = do
maybeScreen <- screenGetDefault
case maybeScreen of
Nothing -> pure ()
Just screen -> do
cssProvider <- cssProviderNew
let (textLines :: [Text]) =
[
"scrollbar {"
, " background-color: #aaaaaa;"
, "}"
, "tab {"
, " background-color: transparent;"
, "}"
]
let styleData = encodeUtf8 (unlines textLines :: Text)
cssProviderLoadFromData cssProvider styleData
styleContextAddProviderForScreen
screen
cssProvider
(fromIntegral STYLE_PROVIDER_PRIORITY_APPLICATION)
createFontDescFromConfig :: TMConfig -> IO FontDescription
createFontDescFromConfig tmConfig = do
let fontConf = tmConfig ^. lensOptions . lensFontConfig
createFontDesc (fontSize fontConf) (fontFamily fontConf)
createFontDesc :: FontSize -> Text -> IO FontDescription
createFontDesc fontSz fontFam = do
fontDesc <- fontDescriptionNew
fontDescriptionSetFamily fontDesc fontFam
setFontDescSize fontDesc fontSz
pure fontDesc
setFontDescSize :: FontDescription -> FontSize -> IO ()
setFontDescSize fontDesc (FontSizePoints points) =
fontDescriptionSetSize fontDesc $ fromIntegral (points * fromIntegral SCALE)
setFontDescSize fontDesc (FontSizeUnits units) =
fontDescriptionSetAbsoluteSize fontDesc $ units * fromIntegral SCALE
adjustFontDescSize :: (FontSize -> FontSize) -> FontDescription -> IO ()
adjustFontDescSize f fontDesc = do
currSize <- fontDescriptionGetSize fontDesc
currAbsolute <- fontDescriptionGetSizeIsAbsolute fontDesc
let currFontSz =
if currAbsolute
then FontSizeUnits $ fromIntegral currSize / fromIntegral SCALE
else FontSizePoints $ round (fromIntegral currSize / fromIntegral SCALE)
let newFontSz = f currFontSz
setFontDescSize fontDesc newFontSz
modifyFontSizeForAllTerms :: (FontSize -> FontSize) -> TMState -> IO ()
modifyFontSizeForAllTerms modFontSize mvarTMState = do
tmState <- readMVar mvarTMState
let fontDesc = tmState ^. lensTMStateFontDesc
adjustFontDescSize modFontSize fontDesc
let terms =
tmState ^..
lensTMStateNotebook .
lensTMNotebookTabs .
traverse .
lensTMNotebookTabTerm .
lensTerm
foldMap (\vteTerm -> terminalSetFont vteTerm (Just fontDesc)) terms
compareScrolledWinAndTab :: ScrolledWindow -> TMNotebookTab -> Bool
compareScrolledWinAndTab scrollWin flTab =
let ScrolledWindow managedPtrFLTab = tmNotebookTabTermContainer flTab
foreignPtrFLTab = managedForeignPtr managedPtrFLTab
ScrolledWindow managedPtrScrollWin = scrollWin
foreignPtrScrollWin = managedForeignPtr managedPtrScrollWin
in foreignPtrFLTab == foreignPtrScrollWin
updateFLTabPos :: TMState -> Int -> Int -> IO ()
updateFLTabPos mvarTMState oldPos newPos =
modifyMVar_ mvarTMState $ \tmState -> do
let tabs = tmState ^. lensTMStateNotebook . lensTMNotebookTabs
maybeNewTabs = moveFromToFL oldPos newPos tabs
case maybeNewTabs of
Nothing -> do
putStrLn $
"in updateFLTabPos, Strange error: couldn't move tabs.\n" <>
"old pos: " <> tshow oldPos <> "\n" <>
"new pos: " <> tshow newPos <> "\n" <>
"tabs: " <> tshow tabs <> "\n" <>
"maybeNewTabs: " <> tshow maybeNewTabs <> "\n" <>
"tmState: " <> tshow tmState
pure tmState
Just newTabs ->
pure $
tmState &
lensTMStateNotebook . lensTMNotebookTabs .~ newTabs
askShouldExit :: TMState -> IO ResponseType
askShouldExit mvarTMState = do
tmState <- readMVar mvarTMState
let confirm = tmState ^. lensTMStateConfig . lensOptions . lensConfirmExit
if confirm
then confirmationDialogForExit tmState
else pure ResponseTypeYes
where
confirmationDialogForExit :: TMState' -> IO ResponseType
confirmationDialogForExit tmState = do
let app = tmState ^. lensTMStateApp
win <- applicationGetActiveWindow app
dialog <- dialogNew
box <- dialogGetContentArea dialog
label <-
labelNew $
Just
"There are still terminals running. Are you sure you want to exit?"
containerAdd box label
widgetShow label
setWidgetMargin label 10
void $
dialogAddButton
dialog
"No, do NOT exit"
(fromIntegral (fromEnum ResponseTypeNo))
void $
dialogAddButton
dialog
"Yes, exit"
(fromIntegral (fromEnum ResponseTypeYes))
windowSetTransientFor dialog win
res <- dialogRun dialog
widgetDestroy dialog
pure $ toEnum (fromIntegral res)
forceQuit :: TMState -> IO ()
forceQuit mvarTMState = do
tmState <- readMVar mvarTMState
let app = tmState ^. lensTMStateApp
applicationQuit app
setupTermonad :: TMConfig -> Application -> ApplicationWindow -> Gtk.Builder -> IO ()
setupTermonad tmConfig app win builder = do
termonadIconPath <- getDataFileName "img/termonad-lambda.png"
windowSetDefaultIconFromFile termonadIconPath
setupScreenStyle
box <- objFromBuildUnsafe builder "content_box" Box
fontDesc <- createFontDescFromConfig tmConfig
note <- notebookNew
widgetSetCanFocus note False
boxPackStart box note True True 0
mvarTMState <- newEmptyTMState tmConfig app win note fontDesc
terminal <- createTerm handleKeyPress mvarTMState
void $ onNotebookPageRemoved note $ \_ _ -> do
pages <- notebookGetNPages note
if pages == 0
then forceQuit mvarTMState
else setShowTabs tmConfig note
void $ onNotebookSwitchPage note $ \_ pageNum -> do
maybeRes <- tryTakeMVar mvarTMState
case maybeRes of
Nothing -> pure ()
Just val -> do
putMVar mvarTMState val
modifyMVar_ mvarTMState $ \tmState -> do
let notebook = tmStateNotebook tmState
tabs = tmNotebookTabs notebook
maybeNewTabs = updateFocusFL (fromIntegral pageNum) tabs
case maybeNewTabs of
Nothing -> pure tmState
Just (tab, newTabs) -> do
widgetGrabFocus $ tab ^. lensTMNotebookTabTerm . lensTerm
pure $
tmState &
lensTMStateNotebook . lensTMNotebookTabs .~ newTabs
void $ onNotebookPageReordered note $ \childWidg pageNum -> do
maybeScrollWin <- castTo ScrolledWindow childWidg
case maybeScrollWin of
Nothing ->
fail $
"In setupTermonad, in callback for onNotebookPageReordered, " <>
"child widget is not a ScrolledWindow.\n" <>
"Don't know how to continue.\n"
Just scrollWin -> do
TMState{tmStateNotebook} <- readMVar mvarTMState
let fl = tmStateNotebook ^. lensTMNotebookTabs
let maybeOldPosition =
findIndexR (compareScrolledWinAndTab scrollWin) (focusList fl)
case maybeOldPosition of
Nothing ->
fail $
"In setupTermonad, in callback for onNotebookPageReordered, " <>
"the ScrolledWindow is not already in the FocusList.\n" <>
"Don't know how to continue.\n"
Just oldPos -> do
updateFLTabPos mvarTMState oldPos (fromIntegral pageNum)
relabelTabs mvarTMState
newTabAction <- simpleActionNew "newtab" Nothing
void $ onSimpleActionActivate newTabAction $ \_ -> void $ createTerm handleKeyPress mvarTMState
actionMapAddAction app newTabAction
applicationSetAccelsForAction app "app.newtab" ["<Shift><Ctrl>T"]
closeTabAction <- simpleActionNew "closetab" Nothing
void $ onSimpleActionActivate closeTabAction $ \_ ->
termExitFocused mvarTMState
actionMapAddAction app closeTabAction
applicationSetAccelsForAction app "app.closetab" ["<Shift><Ctrl>W"]
quitAction <- simpleActionNew "quit" Nothing
void $ onSimpleActionActivate quitAction $ \_ -> do
shouldExit <- askShouldExit mvarTMState
when (shouldExit == ResponseTypeYes) $ forceQuit mvarTMState
actionMapAddAction app quitAction
applicationSetAccelsForAction app "app.quit" ["<Shift><Ctrl>Q"]
copyAction <- simpleActionNew "copy" Nothing
void $ onSimpleActionActivate copyAction $ \_ -> do
maybeTerm <- getFocusedTermFromState mvarTMState
maybe (pure ()) terminalCopyClipboard maybeTerm
actionMapAddAction app copyAction
applicationSetAccelsForAction app "app.copy" ["<Shift><Ctrl>C"]
pasteAction <- simpleActionNew "paste" Nothing
void $ onSimpleActionActivate pasteAction $ \_ -> do
maybeTerm <- getFocusedTermFromState mvarTMState
maybe (pure ()) terminalPasteClipboard maybeTerm
actionMapAddAction app pasteAction
applicationSetAccelsForAction app "app.paste" ["<Shift><Ctrl>V"]
enlargeFontAction <- simpleActionNew "enlargefont" Nothing
void $ onSimpleActionActivate enlargeFontAction $ \_ ->
modifyFontSizeForAllTerms (modFontSize 1) mvarTMState
actionMapAddAction app enlargeFontAction
applicationSetAccelsForAction app "app.enlargefont" ["<Ctrl>plus"]
reduceFontAction <- simpleActionNew "reducefont" Nothing
void $ onSimpleActionActivate reduceFontAction $ \_ ->
modifyFontSizeForAllTerms (modFontSize (-1)) mvarTMState
actionMapAddAction app reduceFontAction
applicationSetAccelsForAction app "app.reducefont" ["<Ctrl>minus"]
aboutAction <- simpleActionNew "about" Nothing
void $ onSimpleActionActivate aboutAction (const $ showAboutDialog app)
actionMapAddAction app aboutAction
when (tmConfig ^. lensOptions . lensShowMenu) $ do
menuBuilder <- builderNewFromString menuText $ fromIntegral (length menuText)
menuModel <- objFromBuildUnsafe menuBuilder "menubar" MenuModel
applicationSetMenubar app (Just menuModel)
windowSetTitle win "Termonad"
void $ onWidgetDeleteEvent win $ \_ -> do
shouldExit <- askShouldExit mvarTMState
pure $
case shouldExit of
ResponseTypeYes -> False
_ -> True
widgetShowAll win
widgetGrabFocus $ terminal ^. lensTerm
appActivate :: TMConfig -> Application -> IO ()
appActivate tmConfig app = do
uiBuilder <-
builderNewFromString interfaceText $ fromIntegral (length interfaceText)
builderSetApplication uiBuilder app
appWin <- objFromBuildUnsafe uiBuilder "appWin" ApplicationWindow
applicationAddWindow app appWin
setupTermonad tmConfig app appWin uiBuilder
windowPresent appWin
showAboutDialog :: Application -> IO ()
showAboutDialog app = do
win <- applicationGetActiveWindow app
aboutDialog <- aboutDialogNew
windowSetTransientFor aboutDialog win
void $ dialogRun aboutDialog
widgetDestroy aboutDialog
appStartup :: Application -> IO ()
appStartup _app = pure ()
start :: TMConfig -> IO ()
start tmConfig = do
app <- appNew Nothing [ApplicationFlagsFlagsNone]
void $ onApplicationStartup app (appStartup app)
void $ onApplicationActivate app (appActivate tmConfig app)
void $ applicationRun app Nothing
defaultMain :: TMConfig -> IO ()
defaultMain tmConfig = do
let params =
defaultParams
{ projectName = "termonad"
, showError = \(cfg, oldErrs) newErr -> (cfg, oldErrs <> "\n" <> newErr)
, realMain = \(cfg, errs) -> putStrLn (pack errs) *> start cfg
}
eitherRes <- tryIOError $ wrapMain params (tmConfig, "")
case eitherRes of
Left ioErr
| ioeGetErrorType ioErr == doesNotExistErrorType && ioeGetFileName ioErr == Just "ghc" -> do
putStrLn $
"Could not find ghc on your PATH. Ignoring your termonad.hs " <>
"configuration file and running termonad with default settings."
start tmConfig
| otherwise -> do
putStrLn $ "IO error occurred when trying to run termonad:"
print ioErr
putStrLn "Don't know how to recover. Exiting."
Right _ -> pure ()