diff --git a/README.md b/README.md index b038d96..2b4047c 100644 --- a/README.md +++ b/README.md @@ -529,3 +529,4 @@ would like to add, please submit an issue or PR. ## Maintainers - [cdepillabout](https://github.com/cdepillabout) +- [gelisam](https://github.com/gelisam) diff --git a/src/Termonad/App.hs b/src/Termonad/App.hs index d219ea3..d357359 100644 --- a/src/Termonad/App.hs +++ b/src/Termonad/App.hs @@ -29,10 +29,10 @@ import GI.Gtk , Entry(Entry) , FontButton(FontButton) , Label(Label) + , Paned(Paned) , PolicyType(PolicyTypeAutomatic) , PositionType(PositionTypeRight) , ResponseType(ResponseTypeAccept, ResponseTypeNo, ResponseTypeYes) - , ScrolledWindow(ScrolledWindow) , SpinButton(SpinButton) , pattern STYLE_PROVIDER_PRIORITY_APPLICATION , aboutDialogNew @@ -138,24 +138,26 @@ import Termonad.Lenses , lensShowTabBar , lensScrollbackLen , lensTMNotebook - , lensTMNotebookTabTermContainer + , lensTMNotebookTabFocusedTerm , lensTMNotebookTabs - , lensTMNotebookTabTerm , lensTMStateApp , lensTMStateAppWin , lensTMStateConfig , lensTMStateFontDesc , lensTMStateNotebook + , lensTMTermScrolledWindow , lensTerm , lensWordCharExceptions + , traversalTMNotebookTabTerms ) import Termonad.PreferencesFile (saveToPreferencesFile) import Termonad.Term - ( createTerm + ( createTerms , relabelTabs + , termExitFocused , termNextPage , termPrevPage - , termExitFocused + , termTogglePane , setShowTabs , showScrollbarToPolicy ) @@ -169,11 +171,12 @@ import Termonad.Types , TMNotebookTab , TMState , TMState'(TMState) + , TMTerm , getFocusedTermFromState , modFontSize , newEmptyTMState - , tmNotebookTabTermContainer , tmNotebookTabs + , tmNotebookTabPaned , tmStateApp , tmStateNotebook ) @@ -257,7 +260,7 @@ modifyFontSizeForAllTerms modFontSizeFunc mvarTMState = do lensTMStateNotebook . lensTMNotebookTabs . traverse . - lensTMNotebookTabTerm . + traversalTMNotebookTabTerms . lensTerm foldMap (\vteTerm -> terminalSetFont vteTerm (Just fontDesc)) terms @@ -277,13 +280,13 @@ fontConfigFromFontDescription fontDescription = do maybeFontFamily <- fontDescriptionGetFamily fontDescription return $ (`FontConfig` fontSize) <$> maybeFontFamily -compareScrolledWinAndTab :: ScrolledWindow -> TMNotebookTab -> Bool -compareScrolledWinAndTab scrollWin flTab = - let ScrolledWindow managedPtrFLTab = tmNotebookTabTermContainer flTab +comparePanedAndTab :: Paned -> TMNotebookTab -> Bool +comparePanedAndTab paned flTab = + let Paned managedPtrFLTab = tmNotebookTabPaned flTab foreignPtrFLTab = managedForeignPtr managedPtrFLTab - ScrolledWindow managedPtrScrollWin = scrollWin - foreignPtrScrollWin = managedForeignPtr managedPtrScrollWin - in foreignPtrFLTab == foreignPtrScrollWin + Paned managedPtrPaned = paned + foreignPtrPaned = managedForeignPtr managedPtrPaned + in foreignPtrFLTab == foreignPtrPaned updateFLTabPos :: TMState -> Int -> Int -> IO () updateFLTabPos mvarTMState oldPos newPos = @@ -382,7 +385,7 @@ setupTermonad tmConfig app win builder = do boxPackStart box note True True 0 mvarTMState <- newEmptyTMState tmConfig app win note fontDesc - terminal <- createTerm handleKeyPress mvarTMState + (terminalL, _terminalR) <- createTerms handleKeyPress mvarTMState void $ onNotebookPageRemoved note $ \_ _ -> do pages <- notebookGetNPages note @@ -391,57 +394,74 @@ setupTermonad tmConfig app win builder = do else setShowTabs tmConfig note void $ onNotebookSwitchPage note $ \_ pageNum -> do - modifyMVar_ mvarTMState $ \tmState -> do + followUp <- modifyMVar mvarTMState $ \tmState -> do let notebook = tmStateNotebook tmState tabs = tmNotebookTabs notebook maybeNewTabs = updateFocusFL (fromIntegral pageNum) tabs case maybeNewTabs of - Nothing -> pure tmState + Nothing -> do + pure (tmState, pure ()) Just (tab, newTabs) -> do - widgetGrabFocus $ tab ^. lensTMNotebookTabTerm . lensTerm - pure $ - tmState & - lensTMStateNotebook . lensTMNotebookTabs .~ newTabs + let followUp = do + let newFocus = tab ^. lensTMNotebookTabFocusedTerm . lensTerm + widgetGrabFocus newFocus + tmState' + = tmState + & lensTMStateNotebook . lensTMNotebookTabs .~ newTabs + pure (tmState', followUp) + followUp void $ onNotebookPageReordered note $ \childWidg pageNum -> do - maybeScrollWin <- castTo ScrolledWindow childWidg - case maybeScrollWin of + maybePaned <- castTo Paned childWidg + case maybePaned of Nothing -> fail $ "In setupTermonad, in callback for onNotebookPageReordered, " <> - "child widget is not a ScrolledWindow.\n" <> + "child widget is not a Paned.\n" <> "Don't know how to continue.\n" - Just scrollWin -> do + Just paned -> do TMState{tmStateNotebook} <- readMVar mvarTMState let fl = tmStateNotebook ^. lensTMNotebookTabs let maybeOldPosition = - findIndexR (compareScrolledWinAndTab scrollWin) (focusList fl) + findIndexR (comparePanedAndTab paned) (focusList fl) case maybeOldPosition of Nothing -> fail $ "In setupTermonad, in callback for onNotebookPageReordered, " <> - "the ScrolledWindow is not already in the FocusList.\n" <> + "the Paned 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 + void $ onSimpleActionActivate newTabAction $ \_ -> void $ createTerms handleKeyPress mvarTMState actionMapAddAction app newTabAction applicationSetAccelsForAction app "app.newtab" ["T"] + nextPaneAction <- simpleActionNew "nextpane" Nothing + void $ onSimpleActionActivate nextPaneAction $ \_ -> + termTogglePane mvarTMState + actionMapAddAction app nextPaneAction + applicationSetAccelsForAction app "app.nextpane" ["Page_Down"] + + prevPaneAction <- simpleActionNew "prevpane" Nothing + void $ onSimpleActionActivate prevPaneAction $ \_ -> + termTogglePane mvarTMState + actionMapAddAction app prevPaneAction + applicationSetAccelsForAction app "app.prevpane" ["Page_Up"] + nextPageAction <- simpleActionNew "nextpage" Nothing void $ onSimpleActionActivate nextPageAction $ \_ -> termNextPage mvarTMState actionMapAddAction app nextPageAction - applicationSetAccelsForAction app "app.nextpage" ["Page_Down"] + applicationSetAccelsForAction app "app.nextpage" ["Page_Down"] prevPageAction <- simpleActionNew "prevpage" Nothing void $ onSimpleActionActivate prevPageAction $ \_ -> termPrevPage mvarTMState actionMapAddAction app prevPageAction - applicationSetAccelsForAction app "app.prevpage" ["Page_Up"] + applicationSetAccelsForAction app "app.prevpage" ["Page_Up"] closeTabAction <- simpleActionNew "closetab" Nothing void $ onSimpleActionActivate closeTabAction $ \_ -> @@ -478,13 +498,13 @@ setupTermonad tmConfig app win builder = do void $ onSimpleActionActivate enlargeFontAction $ \_ -> modifyFontSizeForAllTerms (modFontSize 1) mvarTMState actionMapAddAction app enlargeFontAction - applicationSetAccelsForAction app "app.enlargefont" ["plus"] + applicationSetAccelsForAction app "app.enlargefont" ["KP_Add"] reduceFontAction <- simpleActionNew "reducefont" Nothing void $ onSimpleActionActivate reduceFontAction $ \_ -> modifyFontSizeForAllTerms (modFontSize (-1)) mvarTMState actionMapAddAction app reduceFontAction - applicationSetAccelsForAction app "app.reducefont" ["minus"] + applicationSetAccelsForAction app "app.reducefont" ["KP_Subtract"] findAction <- simpleActionNew "find" Nothing void $ onSimpleActionActivate findAction $ \_ -> doFind mvarTMState @@ -528,8 +548,9 @@ setupTermonad tmConfig app win builder = do ResponseTypeYes -> False _ -> True + -- Focus on the left terminal widgetShowAll win - widgetGrabFocus $ terminal ^. lensTerm + widgetGrabFocus $ terminalL ^. lensTerm appActivate :: TMConfig -> Application -> IO () appActivate tmConfig app = do @@ -717,10 +738,15 @@ applyNewPreferences mvarTMState = do applyNewPreferencesToTab :: TMState -> TMNotebookTab -> IO () applyNewPreferencesToTab mvarTMState tab = do + for_ (tab ^.. traversalTMNotebookTabTerms) $ \tmTerm -> do + applyNewPreferencesToTerm mvarTMState tmTerm + +applyNewPreferencesToTerm :: TMState -> TMTerm -> IO () +applyNewPreferencesToTerm mvarTMState tmTerm = do tmState <- readMVar mvarTMState let fontDesc = tmState ^. lensTMStateFontDesc - term = tab ^. lensTMNotebookTabTerm . lensTerm - scrolledWin = tab ^. lensTMNotebookTabTermContainer + term = tmTerm ^. lensTerm + scrolledWin = tmTerm ^. lensTMTermScrolledWindow options = tmState ^. lensTMStateConfig . lensOptions terminalSetFont term (Just fontDesc) terminalSetCursorBlinkMode term (cursorBlinkMode options) @@ -731,6 +757,7 @@ applyNewPreferencesToTab mvarTMState tab = do let vScrollbarPolicy = showScrollbarToPolicy (options ^. lensShowScrollbar) scrolledWindowSetPolicy scrolledWin PolicyTypeAutomatic vScrollbarPolicy + -- | Show the preferences dialog. -- -- When the user clicks on the Ok button, it copies the new settings to TMState. diff --git a/src/Termonad/Gtk.hs b/src/Termonad/Gtk.hs index 2ef50fc..c17f10b 100644 --- a/src/Termonad/Gtk.hs +++ b/src/Termonad/Gtk.hs @@ -4,6 +4,7 @@ import Termonad.Prelude import Control.Monad.Fail (MonadFail, fail) import Data.GI.Base (ManagedPtr, withManagedPtr) +import Data.GI.Base.GObject (gtypeFromInstance) import GHC.Stack (HasCallStack) import GI.Gdk ( GObject @@ -58,3 +59,20 @@ widgetEq a b = do withManagedPtr managedPtrA $ \ptrA -> withManagedPtr managedPtrB $ \ptrB -> pure (ptrA == ptrB) + +printWidgetTree :: Gtk.IsWidget a => a -> IO () +printWidgetTree widget_ = do + widget <- Gtk.toWidget widget_ + go "" widget + where + go :: Text -> Gtk.Widget -> IO () + go indent w = do + type_ <- gtypeFromInstance w + name <- Gtk.gtypeName type_ + let ptr = Gtk.managedForeignPtr . Gtk.toManagedPtr $ w + putStrLn $ indent <> pack name <> " " <> pack (show ptr) + maybeContainer <- Gtk.castTo Gtk.Container w + for_ maybeContainer $ \container -> do + children <- Gtk.containerGetChildren container + for_ children $ \child -> do + go (" " <> indent) child diff --git a/src/Termonad/Lenses.hs b/src/Termonad/Lenses.hs index 1cfcb8c..99b30c7 100644 --- a/src/Termonad/Lenses.hs +++ b/src/Termonad/Lenses.hs @@ -2,11 +2,18 @@ module Termonad.Lenses where -import Control.Lens (makeLensesFor, makePrisms) +import Termonad.Prelude + +import Control.Lens (Lens', Traversal', makeLensesFor, makePrisms) +import Data.FocusList (FocusList) import Termonad.Types +import qualified Data.FocusList as FocusList +import qualified Data.Maybe as Unsafe (fromJust) +import qualified Data.Sequence as Seq $(makeLensesFor - [ ("term", "lensTerm") + [ ("tmTermScrolledWindow", "lensTMTermScrolledWindow") + , ("term", "lensTerm") , ("pid", "lensPid") , ("unique", "lensUnique") ] @@ -14,13 +21,36 @@ $(makeLensesFor ) $(makeLensesFor - [ ("tmNotebookTabTermContainer", "lensTMNotebookTabTermContainer") - , ("tmNotebookTabTerm", "lensTMNotebookTabTerm") + [ ("tmNotebookTabPaned", "lensTMNotebookTabPaned") + , ("tmNotebookTabLeftTerm", "lensTMNotebookTabLeftTerm") + , ("tmNotebookTabRightTerm", "lensTMNotebookTabRightTerm") + , ("tmNotebookTabFocusIsOnLeft", "lensTMNotebookTabFocusIsOnLeft") , ("tmNotebookTabLabel", "lensTMNotebookTabLabel") ] ''TMNotebookTab ) +lensTMNotebookTabFocusedTerm :: Lens' TMNotebookTab TMTerm +lensTMNotebookTabFocusedTerm f notebookTab + = if tmNotebookTabFocusIsOnLeft notebookTab + then lensTMNotebookTabLeftTerm f notebookTab + else lensTMNotebookTabRightTerm f notebookTab + +lensTMNotebookTabNonFocusedTerm :: Lens' TMNotebookTab TMTerm +lensTMNotebookTabNonFocusedTerm f notebookTab + = if tmNotebookTabFocusIsOnLeft notebookTab + then lensTMNotebookTabRightTerm f notebookTab + else lensTMNotebookTabLeftTerm f notebookTab + +traversalTMNotebookTabTerms :: Traversal' TMNotebookTab TMTerm +traversalTMNotebookTabTerms f notebookTab + = (\termL termR -> notebookTab + { tmNotebookTabLeftTerm = termL + , tmNotebookTabRightTerm = termR + }) + <$> f (tmNotebookTabLeftTerm notebookTab) + <*> f (tmNotebookTabRightTerm notebookTab) + $(makeLensesFor [ ("tmNotebook", "lensTMNotebook") , ("tmNotebookTabs", "lensTMNotebookTabs") @@ -28,6 +58,29 @@ $(makeLensesFor ''TMNotebook ) +-- TODO: This should be available in focuslist-0.1.1.0 as traversalFocusItem. +-- focuslist-0.1.1.0 should likely be available in LTS-19. +-- We should delete this function and use traversalFocusItem when Termonad moves to using LTS-19. +traversalFLItem :: forall a. Traversal' (FocusList a) a +traversalFLItem f flA + = let seqA = FocusList.toSeqFL flA + maybeFocus = FocusList.getFocus (FocusList.getFocusFL flA) + maybeFocusItem = FocusList.getFocusItemFL flA + in case (maybeFocus, maybeFocusItem) of + (Just i, Just a) + -> let makeUpdatedFL :: a -> FocusList a + makeUpdatedFL a' + = Unsafe.fromJust -- safe because i and the length are unchanged + $ FocusList.fromFoldableFL + (FocusList.Focus i) + (Seq.update i a' seqA) + in makeUpdatedFL <$> f a + _ + -> pure flA + +traversalTMNotebookFocusedTab :: Traversal' TMNotebook TMNotebookTab +traversalTMNotebookFocusedTab = lensTMNotebookTabs . traversalFLItem + $(makeLensesFor [ ("tmStateApp", "lensTMStateApp") , ("tmStateAppWin", "lensTMStateAppWin") diff --git a/src/Termonad/Term.hs b/src/Termonad/Term.hs index 8176247..bfa815d 100644 --- a/src/Termonad/Term.hs +++ b/src/Termonad/Term.hs @@ -36,6 +36,7 @@ import GI.Gtk , Label , Notebook , Orientation(OrientationHorizontal) + , Paned , PolicyType(PolicyTypeAlways, PolicyTypeAutomatic, PolicyTypeNever) , ReliefStyle(ReliefStyleNone) , ResponseType(ResponseTypeNo, ResponseTypeYes) @@ -67,6 +68,7 @@ import GI.Gtk , notebookSetTabReorderable , onButtonClicked , onWidgetButtonPressEvent + , onWidgetFocusInEvent , onWidgetKeyPressEvent , scrolledWindowNew , scrolledWindowSetPolicy @@ -80,6 +82,7 @@ import GI.Gtk , windowSetFocus , windowSetTransientFor ) +import qualified GI.Gtk as Gtk import GI.Pango (EllipsizeMode(EllipsizeModeMiddle), FontDescription) import GI.Vte ( PtyFlags(PtyFlagsDefault) @@ -103,14 +106,17 @@ import Termonad.Lenses , lensOptions , lensShowScrollbar , lensShowTabBar + , lensTMNotebookTabFocusedTerm + , lensTMNotebookTabFocusIsOnLeft , lensTMNotebookTabLabel - , lensTMNotebookTabTerm - , lensTMNotebookTabTermContainer + , lensTMNotebookTabNonFocusedTerm + , lensTMNotebookTabPaned , lensTMNotebookTabs , lensTMStateApp , lensTMStateConfig , lensTMStateNotebook , lensTerm + , traversalTMNotebookFocusedTab ) import Termonad.Types ( ConfigHooks(createTermHook) @@ -128,8 +134,7 @@ import Termonad.Types , newTMTerm , pid , tmNotebook - , tmNotebookTabTerm - , tmNotebookTabTermContainer + , tmNotebookTabPaned , tmNotebookTabs ) @@ -141,6 +146,14 @@ focusTerm i mvarTMState = do altNumSwitchTerm :: Int -> TMState -> IO () altNumSwitchTerm = focusTerm +termTogglePane :: TMState -> IO () +termTogglePane mvarTMState = do + tabs <- tmNotebookTabs . tmStateNotebook <$> readMVar mvarTMState + let maybeFocusedTab = getFocusItemFL tabs + for_ maybeFocusedTab $ \focusedTab -> do + let newFocus = focusedTab ^. lensTMNotebookTabNonFocusedTerm . lensTerm + widgetGrabFocus newFocus + termNextPage :: TMState -> IO () termNextPage mvarTMState = do note <- tmNotebook . tmStateNotebook <$> readMVar mvarTMState @@ -203,7 +216,7 @@ termExit tab mvarTMState = do detachTabAction = notebookDetachTab (tmNotebook notebook) - (tmNotebookTabTermContainer tab) + (tmNotebookTabPaned tab) let newTabs = deleteFL tab (tmNotebookTabs notebook) let newTMState = set (lensTMStateNotebook . lensTMNotebookTabs) newTabs tmState @@ -221,9 +234,9 @@ relabelTabs mvarTMState = do go :: Notebook -> TMNotebookTab -> IO () go notebook tmNotebookTab = do let label = tmNotebookTab ^. lensTMNotebookTabLabel - scrolledWin = tmNotebookTab ^. lensTMNotebookTabTermContainer - term' = tmNotebookTab ^. lensTMNotebookTabTerm . lensTerm - relabelTab notebook label scrolledWin term' + paned = tmNotebookTab ^. lensTMNotebookTabPaned + term' = tmNotebookTab ^. lensTMNotebookTabFocusedTerm . lensTerm + relabelTab notebook label paned term' -- | Compute the text for a 'Label' for a GTK Notebook tab. -- @@ -249,9 +262,9 @@ computeTabLabel pageNum maybeTitle = -- | Update the given 'Label' for a GTK Notebook tab. -- -- The new text for the label is determined by the 'computeTabLabel' function. -relabelTab :: Notebook -> Label -> ScrolledWindow -> Terminal -> IO () -relabelTab notebook label scrolledWin term' = do - tabNum <- notebookPageNum notebook scrolledWin +relabelTab :: Notebook -> Label -> Paned -> Terminal -> IO () +relabelTab notebook label paned term' = do + tabNum <- notebookPageNum notebook paned maybeTitle <- terminalGetWindowTitle term' let labelText = computeTabLabel (fromIntegral tabNum) maybeTitle labelSetLabel label labelText @@ -348,7 +361,7 @@ getCWDFromFocusedTab currNote = do case maybeFocusedTab of Nothing -> pure Nothing Just focusedNotebookTab -> do - let shellPid = pid (tmNotebookTabTerm focusedNotebookTab) + let shellPid = pid (focusedNotebookTab ^. lensTMNotebookTabFocusedTerm) cwdOfPid shellPid -- | Create the VTE 'Terminal', set the fonts and options @@ -410,9 +423,10 @@ addPage mvarTMState notebookTab tabLabelBox = do let notebook = tmStateNotebook tmState note = tmNotebook notebook tabs = tmNotebookTabs notebook - scrolledWin = tmNotebookTabTermContainer notebookTab - pageIndex <- notebookAppendPage note scrolledWin (Just tabLabelBox) - notebookSetTabReorderable note scrolledWin True + paned = tmNotebookTabPaned notebookTab + + pageIndex <- notebookAppendPage note paned (Just tabLabelBox) + notebookSetTabReorderable note paned True setShowTabs (tmState ^. lensTMStateConfig) note let newTabs = appendFL tabs notebookTab newTMState = @@ -425,13 +439,14 @@ setFocusOn tmStateAppWin vteTerm = do widgetGrabFocus vteTerm windowSetFocus tmStateAppWin (Just vteTerm) --- | Create a new 'TMTerm', setting it up and adding it to the GTKNotebook. -createTerm +-- | Create two new 'TMTerm's, setting them up and adding them to the +-- GTKNotebook. +createTerms :: (TMState -> EventKey -> IO Bool) -- ^ Funtion for handling key presses on the terminal. -> TMState - -> IO TMTerm -createTerm handleKeyPress mvarTMState = do + -> IO (TMTerm, TMTerm) +createTerms handleKeyPress mvarTMState = do -- Check preconditions assertInvariantTMState mvarTMState @@ -439,50 +454,81 @@ createTerm handleKeyPress mvarTMState = do TMState{tmStateAppWin, tmStateFontDesc, tmStateConfig, tmStateNotebook=currNote} <- readMVar mvarTMState - -- Create a new terminal and launch a shell in it - vteTerm <- createAndInitVteTerm tmStateFontDesc (options tmStateConfig) - maybeCurrDir <- getCWDFromFocusedTab currNote - termShellPid <- launchShell vteTerm maybeCurrDir - tmTerm <- newTMTerm vteTerm termShellPid - - -- Create the container add the VTE term in it - scrolledWin <- createScrolledWin mvarTMState - containerAdd scrolledWin vteTerm + -- Launch a shell in a Terminal in a ScrolledWindow + let createTerm :: IO (ScrolledWindow, Terminal, TMTerm) + createTerm = do + scrolledWin <- createScrolledWin mvarTMState + vteTerm <- createAndInitVteTerm tmStateFontDesc (options tmStateConfig) + maybeCurrDir <- getCWDFromFocusedTab currNote + termShellPid <- launchShell vteTerm maybeCurrDir + tmTerm <- newTMTerm scrolledWin vteTerm termShellPid + containerAdd scrolledWin vteTerm + pure (scrolledWin, vteTerm, tmTerm) + + -- Create the left and right terminals + (scrolledWinR, vteTermR, tmTermR) <- createTerm + (scrolledWinL, vteTermL, tmTermL) <- createTerm + + -- Create the paned window container add the two terminals to it + paned <- Gtk.panedNew OrientationHorizontal + Gtk.panedSetWideHandle paned True + Gtk.panedPack1 paned scrolledWinL True True + Gtk.panedPack2 paned scrolledWinR True True + Gtk.widgetShowAll paned -- Create the GTK widget for the Notebook tab (tabLabelBox, tabLabel, tabCloseButton) <- createNotebookTabLabel -- Create notebook state - let notebookTab = createTMNotebookTab tabLabel scrolledWin tmTerm + let notebookTab = createTMNotebookTab tabLabel paned tmTermL tmTermR -- Add the new notebooktab to the notebook. addPage mvarTMState notebookTab tabLabelBox -- Setup the initial label for the notebook tab. This needs to happen -- after we add the new page to the notebook, so that the page can get labelled - -- appropriately. - relabelTab (tmNotebook currNote) tabLabel scrolledWin vteTerm + -- appropriately. We use the left terminal's title because it is the left + -- terminal which initially has the focus. + relabelTab (tmNotebook currNote) tabLabel paned vteTermL -- Connect callbacks void $ onButtonClicked tabCloseButton $ termClose notebookTab mvarTMState - void $ onTerminalWindowTitleChanged vteTerm $ do + void $ onTerminalWindowTitleChanged vteTermL $ do + -- TODO: use the title of the focused pane TMState{tmStateNotebook} <- readMVar mvarTMState let notebook = tmNotebook tmStateNotebook - relabelTab notebook tabLabel scrolledWin vteTerm - void $ onWidgetKeyPressEvent vteTerm $ handleKeyPress mvarTMState - void $ onWidgetKeyPressEvent scrolledWin $ handleKeyPress mvarTMState - void $ onWidgetButtonPressEvent vteTerm $ handleMousePress vteTerm - void $ onTerminalChildExited vteTerm $ \_ -> termExit notebookTab mvarTMState - - -- Put the keyboard focus on the term - setFocusOn tmStateAppWin vteTerm + relabelTab notebook tabLabel paned vteTermL + for_ @[Terminal] [vteTermL, vteTermR] $ \vteTerm -> do + void $ onWidgetKeyPressEvent vteTerm $ handleKeyPress mvarTMState + void $ onWidgetButtonPressEvent vteTerm $ handleMousePress vteTerm + void $ onTerminalChildExited vteTerm $ \_ -> termExit notebookTab mvarTMState + for_ @[ScrolledWindow] [scrolledWinL, scrolledWinR] $ \scrolledWin -> do + void $ onWidgetKeyPressEvent scrolledWin $ handleKeyPress mvarTMState + + void $ onWidgetFocusInEvent vteTermL $ \_ -> do + modifyMVar_ mvarTMState $ \tmState -> do + pure $ tmState & lensTMStateNotebook + . traversalTMNotebookFocusedTab + . lensTMNotebookTabFocusIsOnLeft .~ True + pure False + void $ onWidgetFocusInEvent vteTermR $ \_ -> do + modifyMVar_ mvarTMState $ \tmState -> do + pure $ tmState & lensTMStateNotebook + . traversalTMNotebookFocusedTab + . lensTMNotebookTabFocusIsOnLeft .~ False + pure False + + -- Put the keyboard focus on the left term + setFocusOn tmStateAppWin vteTermL -- Make sure the state is still right assertInvariantTMState mvarTMState - -- Run user-defined hooks for modifying the newly-created VTE Terminal. - createTermHook (hooks tmStateConfig) mvarTMState vteTerm - pure tmTerm + -- Run user-defined hooks for modifying the newly-created VTE Terminals. + for_ @[Terminal] [vteTermL, vteTermR] $ \vteTerm -> do + createTermHook (hooks tmStateConfig) mvarTMState vteTerm + + pure (tmTermL, tmTermR) -- | Popup the context menu on right click handleMousePress :: Terminal -> EventButton -> IO Bool diff --git a/src/Termonad/Types.hs b/src/Termonad/Types.hs index 999ee95..905c7b4 100644 --- a/src/Termonad/Types.hs +++ b/src/Termonad/Types.hs @@ -4,6 +4,7 @@ module Termonad.Types where import Termonad.Prelude +import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE, withExceptT) import Control.Monad.Fail (fail) import Data.FocusList (FocusList, emptyFL, singletonFL, getFocusItemFL, lengthFL) import Data.Unique (Unique, hashUnique, newUnique) @@ -19,6 +20,7 @@ import GI.Gtk , IsWidget , Label , Notebook + , Paned , ScrolledWindow , Widget , notebookGetCurrentPage @@ -33,10 +35,13 @@ import Text.Show (ShowS, showParen, showString) import Termonad.Gtk (widgetEq) -- | A wrapper around a VTE 'Terminal'. This also stores the process ID of the --- process running on this terminal, as well as a 'Unique' that can be used for --- comparing terminals. +-- process running on this terminal, the 'Unique' that can be used for +-- comparing terminals, and the 'ScrolledWindow' which surrounds the +-- 'Terminal', allowing the user to scroll up to see the history. data TMTerm = TMTerm - { term :: !Terminal + { tmTermScrolledWindow :: !ScrolledWindow + -- ^ The 'ScrolledWindow' holding the VTE 'Terminal'. + , term :: !Terminal -- ^ The actual 'Terminal'. , pid :: !Int -- ^ The process ID of the process running in 'term'. @@ -49,6 +54,9 @@ instance Show TMTerm where showsPrec d TMTerm{..} = showParen (d > 10) $ showString "TMTerm {" . + showString "tmTermScrolledWindow = " . + showString "(GI.GTK.ScrolledWindow)" . + showString ", " . showString "term = " . showString "(GI.GTK.Terminal)" . showString ", " . @@ -59,16 +67,21 @@ instance Show TMTerm where showsPrec (d + 1) (hashUnique unique) . showString "}" --- | A container that holds everything in a given terminal window. The 'term' --- in the 'TMTerm' is inside the 'tmNotebookTabTermContainer' 'ScrolledWindow'. --- The notebook tab 'Label' is also available. +-- | A container that holds everything in a given notebook tab. Each tab is +-- split in two terminals, one on the left and one on the right. The notebook +-- tab 'Label' is also available. data TMNotebookTab = TMNotebookTab - { tmNotebookTabTermContainer :: !ScrolledWindow - -- ^ The 'ScrolledWindow' holding the VTE 'Terminal'. - , tmNotebookTabTerm :: !TMTerm - -- ^ The 'Terminal' insidie the 'ScrolledWindow'. + { tmNotebookTabPaned :: !Paned + -- ^ The 'Paned' holding the two 'TMTerm's. + , tmNotebookTabLeftTerm :: !TMTerm + -- ^ The left 'TMTerm'. + , tmNotebookTabRightTerm :: !TMTerm + -- ^ The right 'TMTerm'. + , tmNotebookTabFocusIsOnLeft :: !Bool + -- ^ Whether it is the left 'TMTerm' which has the focus (if 'True') or the + -- right 'TMTerm' (if 'False'). , tmNotebookTabLabel :: !Label - -- ^ The 'Label' holding the title of the 'Terminal' in the 'Notebook' tab. + -- ^ The 'Label' holding the title of the left 'Terminal' in the 'Notebook' tab. } instance Show TMNotebookTab where @@ -76,11 +89,14 @@ instance Show TMNotebookTab where showsPrec d TMNotebookTab{..} = showParen (d > 10) $ showString "TMNotebookTab {" . - showString "tmNotebookTabTermContainer = " . - showString "(GI.GTK.ScrolledWindow)" . + showString "tmNotebookTabPaned = " . + showString "(GI.GTK.Paned)" . + showString ", " . + showString "tmNotebookTabLeftTerm = " . + showsPrec (d + 1) tmNotebookTabLeftTerm . showString ", " . - showString "tmNotebookTabTerm = " . - showsPrec (d + 1) tmNotebookTabTerm . + showString "tmNotebookTabRightTerm = " . + showsPrec (d + 1) tmNotebookTabRightTerm . showString ", " . showString "tmNotebookTabLabel = " . showString "(GI.GTK.Label)" . @@ -144,34 +160,41 @@ instance Eq TMTerm where instance Eq TMNotebookTab where (==) :: TMNotebookTab -> TMNotebookTab -> Bool - (==) = (==) `on` tmNotebookTabTerm + l == r = ((==) `on` tmNotebookTabLeftTerm) l r + && ((==) `on` tmNotebookTabRightTerm) l r -createTMTerm :: Terminal -> Int -> Unique -> TMTerm -createTMTerm trm pd unq = +createTMTerm :: ScrolledWindow -> Terminal -> Int -> Unique -> TMTerm +createTMTerm scrollWin trm pd unq = TMTerm - { term = trm + { tmTermScrolledWindow = scrollWin + , term = trm , pid = pd , unique = unq } -newTMTerm :: Terminal -> Int -> IO TMTerm -newTMTerm trm pd = createTMTerm trm pd <$> newUnique +newTMTerm :: ScrolledWindow -> Terminal -> Int -> IO TMTerm +newTMTerm scrollWin trm pd = createTMTerm scrollWin trm pd <$> newUnique getFocusedTermFromState :: TMState -> IO (Maybe Terminal) getFocusedTermFromState mvarTMState = - withMVar mvarTMState go + withMVar mvarTMState (pure . go) where - go :: TMState' -> IO (Maybe Terminal) + go :: TMState' -> Maybe Terminal go tmState = do - let maybeNotebookTab = - getFocusItemFL $ tmNotebookTabs $ tmStateNotebook tmState - pure $ fmap (term . tmNotebookTabTerm) maybeNotebookTab - -createTMNotebookTab :: Label -> ScrolledWindow -> TMTerm -> TMNotebookTab -createTMNotebookTab tabLabel scrollWin trm = + notebookTab <- getFocusItemFL $ tmNotebookTabs $ tmStateNotebook tmState + let focusedTMTerm + = if tmNotebookTabFocusIsOnLeft notebookTab + then tmNotebookTabLeftTerm notebookTab + else tmNotebookTabRightTerm notebookTab + pure $ term focusedTMTerm + +createTMNotebookTab :: Label -> Paned -> TMTerm -> TMTerm -> TMNotebookTab +createTMNotebookTab tabLabel paned trmL trmR = TMNotebookTab - { tmNotebookTabTermContainer = scrollWin - , tmNotebookTabTerm = trm + { tmNotebookTabPaned = paned + , tmNotebookTabLeftTerm = trmL + , tmNotebookTabRightTerm = trmR + , tmNotebookTabFocusIsOnLeft = True , tmNotebookTabLabel = tabLabel } @@ -217,20 +240,25 @@ newEmptyTMState tmConfig app appWin note fontDesc = , tmStateConfig = tmConfig } -newTMStateSingleTerm :: +newTMStateSingleTab :: TMConfig -> Application -> ApplicationWindow -> Notebook -> Label + -> Paned + -> ScrolledWindow + -> Terminal + -> Int -> ScrolledWindow -> Terminal -> Int -> FontDescription -> IO TMState -newTMStateSingleTerm tmConfig app appWin note label scrollWin trm pd fontDesc = do - tmTerm <- newTMTerm trm pd - let tmNoteTab = createTMNotebookTab label scrollWin tmTerm +newTMStateSingleTab tmConfig app appWin note label paned scrollWinL trmL pdL scrollWinR trmR pdR fontDesc = do + tmTermL <- newTMTerm scrollWinL trmL pdL + tmTermR <- newTMTerm scrollWinR trmR pdR + let tmNoteTab = createTMNotebookTab label paned tmTermL tmTermR tabs = singletonFL tmNoteTab tmNote = createTMNotebook note tabs newTMState tmConfig app appWin tmNote fontDesc @@ -546,70 +574,63 @@ invariantTMState' tmState = runInvariants = fmap catMaybes . sequence invariantFocusSame :: IO (Maybe TMStateInvariantErr) - invariantFocusSame = do + invariantFocusSame = execExceptT $ do let tmNote = tmNotebook $ tmStateNotebook tmState index32 <- notebookGetCurrentPage tmNote maybeWidgetFromNote <- notebookGetNthPage tmNote index32 let focusList = tmNotebookTabs $ tmStateNotebook tmState - maybeScrollWinFromFL = - tmNotebookTabTermContainer <$> getFocusItemFL focusList + maybePanedFromFL = + tmNotebookTabPaned <$> getFocusItemFL focusList idx = fromIntegral index32 - case (maybeWidgetFromNote, maybeScrollWinFromFL) of - (Nothing, Nothing) -> pure Nothing + case (maybeWidgetFromNote, maybePanedFromFL) of + (Nothing, Nothing) -> pure () (Just _, Nothing) -> - pure $ - Just $ - FocusNotSame NotebookTabWidgetExistsButNoFocusListFocus idx + throwE $ FocusNotSame NotebookTabWidgetExistsButNoFocusListFocus idx (Nothing, Just _) -> - pure $ - Just $ - FocusNotSame FocusListFocusExistsButNoNotebookTabWidget idx - (Just widgetFromNote, Just scrollWinFromFL) -> do - isEq <- widgetEq widgetFromNote scrollWinFromFL - if isEq - then pure Nothing - else - pure $ - Just $ - FocusNotSame NotebookTabWidgetDiffersFromFocusListFocus idx + throwE $ FocusNotSame FocusListFocusExistsButNoNotebookTabWidget idx + (Just widgetFromNote, Just panedFromFL) -> do + withExceptT (\() -> FocusNotSame NotebookTabWidgetDiffersFromFocusListFocus idx) $ do + expectSameWidgets widgetFromNote panedFromFL invariantTMTabLength :: IO (Maybe TMStateInvariantErr) - invariantTMTabLength = do + invariantTMTabLength = execExceptT $ do let tmNote = tmNotebook $ tmStateNotebook tmState noteLength32 <- notebookGetNPages tmNote let noteLength = fromIntegral noteLength32 focusListLength = lengthFL $ tmNotebookTabs $ tmStateNotebook tmState lengthEqual = focusListLength == noteLength - if lengthEqual - then pure Nothing - else pure $ - Just $ - TabsDoNotMatch $ - TabLengthsDifferent noteLength focusListLength + when (not lengthEqual) $ do + throwE $ TabsDoNotMatch $ TabLengthsDifferent noteLength focusListLength -- Turns a FocusList and Notebook into two lists of widgets and compares each widget for equality invariantTabsAllMatch :: IO (Maybe TMStateInvariantErr) - invariantTabsAllMatch = do - let tmNote = tmNotebook $ tmStateNotebook tmState - focusList = tmNotebookTabs $ tmStateNotebook tmState - flList = tmNotebookTabTermContainer <$> toList focusList - noteList <- notebookToList tmNote - tabsMatch noteList flList - where - tabsMatch - :: forall a b - . (IsWidget a, IsWidget b) - => [a] - -> [b] - -> IO (Maybe TMStateInvariantErr) - tabsMatch xs ys = foldr go (pure Nothing) (zip3 xs ys [0..]) - where - go :: (a, b, Int) -> IO (Maybe TMStateInvariantErr) -> IO (Maybe TMStateInvariantErr) - go (x, y, i) acc = do - isEq <- widgetEq x y - if isEq - then acc - else pure . Just $ TabsDoNotMatch (TabAtIndexDifferent i) + invariantTabsAllMatch = execExceptT $ do + withExceptT (\i -> TabsDoNotMatch (TabAtIndexDifferent i)) $ do + let tmNote = tmNotebook $ tmStateNotebook tmState + focusList = tmNotebookTabs $ tmStateNotebook tmState + flList = tmNotebookTabPaned <$> toList focusList + widgetsFromNote <- liftIO $ notebookToList tmNote + for_ (zip3 widgetsFromNote flList [0..]) $ \(scrollWinFromNote, panedFromFL, i) -> do + withExceptT (\() -> i) $ do + expectSameWidgets scrollWinFromNote panedFromFL + + expectSameWidgets + :: forall a b + . (IsWidget a, IsWidget b) + => a -> b -> ExceptT () IO () + expectSameWidgets x y = do + isEq <- widgetEq x y + when (not isEq) $ do + throwE () + + execExceptT :: forall e m. Monad m => ExceptT e m () -> m (Maybe e) + execExceptT body = do + eOrUnit <- runExceptT body + case eOrUnit of + Left e -> do + pure (Just e) + Right () -> do + pure Nothing -- | Check the invariants for 'TMState', and call 'fail' if we find that they -- have been violated.