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"]