module Termonad.App where import Termonad.Prelude import Config.Dyre (defaultParams, projectName, realMain, showError, wrapMain) import Control.Lens ((&), (^.), (.~)) 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 , onWidgetDestroy , setWidgetMargin , styleContextAddProviderForScreen , widgetDestroy , widgetGrabFocus , widgetSetCanFocus , widgetShow , widgetShowAll , windowClose , windowPresent , windowSetDefaultIconFromFile , windowSetTitle , windowSetTransientFor ) import qualified GI.Gtk as Gtk import GI.Pango ( FontDescription , pattern SCALE , fontDescriptionNew , fontDescriptionSetFamily , fontDescriptionSetSize ) import GI.Vte ( terminalCopyClipboard , terminalPasteClipboard ) import Paths_termonad (getDataFileName) import Termonad.Config ( FontConfig(fontFamily, fontSize) , TMConfig , lensFontConfig ) import Termonad.FocusList (findFL, moveFromToFL, updateFocusFL) import Termonad.Gtk (appNew, objFromBuildUnsafe) import Termonad.Keys (handleKeyPress) import Termonad.Term (createTerm, relabelTabs, termExitFocused) import Termonad.Types ( TMNotebookTab , TMState , TMState'(TMState) , UserRequestedExit(UserRequestedExit, UserDidNotRequestExit) , getFocusedTermFromState , getUserRequestedExit , lensTMNotebookTabs , lensTMNotebookTabTerm , lensTMStateApp , lensTMStateNotebook , lensTerm , newEmptyTMState , setUserRequestedExit , 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 {" -- , " -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 = encodeUtf8 (unlines textLines :: Text) cssProviderLoadFromData cssProvider styleData styleContextAddProviderForScreen screen cssProvider (fromIntegral STYLE_PROVIDER_PRIORITY_APPLICATION) createFontDesc :: TMConfig -> IO FontDescription createFontDesc tmConfig = do fontDesc <- fontDescriptionNew let fontConf = tmConfig ^. lensFontConfig fontDescriptionSetFamily fontDesc (fontFamily fontConf) fontDescriptionSetSize fontDesc (fromIntegral (fontSize fontConf) * SCALE) pure fontDesc compareScrolledWinAndTab :: ScrolledWindow -> a -> 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 exitWithConfirmation :: TMState -> IO () exitWithConfirmation mvarTMState = do respType <- exitWithConfirmationDialog mvarTMState case respType of ResponseTypeYes -> do setUserRequestedExit mvarTMState quit mvarTMState _ -> pure () exitWithConfirmationDialog :: TMState -> IO ResponseType exitWithConfirmationDialog mvarTMState = do tmState <- readMVar mvarTMState 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) quit :: TMState -> IO () quit mvarTMState = do tmState <- readMVar mvarTMState let app = tmState ^. lensTMStateApp maybeWin <- applicationGetActiveWindow app case maybeWin of Nothing -> applicationQuit app Just win -> windowClose win 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 <- createFontDesc 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 when (pages == 0) $ do setUserRequestedExit mvarTMState quit mvarTMState 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 = findFL (compareScrolledWinAndTab scrollWin) 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" ["T"] closeTabAction <- simpleActionNew "closetab" Nothing void $ onSimpleActionActivate closeTabAction $ \_ -> termExitFocused mvarTMState actionMapAddAction app closeTabAction applicationSetAccelsForAction app "app.closetab" ["W"] quitAction <- simpleActionNew "quit" Nothing void $ onSimpleActionActivate quitAction $ \_ -> exitWithConfirmation mvarTMState actionMapAddAction app quitAction applicationSetAccelsForAction app "app.quit" ["Q"] copyAction <- simpleActionNew "copy" Nothing void $ onSimpleActionActivate copyAction $ \_ -> do maybeTerm <- getFocusedTermFromState mvarTMState maybe (pure ()) terminalCopyClipboard maybeTerm actionMapAddAction app copyAction applicationSetAccelsForAction app "app.copy" ["C"] pasteAction <- simpleActionNew "paste" Nothing void $ onSimpleActionActivate pasteAction $ \_ -> do maybeTerm <- getFocusedTermFromState mvarTMState maybe (pure ()) terminalPasteClipboard maybeTerm actionMapAddAction app pasteAction applicationSetAccelsForAction app "app.paste" ["C"] aboutAction <- simpleActionNew "about" Nothing void $ onSimpleActionActivate aboutAction (const $ showAboutDialog app) actionMapAddAction app aboutAction menuBuilder <- builderNewFromString menuText $ fromIntegral (length menuText) menuModel <- objFromBuildUnsafe menuBuilder "menubar" MenuModel applicationSetMenubar app (Just menuModel) windowSetTitle win "Termonad" void $ onWidgetDeleteEvent win $ \_ -> do userRequestedExit <- getUserRequestedExit mvarTMState case userRequestedExit of UserRequestedExit -> pure False UserDidNotRequestExit -> do respType <- exitWithConfirmationDialog mvarTMState let stopOtherHandlers = case respType of ResponseTypeYes -> False _ -> True pure stopOtherHandlers void $ onWidgetDestroy win $ quit mvarTMState 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 (Just "haskell.termonad") [ApplicationFlagsFlagsNone] -- Make sure the application is not unique, so we can open multiple copies of it. 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 ()