diff --git a/src/Termonad/App.hs b/src/Termonad/App.hs index dc52b7c..6505383 100644 --- a/src/Termonad/App.hs +++ b/src/Termonad/App.hs @@ -4,13 +4,11 @@ module Termonad.App where import Termonad.Prelude -import Control.Lens ((^.), (^..), set, view, ix) +import Control.Lens ((^.)) import Data.FileEmbed (embedFile) -import Data.FocusList (focusList, moveFromToFL, updateFocusFL) -import Data.Sequence (findIndexR) import qualified Data.Text as Text import Data.Text.Encoding (encodeUtf8) -import GI.Gdk (castTo, managedForeignPtr, screenGetDefault) +import GI.Gdk (screenGetDefault) import GI.Gio ( ApplicationFlags(ApplicationFlagsFlagsNone) , MenuModel(MenuModel) @@ -26,11 +24,9 @@ import GI.Gtk ( Application , ApplicationWindow(ApplicationWindow) , Box(Box) - , PositionType(PositionTypeRight) + , Notebook , ResponseType(ResponseTypeNo, ResponseTypeYes) - , ScrolledWindow(ScrolledWindow) , pattern STYLE_PROVIDER_PRIORITY_APPLICATION - , aboutDialogNew , applicationAddWindow , applicationGetActiveWindow , applicationSetAccelsForAction @@ -45,20 +41,12 @@ import GI.Gtk , dialogAddButton , dialogGetContentArea , dialogNew - , dialogResponse , dialogRun - , entryGetText - , entryNew - , gridAttachNextTo - , gridNew , labelNew , notebookGetNPages , notebookNew , notebookSetShowBorder - , onEntryActivate , onNotebookPageRemoved - , onNotebookPageReordered - , onNotebookSwitchPage , onWidgetDeleteEvent , setWidgetMargin , styleContextAddProviderForScreen @@ -73,68 +61,29 @@ import GI.Gtk , windowSetTransientFor ) import qualified GI.Gtk as Gtk -import GI.Pango - ( FontDescription - , pattern SCALE - , fontDescriptionNew - , fontDescriptionSetFamily - , fontDescriptionSetSize - , fontDescriptionSetAbsoluteSize - ) -import GI.Vte - ( catchRegexError - , regexNewForSearch - , terminalCopyClipboard - , terminalPasteClipboard - , terminalSearchFindNext - , terminalSearchFindPrevious - , terminalSearchSetRegex - , terminalSearchSetWrapAround - , terminalSetFont - ) import Termonad.Gtk (appNew, imgToPixbuf, objFromBuildUnsafe) import Termonad.Keys (handleKeyPress) import Termonad.Lenses ( lensConfirmExit - , lensFontConfig , lensOptions , lensShowMenu - , lensTMNotebookTabs - , lensTMNotebookTabTerm , lensTMStateApp , lensTMStateConfig - , lensTMStateFontDesc , lensTerm - , lensTMStateWindows, lensTMWindowNotebook ) import Termonad.Preferences (showPreferencesDialog) -import Termonad.Term - ( createTerm - , relabelTabs - , termNextPage - , termPrevPage - , termExitFocused - , setShowTabs - ) +import Termonad.Term (createTerm, setShowTabs) import Termonad.Types - ( FontConfig(..) - , FontSize(FontSizePoints, FontSizeUnits) - , TMConfig - , TMNotebookTab + ( TMConfig , TMState , TMState' , TMWindowId - , fontSizeFromFontDescription - , getFocusedTermFromState - , getTMNotebookFromTMState - , getTMNotebookFromTMState' + , createFontDescFromConfig , modFontSize , newEmptyTMState - , tmNotebookTabTermContainer - , tmNotebookTabs - , tmStateApp ) import Termonad.XML (interfaceText, menuText) +import Termonad.Window (showAboutDialog, modifyFontSizeForAllTerms, setupWindowCallbacks) setupScreenStyle :: IO () setupScreenStyle = do @@ -180,77 +129,6 @@ setupScreenStyle = do 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 - currFontSz <- fontSizeFromFontDescription fontDesc - let newFontSz = f currFontSz - setFontDescSize fontDesc newFontSz - -modifyFontSizeForAllTerms :: (FontSize -> FontSize) -> TMState -> TMWindowId -> IO () -modifyFontSizeForAllTerms modFontSizeFunc mvarTMState tmWinId = do - tmState <- readMVar mvarTMState - let fontDesc = tmState ^. lensTMStateFontDesc - adjustFontDescSize modFontSizeFunc fontDesc - let terms = - tmState ^.. - lensTMStateWindows . - ix tmWinId . - lensTMWindowNotebook . - 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 -> TMWindowId -> Int -> Int -> IO () -updateFLTabPos mvarTMState tmWinId oldPos newPos = - modifyMVar_ mvarTMState $ \tmState -> do - note <- getTMNotebookFromTMState' tmState tmWinId - let tabs = tmNotebookTabs note - maybeNewTabs = moveFromToFL oldPos newPos tabs - case maybeNewTabs of - Nothing -> do - putStrLn $ - "in updateFLTabPos, Strange error: couldn't move tabs.\n" <> - "old pos: " <> show oldPos <> "\n" <> - "new pos: " <> show newPos <> "\n" <> - "tabs: " <> show tabs <> "\n" <> - "maybeNewTabs: " <> show maybeNewTabs <> "\n" <> - "tmState: " <> show tmState - pure tmState - Just newTabs -> - pure $ - set - (lensTMStateWindows . ix tmWinId . lensTMWindowNotebook . lensTMNotebookTabs) - newTabs - tmState - -- | Try to figure out whether Termonad should exit. This also used to figure -- out if Termonad should close a given terminal. -- @@ -312,66 +190,8 @@ forceQuit mvarTMState = do let app = tmState ^. lensTMStateApp applicationQuit app -setupTermonad :: TMConfig -> Application -> ApplicationWindow -> Gtk.Builder -> IO () -setupTermonad tmConfig app win builder = do - 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, tmWinId) <- newEmptyTMState tmConfig app win note fontDesc - terminal <- createTerm handleKeyPress mvarTMState tmWinId - - void $ onNotebookPageRemoved note $ \_ _ -> do - pages <- notebookGetNPages note - if pages == 0 - then forceQuit mvarTMState - else setShowTabs tmConfig note - - void $ onNotebookSwitchPage note $ \_ pageNum -> do - modifyMVar_ mvarTMState $ \tmState -> do - tmNote <- getTMNotebookFromTMState' tmState tmWinId - let tabs = tmNotebookTabs tmNote - maybeNewTabs = updateFocusFL (fromIntegral pageNum) tabs - case maybeNewTabs of - Nothing -> pure tmState - Just (tab, newTabs) -> do - widgetGrabFocus $ tab ^. lensTMNotebookTabTerm . lensTerm - pure $ - set - (lensTMStateWindows . ix tmWinId . lensTMWindowNotebook . lensTMNotebookTabs) - newTabs - tmState - - 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 - tmNote <- getTMNotebookFromTMState mvarTMState tmWinId - let fl = view lensTMNotebookTabs tmNote - 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 tmWinId oldPos (fromIntegral pageNum) - tmNote' <- getTMNotebookFromTMState mvarTMState tmWinId - relabelTabs tmNote' - +setupAppCallbacks :: TMState -> TMConfig -> Application -> ApplicationWindow -> Notebook -> TMWindowId -> IO () +setupAppCallbacks mvarTMState tmConfig app win note tmWinId = do newWindowAction <- simpleActionNew "newwin" Nothing void $ onSimpleActionActivate newWindowAction $ \_ -> pure () @@ -379,29 +199,11 @@ setupTermonad tmConfig app win builder = do actionMapAddAction app newWindowAction applicationSetAccelsForAction app "app.newwin" ["N"] - newTabAction <- simpleActionNew "newtab" Nothing - void $ onSimpleActionActivate newTabAction $ \_ -> - void $ createTerm handleKeyPress mvarTMState tmWinId - actionMapAddAction win newTabAction - applicationSetAccelsForAction app "win.newtab" ["T"] - - nextPageAction <- simpleActionNew "nextpage" Nothing - void $ onSimpleActionActivate nextPageAction $ \_ -> - termNextPage mvarTMState tmWinId - actionMapAddAction win nextPageAction - applicationSetAccelsForAction app "win.nextpage" ["Page_Down"] - - prevPageAction <- simpleActionNew "prevpage" Nothing - void $ onSimpleActionActivate prevPageAction $ \_ -> - termPrevPage mvarTMState tmWinId - actionMapAddAction win prevPageAction - applicationSetAccelsForAction app "win.prevpage" ["Page_Up"] - - closeTabAction <- simpleActionNew "closetab" Nothing - void $ onSimpleActionActivate closeTabAction $ \_ -> - termExitFocused mvarTMState tmWinId - actionMapAddAction win closeTabAction - applicationSetAccelsForAction app "win.closetab" ["W"] + void $ onNotebookPageRemoved note $ \_ _ -> do + pages <- notebookGetNPages note + if pages == 0 + then forceQuit mvarTMState + else setShowTabs tmConfig note quitAction <- simpleActionNew "quit" Nothing void $ onSimpleActionActivate quitAction $ \_ -> do @@ -410,20 +212,6 @@ setupTermonad tmConfig app win builder = do actionMapAddAction app quitAction applicationSetAccelsForAction app "app.quit" ["Q"] - copyAction <- simpleActionNew "copy" Nothing - void $ onSimpleActionActivate copyAction $ \_ -> do - maybeTerm <- getFocusedTermFromState mvarTMState tmWinId - maybe (pure ()) terminalCopyClipboard maybeTerm - actionMapAddAction win copyAction - applicationSetAccelsForAction app "win.copy" ["C"] - - pasteAction <- simpleActionNew "paste" Nothing - void $ onSimpleActionActivate pasteAction $ \_ -> do - maybeTerm <- getFocusedTermFromState mvarTMState tmWinId - maybe (pure ()) terminalPasteClipboard maybeTerm - actionMapAddAction win pasteAction - applicationSetAccelsForAction app "win.paste" ["V"] - preferencesAction <- simpleActionNew "preferences" Nothing void $ onSimpleActionActivate preferencesAction (const $ showPreferencesDialog mvarTMState) actionMapAddAction app preferencesAction @@ -440,33 +228,10 @@ setupTermonad tmConfig app win builder = do actionMapAddAction app reduceFontAction applicationSetAccelsForAction app "app.reducefont" ["minus"] - findAction <- simpleActionNew "find" Nothing - void $ onSimpleActionActivate findAction $ \_ -> doFind mvarTMState tmWinId - actionMapAddAction win findAction - applicationSetAccelsForAction app "win.find" ["F"] - - findAboveAction <- simpleActionNew "findabove" Nothing - void $ onSimpleActionActivate findAboveAction $ \_ -> findAbove mvarTMState tmWinId - actionMapAddAction win findAboveAction - applicationSetAccelsForAction app "win.findabove" ["P"] - - findBelowAction <- simpleActionNew "findbelow" Nothing - void $ onSimpleActionActivate findBelowAction $ \_ -> findBelow mvarTMState tmWinId - actionMapAddAction win findBelowAction - applicationSetAccelsForAction app "win.findbelow" ["I"] - aboutAction <- simpleActionNew "about" Nothing - void $ onSimpleActionActivate aboutAction $ \_ -> showAboutDialog app + void $ onSimpleActionActivate aboutAction $ \_ -> showAboutDialog win actionMapAddAction app aboutAction - menuBuilder <- builderNewFromString menuText $ fromIntegral (Text.length menuText) - menuModel <- objFromBuildUnsafe menuBuilder "menubar" MenuModel - applicationSetMenubar app (Just menuModel) - let showMenu = tmConfig ^. lensOptions . 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, @@ -482,6 +247,32 @@ setupTermonad tmConfig app win builder = do ResponseTypeYes -> False _ -> True +setupTermonad :: TMConfig -> Application -> ApplicationWindow -> Gtk.Builder -> IO () +setupTermonad tmConfig app win builder = do + 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, tmWinId) <- newEmptyTMState tmConfig app win note fontDesc + terminal <- createTerm handleKeyPress mvarTMState tmWinId + + setupAppCallbacks mvarTMState tmConfig app win note tmWinId + setupWindowCallbacks mvarTMState app win note tmWinId + + menuBuilder <- builderNewFromString menuText $ fromIntegral (Text.length menuText) + menuModel <- objFromBuildUnsafe menuBuilder "menubar" MenuModel + applicationSetMenubar app (Just menuModel) + let showMenu = tmConfig ^. lensOptions . lensShowMenu + applicationWindowSetShowMenubar win showMenu + + windowSetTitle win "Termonad" + widgetShowAll win widgetGrabFocus $ terminal ^. lensTerm @@ -498,137 +289,6 @@ appActivate tmConfig app = do 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 - -showFindDialog :: Application -> IO (Maybe Text) -showFindDialog app = do - win <- applicationGetActiveWindow 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 toEnum (fromIntegral res) of - ResponseTypeYes -> Just searchString - _ -> Nothing - - widgetDestroy dialog - - pure maybeSearchString - -doFind :: TMState -> TMWindowId -> IO () -doFind mvarTMState tmWinId = do - tmState <- readMVar mvarTMState - let app = tmStateApp tmState - maybeSearchString <- showFindDialog app - -- putStrLn $ "trying to find: " <> tshow maybeSearchString - maybeTerminal <- getFocusedTermFromState mvarTMState tmWinId - case (maybeSearchString, maybeTerminal) of - (Just searchString, Just 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 = 0 - let newRegex = - regexNewForSearch - searchString - (fromIntegral $ Text.length searchString) - pcreFlags - eitherRegex <- - catchRegexError - (fmap Right newRegex) - (\_ errMsg -> pure (Left errMsg)) - case eitherRegex of - Left errMsg -> do - let msg = "error when creating regex: " <> errMsg - hPutStrLn stderr msg - Right regex -> do - terminalSearchSetRegex terminal (Just regex) pcreFlags - terminalSearchSetWrapAround terminal True - _matchFound <- terminalSearchFindPrevious 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 () - _ -> pure () - -findAbove :: TMState -> TMWindowId -> IO () -findAbove mvarTMState tmWinId = do - maybeTerminal <- getFocusedTermFromState mvarTMState tmWinId - case maybeTerminal of - Nothing -> pure () - Just terminal -> do - _matchFound <- terminalSearchFindPrevious terminal - -- putStrLn $ "was match found: " <> tshow matchFound - pure () - -findBelow :: TMState -> TMWindowId -> IO () -findBelow mvarTMState tmWinId = do - maybeTerminal <- getFocusedTermFromState mvarTMState tmWinId - case maybeTerminal of - Nothing -> pure () - Just terminal -> do - _matchFound <- terminalSearchFindNext terminal - -- putStrLn $ "was match found: " <> tshow matchFound - pure () - -setShowMenuBar :: Application -> Bool -> IO () -setShowMenuBar app visible = do - void $ runMaybeT $ do - win <- MaybeT $ applicationGetActiveWindow app - appWin <- MaybeT $ castTo ApplicationWindow win - lift $ applicationWindowSetShowMenubar appWin visible - appStartup :: Application -> IO () appStartup _app = pure () diff --git a/src/Termonad/Types.hs b/src/Termonad/Types.hs index 90eaf2b..155e9a0 100644 --- a/src/Termonad/Types.hs +++ b/src/Termonad/Types.hs @@ -26,7 +26,7 @@ import GI.Gtk , notebookGetNthPage , notebookGetNPages ) -import GI.Pango (FontDescription, fontDescriptionGetSize, fontDescriptionGetSizeIsAbsolute, pattern SCALE, fontDescriptionGetFamily) +import GI.Pango (FontDescription, fontDescriptionGetSize, fontDescriptionGetSizeIsAbsolute, pattern SCALE, fontDescriptionGetFamily, fontDescriptionNew, fontDescriptionSetFamily, fontDescriptionSetSize, fontDescriptionSetAbsoluteSize) import GI.Vte (Terminal, CursorBlinkMode(..)) import Termonad.Gtk (widgetEq) import Termonad.IdMap (IdMap, IdMapKey, singletonIdMap, lookupIdMap) @@ -343,6 +343,31 @@ fontSizeFromFontDescription fontDesc = do let fontRatio :: Double = fromIntegral currSize / fromIntegral SCALE in FontSizePoints $ round fontRatio +-- | Create a 'FontDescription' from a 'FontSize' and font family. +createFontDesc + :: FontSize + -> Text + -- ^ font family + -> IO FontDescription +createFontDesc fontSz fontFam = do + fontDesc <- fontDescriptionNew + fontDescriptionSetFamily fontDesc fontFam + setFontDescSize fontDesc fontSz + pure fontDesc + +-- | Set the size of a 'FontDescription' from a 'FontSize'. +setFontDescSize :: FontDescription -> FontSize -> IO () +setFontDescSize fontDesc (FontSizePoints points) = + fontDescriptionSetSize fontDesc $ fromIntegral (points * fromIntegral SCALE) +setFontDescSize fontDesc (FontSizeUnits units) = + fontDescriptionSetAbsoluteSize fontDesc $ units * fromIntegral SCALE + +-- | Create a 'FontDescription' from the 'fontSize' and 'fontFamily' inside a 'TMConfig'. +createFontDescFromConfig :: TMConfig -> IO FontDescription +createFontDescFromConfig tmConfig = do + let fontConf = fontConfig (options tmConfig) + createFontDesc (fontSize fontConf) (fontFamily fontConf) + -- | Settings for the font to be used in Termonad. data FontConfig = FontConfig { fontFamily :: !Text diff --git a/src/Termonad/Window.hs b/src/Termonad/Window.hs new file mode 100644 index 0000000..c73ad67 --- /dev/null +++ b/src/Termonad/Window.hs @@ -0,0 +1,386 @@ + +module Termonad.Window where + +import Termonad.Prelude + +import Control.Lens ((^.), (^..), set, view, ix) +import Data.FocusList (focusList, moveFromToFL, updateFocusFL) +import Data.Sequence (findIndexR) +import qualified Data.Text as Text +import GI.Gdk (castTo, managedForeignPtr) +import GI.Gio + ( actionMapAddAction + , onSimpleActionActivate + , simpleActionNew + ) +import GI.Gtk + ( Application + , ApplicationWindow + , Notebook + , PositionType(PositionTypeRight) + , ResponseType(ResponseTypeNo, ResponseTypeYes) + , ScrolledWindow(ScrolledWindow) + , Widget + , aboutDialogNew + , applicationSetAccelsForAction + , containerAdd + , dialogAddButton + , dialogGetContentArea + , dialogNew + , dialogResponse + , dialogRun + , entryGetText + , entryNew + , gridAttachNextTo + , gridNew + , labelNew + , onEntryActivate + , onNotebookPageReordered + , onNotebookSwitchPage + , setWidgetMargin + , widgetDestroy + , widgetGrabFocus + , widgetShow + , windowSetTransientFor + ) +import GI.Pango (FontDescription) +import GI.Vte + ( catchRegexError + , regexNewForSearch + , terminalCopyClipboard + , terminalPasteClipboard + , terminalSearchFindNext + , terminalSearchFindPrevious + , terminalSearchSetRegex + , terminalSearchSetWrapAround + , terminalSetFont + ) +import Termonad.Keys (handleKeyPress) +import Termonad.Lenses + ( lensTMNotebookTabs + , lensTMNotebookTabTerm + , lensTMStateFontDesc + , lensTerm + , lensTMStateWindows + , lensTMWindowNotebook + ) +import Termonad.Term + ( createTerm + , relabelTabs + , termNextPage + , termPrevPage + , termExitFocused + ) +import Termonad.Types + ( FontSize + , TMNotebookTab + , TMState + , TMWindowId + , fontSizeFromFontDescription + , getFocusedTermFromState + , getTMNotebookFromTMState + , getTMNotebookFromTMState' + , getTMWindowFromTMState + , setFontDescSize + , tmNotebookTabTermContainer + , tmNotebookTabs + , tmWindowAppWin + ) + +modifyFontSizeForAllTerms :: (FontSize -> FontSize) -> TMState -> TMWindowId -> IO () +modifyFontSizeForAllTerms modFontSizeFunc mvarTMState tmWinId = do + tmState <- readMVar mvarTMState + let fontDesc = tmState ^. lensTMStateFontDesc + adjustFontDescSize modFontSizeFunc fontDesc + let terms = + tmState ^.. + lensTMStateWindows . + ix tmWinId . + lensTMWindowNotebook . + lensTMNotebookTabs . + traverse . + lensTMNotebookTabTerm . + lensTerm + foldMap (\vteTerm -> terminalSetFont vteTerm (Just fontDesc)) terms + where + adjustFontDescSize :: (FontSize -> FontSize) -> FontDescription -> IO () + adjustFontDescSize f fontDesc = do + currFontSz <- fontSizeFromFontDescription fontDesc + let newFontSz = f currFontSz + setFontDescSize fontDesc newFontSz + +-- | This is the callback for when a page in a 'Notebook' has been reordered +-- (normally caused by a drag-and-drop event). +notebookPageReorderedCallback + :: TMState + -> TMWindowId + -> Widget + -- ^ The child widget that is in the Notebook page. + -> Word32 + -- ^ The new index of the Notebook page. + -> IO () +notebookPageReorderedCallback mvarTMState tmWinId 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 + tmNote <- getTMNotebookFromTMState mvarTMState tmWinId + let fl = view lensTMNotebookTabs tmNote + 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 tmWinId oldPos (fromIntegral pageNum) + tmNote' <- getTMNotebookFromTMState mvarTMState tmWinId + relabelTabs tmNote' + where + compareScrolledWinAndTab :: ScrolledWindow -> TMNotebookTab -> Bool + compareScrolledWinAndTab scrollWin flTab = + let ScrolledWindow managedPtrFLTab = tmNotebookTabTermContainer flTab + foreignPtrFLTab = managedForeignPtr managedPtrFLTab + ScrolledWindow managedPtrScrollWin = scrollWin + foreignPtrScrollWin = managedForeignPtr managedPtrScrollWin + in foreignPtrFLTab == foreignPtrScrollWin + +-- | Move a 'TMNotebookTab' from one position to another. +-- +-- If the current position index is out of bounds, or the new index is out of +-- bounds, then nothing will be done. +-- +-- Note that this function doesn't change anything about the 'tmNotebook'. +-- This function is meant to be used as a call-back for when a 'Notebook's +-- tab-order has been changed. +updateFLTabPos + :: TMState + -> TMWindowId + -> Int + -- ^ Current position index. + -> Int + -- ^ New position index. + -> IO () +updateFLTabPos mvarTMState tmWinId oldPos newPos = + modifyMVar_ mvarTMState $ \tmState -> do + note <- getTMNotebookFromTMState' tmState tmWinId + let tabs = tmNotebookTabs note + maybeNewTabs = moveFromToFL oldPos newPos tabs + case maybeNewTabs of + Nothing -> do + putStrLn $ + "in updateFLTabPos, Strange error: couldn't move tabs.\n" <> + "old pos: " <> show oldPos <> "\n" <> + "new pos: " <> show newPos <> "\n" <> + "tabs: " <> show tabs <> "\n" <> + "maybeNewTabs: " <> show maybeNewTabs <> "\n" <> + "tmState: " <> show tmState + pure tmState + Just newTabs -> + pure $ + set + (lensTMStateWindows . ix tmWinId . lensTMWindowNotebook . lensTMNotebookTabs) + newTabs + tmState + +showAboutDialog :: ApplicationWindow -> IO () +showAboutDialog win = do + aboutDialog <- aboutDialogNew + windowSetTransientFor aboutDialog (Just win) + void $ dialogRun aboutDialog + widgetDestroy aboutDialog + +showFindDialog :: ApplicationWindow -> IO (Maybe Text) +showFindDialog win = do + 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 (Just win) + res <- dialogRun dialog + + searchString <- entryGetText searchEntry + let maybeSearchString = + case toEnum (fromIntegral res) of + ResponseTypeYes -> Just searchString + _ -> Nothing + + widgetDestroy dialog + + pure maybeSearchString + +doFind :: TMState -> TMWindowId -> IO () +doFind mvarTMState tmWinId = do + tmWin <- getTMWindowFromTMState mvarTMState tmWinId + let win = tmWindowAppWin tmWin + maybeSearchString <- showFindDialog win + -- putStrLn $ "trying to find: " <> tshow maybeSearchString + maybeTerminal <- getFocusedTermFromState mvarTMState tmWinId + case (maybeSearchString, maybeTerminal) of + (Just searchString, Just 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 = 0 + let newRegex = + regexNewForSearch + searchString + (fromIntegral $ Text.length searchString) + pcreFlags + eitherRegex <- + catchRegexError + (fmap Right newRegex) + (\_ errMsg -> pure (Left errMsg)) + case eitherRegex of + Left errMsg -> do + let msg = "error when creating regex: " <> errMsg + hPutStrLn stderr msg + Right regex -> do + terminalSearchSetRegex terminal (Just regex) pcreFlags + terminalSearchSetWrapAround terminal True + _matchFound <- terminalSearchFindPrevious 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 () + _ -> pure () + +findAbove :: TMState -> TMWindowId -> IO () +findAbove mvarTMState tmWinId = do + maybeTerminal <- getFocusedTermFromState mvarTMState tmWinId + case maybeTerminal of + Nothing -> pure () + Just terminal -> do + _matchFound <- terminalSearchFindPrevious terminal + -- putStrLn $ "was match found: " <> tshow matchFound + pure () + +findBelow :: TMState -> TMWindowId -> IO () +findBelow mvarTMState tmWinId = do + maybeTerminal <- getFocusedTermFromState mvarTMState tmWinId + case maybeTerminal of + Nothing -> pure () + Just terminal -> do + _matchFound <- terminalSearchFindNext terminal + -- putStrLn $ "was match found: " <> tshow matchFound + pure () + +setupWindowCallbacks :: TMState -> Application -> ApplicationWindow -> Notebook -> TMWindowId -> IO () +setupWindowCallbacks mvarTMState app win note tmWinId = do + + void $ onNotebookSwitchPage note $ \_ pageNum -> do + modifyMVar_ mvarTMState $ \tmState -> do + tmNote <- getTMNotebookFromTMState' tmState tmWinId + let tabs = tmNotebookTabs tmNote + maybeNewTabs = updateFocusFL (fromIntegral pageNum) tabs + case maybeNewTabs of + Nothing -> pure tmState + Just (tab, newTabs) -> do + widgetGrabFocus $ tab ^. lensTMNotebookTabTerm . lensTerm + pure $ + set + (lensTMStateWindows . ix tmWinId . lensTMWindowNotebook . lensTMNotebookTabs) + newTabs + tmState + + void $ onNotebookPageReordered note $ \childWidg pageNum -> + notebookPageReorderedCallback mvarTMState tmWinId childWidg pageNum + + newTabAction <- simpleActionNew "newtab" Nothing + void $ onSimpleActionActivate newTabAction $ \_ -> + void $ createTerm handleKeyPress mvarTMState tmWinId + actionMapAddAction win newTabAction + applicationSetAccelsForAction app "win.newtab" ["T"] + + nextPageAction <- simpleActionNew "nextpage" Nothing + void $ onSimpleActionActivate nextPageAction $ \_ -> + termNextPage mvarTMState tmWinId + actionMapAddAction win nextPageAction + applicationSetAccelsForAction app "win.nextpage" ["Page_Down"] + + prevPageAction <- simpleActionNew "prevpage" Nothing + void $ onSimpleActionActivate prevPageAction $ \_ -> + termPrevPage mvarTMState tmWinId + actionMapAddAction win prevPageAction + applicationSetAccelsForAction app "win.prevpage" ["Page_Up"] + + closeTabAction <- simpleActionNew "closetab" Nothing + void $ onSimpleActionActivate closeTabAction $ \_ -> + termExitFocused mvarTMState tmWinId + actionMapAddAction win closeTabAction + applicationSetAccelsForAction app "win.closetab" ["W"] + + copyAction <- simpleActionNew "copy" Nothing + void $ onSimpleActionActivate copyAction $ \_ -> do + maybeTerm <- getFocusedTermFromState mvarTMState tmWinId + maybe (pure ()) terminalCopyClipboard maybeTerm + actionMapAddAction win copyAction + applicationSetAccelsForAction app "win.copy" ["C"] + + pasteAction <- simpleActionNew "paste" Nothing + void $ onSimpleActionActivate pasteAction $ \_ -> do + maybeTerm <- getFocusedTermFromState mvarTMState tmWinId + maybe (pure ()) terminalPasteClipboard maybeTerm + actionMapAddAction win pasteAction + applicationSetAccelsForAction app "win.paste" ["V"] + + findAction <- simpleActionNew "find" Nothing + void $ onSimpleActionActivate findAction $ \_ -> doFind mvarTMState tmWinId + actionMapAddAction win findAction + applicationSetAccelsForAction app "win.find" ["F"] + + findAboveAction <- simpleActionNew "findabove" Nothing + void $ onSimpleActionActivate findAboveAction $ \_ -> findAbove mvarTMState tmWinId + actionMapAddAction win findAboveAction + applicationSetAccelsForAction app "win.findabove" ["P"] + + findBelowAction <- simpleActionNew "findbelow" Nothing + void $ onSimpleActionActivate findBelowAction $ \_ -> findBelow mvarTMState tmWinId + actionMapAddAction win findBelowAction + applicationSetAccelsForAction app "win.findbelow" ["I"] diff --git a/termonad.cabal b/termonad.cabal index 14ab824..f247dda 100644 --- a/termonad.cabal +++ b/termonad.cabal @@ -74,6 +74,7 @@ library , Termonad.Startup , Termonad.Term , Termonad.Types + , Termonad.Window , Termonad.XML other-modules: Paths_termonad build-depends: base >= 4.13 && < 5