{-# LANGUAGE CPP #-} module Termonad.Term where import Termonad.Prelude import Control.Lens ((^.), (.~), set, to) import Data.Colour.SRGB (Colour, RGB(RGB), toSRGB) import Data.FocusList (appendFL, deleteFL, getFocusItemFL) import GI.Gdk ( EventButton , EventKey , RGBA , getEventButtonButton , newZeroRGBA , setRGBABlue , setRGBAGreen , setRGBARed ) import GI.Gdk.Constants (pattern BUTTON_SECONDARY) import GI.Gio ( menuAppend , menuNew , noCancellable ) import GI.GLib ( SpawnFlags(SpawnFlagsDefault) ) import GI.Gtk ( Align(AlignFill) , ApplicationWindow , Box , Button , IconSize(IconSizeMenu) , Label , Notebook , Orientation(OrientationHorizontal) , PolicyType(PolicyTypeAlways, PolicyTypeAutomatic, PolicyTypeNever) , ReliefStyle(ReliefStyleNone) , ResponseType(ResponseTypeNo, ResponseTypeYes) , ScrolledWindow , applicationGetActiveWindow , boxNew , buttonNewFromIconName , buttonSetRelief , containerAdd , dialogAddButton , dialogGetContentArea , dialogNew , dialogRun , labelNew , labelSetEllipsize , labelSetLabel , labelSetMaxWidthChars , menuAttachToWidget , menuNewFromModel , menuPopupAtPointer , noAdjustment , notebookAppendPage , notebookDetachTab , notebookGetNPages , notebookPageNum , notebookSetCurrentPage , notebookSetShowTabs , notebookSetTabReorderable , onButtonClicked , onWidgetButtonPressEvent , onWidgetKeyPressEvent , scrolledWindowNew , scrolledWindowSetPolicy , setWidgetMargin , widgetDestroy , widgetGrabFocus , widgetSetCanFocus , widgetSetHalign , widgetSetHexpand , widgetShow , windowSetFocus , windowSetTransientFor ) import GI.Pango (EllipsizeMode(EllipsizeModeMiddle), FontDescription) import GI.Vte ( PtyFlags(PtyFlagsDefault) , Terminal , onTerminalChildExited , onTerminalWindowTitleChanged , terminalGetWindowTitle , terminalNew , terminalSetCursorBlinkMode , terminalSetFont , terminalSetScrollbackLines , terminalSpawnSync , terminalSetWordCharExceptions ) import System.Directory (getSymbolicLinkTarget) import System.Environment (lookupEnv) import Termonad.Lenses ( lensConfirmExit , lensOptions , lensShowScrollbar , lensShowTabBar , lensTMNotebookTabLabel , lensTMNotebookTabTerm , lensTMNotebookTabTermContainer , lensTMNotebookTabs , lensTMStateApp , lensTMStateConfig , lensTMStateNotebook , lensTerm ) import Termonad.Types ( ConfigHooks(createTermHook) , ConfigOptions(scrollbackLen, wordCharExceptions, cursorBlinkMode) , ShowScrollbar(..) , ShowTabBar(..) , TMConfig(hooks, options) , TMNotebook , TMNotebookTab , TMState , TMState'(TMState, tmStateAppWin, tmStateConfig, tmStateFontDesc, tmStateNotebook) , TMTerm , assertInvariantTMState , createTMNotebookTab , newTMTerm , pid , tmNotebook , tmNotebookTabTerm , tmNotebookTabTermContainer , tmNotebookTabs ) focusTerm :: Int -> TMState -> IO () focusTerm i mvarTMState = do note <- tmNotebook . tmStateNotebook <$> readMVar mvarTMState notebookSetCurrentPage note (fromIntegral i) altNumSwitchTerm :: Int -> TMState -> IO () altNumSwitchTerm = focusTerm termExitFocused :: TMState -> IO () termExitFocused mvarTMState = do tmState <- readMVar mvarTMState let maybeTab = tmState ^. lensTMStateNotebook . lensTMNotebookTabs . to getFocusItemFL case maybeTab of Nothing -> pure () Just tab -> termClose tab mvarTMState termClose :: TMNotebookTab -> TMState -> IO () termClose tab mvarTMState = do tmState <- readMVar mvarTMState let confirm = tmState ^. lensTMStateConfig . lensOptions . lensConfirmExit close = if confirm then termExitWithConfirmation else termExit close tab mvarTMState termExitWithConfirmation :: TMNotebookTab -> TMState -> IO () termExitWithConfirmation tab mvarTMState = do tmState <- readMVar mvarTMState let app = tmState ^. lensTMStateApp win <- applicationGetActiveWindow app dialog <- dialogNew box <- dialogGetContentArea dialog label <- labelNew (Just "Close tab?") containerAdd box label widgetShow label setWidgetMargin label 10 void $ dialogAddButton dialog "No, do NOT close tab" (fromIntegral (fromEnum ResponseTypeNo)) void $ dialogAddButton dialog "Yes, close tab" (fromIntegral (fromEnum ResponseTypeYes)) windowSetTransientFor dialog win res <- dialogRun dialog widgetDestroy dialog case toEnum (fromIntegral res) of ResponseTypeYes -> termExit tab mvarTMState _ -> pure () termExit :: TMNotebookTab -> TMState -> IO () termExit tab mvarTMState = do detachTabAction <- modifyMVar mvarTMState $ \tmState -> do let notebook = tmStateNotebook tmState detachTabAction = notebookDetachTab (tmNotebook notebook) (tmNotebookTabTermContainer tab) let newTabs = deleteFL tab (tmNotebookTabs notebook) let newTMState = set (lensTMStateNotebook . lensTMNotebookTabs) newTabs tmState pure (newTMState, detachTabAction) detachTabAction relabelTabs mvarTMState relabelTabs :: TMState -> IO () relabelTabs mvarTMState = do TMState{tmStateNotebook} <- readMVar mvarTMState let notebook = tmNotebook tmStateNotebook tabFocusList = tmNotebookTabs tmStateNotebook foldMap (go notebook) tabFocusList where go :: Notebook -> TMNotebookTab -> IO () go notebook tmNotebookTab = do let label = tmNotebookTab ^. lensTMNotebookTabLabel scrolledWin = tmNotebookTab ^. lensTMNotebookTabTermContainer term' = tmNotebookTab ^. lensTMNotebookTabTerm . lensTerm relabelTab notebook label scrolledWin term' -- | Compute the text for a 'Label' for a GTK Notebook tab. -- -- >>> computeTabLabel 0 (Just "me@machine:~") -- "1. me@machine:~" -- -- >>> computeTabLabel 5 (Just "bash process") -- "6. bash process" -- -- >>> computeTabLabel 2 Nothing -- "3. shell" computeTabLabel :: Int -- ^ Tab number. 0 is used for the first tab, 1 for the second, etc. -> Maybe Text -- ^ A possible title for a tab. If this is 'Nothing', then the string -- @shell@ will be used. -> Text computeTabLabel pageNum maybeTitle = let title = fromMaybe "shell" maybeTitle in tshow (pageNum + 1) <> ". " <> title -- | 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 maybeTitle <- terminalGetWindowTitle term' let labelText = computeTabLabel (fromIntegral tabNum) maybeTitle labelSetLabel label labelText showScrollbarToPolicy :: ShowScrollbar -> PolicyType showScrollbarToPolicy ShowScrollbarNever = PolicyTypeNever showScrollbarToPolicy ShowScrollbarIfNeeded = PolicyTypeAutomatic showScrollbarToPolicy ShowScrollbarAlways = PolicyTypeAlways createScrolledWin :: TMState -> IO ScrolledWindow createScrolledWin mvarTMState = do tmState <- readMVar mvarTMState let showScrollbarVal = tmState ^. lensTMStateConfig . lensOptions . lensShowScrollbar vScrollbarPolicy = showScrollbarToPolicy showScrollbarVal scrolledWin <- scrolledWindowNew noAdjustment noAdjustment widgetShow scrolledWin scrolledWindowSetPolicy scrolledWin PolicyTypeAutomatic vScrollbarPolicy pure scrolledWin createNotebookTabLabel :: IO (Box, Label, Button) createNotebookTabLabel = do box <- boxNew OrientationHorizontal 5 label <- labelNew (Just "") labelSetEllipsize label EllipsizeModeMiddle labelSetMaxWidthChars label 10 widgetSetHexpand label True widgetSetHalign label AlignFill button <- buttonNewFromIconName (Just "window-close") (fromIntegral (fromEnum IconSizeMenu)) buttonSetRelief button ReliefStyleNone containerAdd box label containerAdd box button widgetSetCanFocus button False widgetSetCanFocus label False widgetSetCanFocus box False widgetShow box widgetShow label widgetShow button pure (box, label, button) setShowTabs :: TMConfig -> Notebook -> IO () setShowTabs tmConfig note = do npages <- notebookGetNPages note let shouldShowTabs = case tmConfig ^. lensOptions . lensShowTabBar of ShowTabBarIfNeeded -> npages > 1 ShowTabBarAlways -> True ShowTabBarNever -> False notebookSetShowTabs note shouldShowTabs toRGBA :: Colour Double -> IO RGBA toRGBA colour = do let RGB red green blue = toSRGB colour rgba <- newZeroRGBA setRGBARed rgba red setRGBAGreen rgba green setRGBABlue rgba blue pure rgba -- | TODO: This should probably be implemented in an external package, -- since it is a generally useful utility. -- -- It should also be implemented for windows and osx. cwdOfPid :: Int -> IO (Maybe Text) cwdOfPid pd = do #ifdef mingw32_HOST_OS pure Nothing #else #ifdef darwin_HOST_OS pure Nothing #else let pidPath = "/proc" show pd "cwd" eitherLinkTarget <- try $ getSymbolicLinkTarget pidPath case eitherLinkTarget of Left (_ :: IOException) -> pure Nothing Right linkTarget -> pure $ Just $ pack linkTarget #endif #endif -- | Get the current working directory from the shell in the focused tab of a -- notebook. -- -- Returns 'Nothing' if there is no focused tab of the notebook, or the -- current working directory could not be detected for the shell. getCWDFromFocusedTab :: TMNotebook -> IO (Maybe Text) getCWDFromFocusedTab currNote = do let maybeFocusedTab = getFocusItemFL (tmNotebookTabs currNote) case maybeFocusedTab of Nothing -> pure Nothing Just focusedNotebookTab -> do let shellPid = pid (tmNotebookTabTerm focusedNotebookTab) cwdOfPid shellPid -- | Create the VTE 'Terminal', set the fonts and options createAndInitVteTerm :: FontDescription -> ConfigOptions -> IO Terminal createAndInitVteTerm tmStateFontDesc curOpts = do vteTerm <- terminalNew terminalSetFont vteTerm (Just tmStateFontDesc) terminalSetWordCharExceptions vteTerm $ wordCharExceptions curOpts terminalSetScrollbackLines vteTerm (fromIntegral (scrollbackLen curOpts)) terminalSetCursorBlinkMode vteTerm (cursorBlinkMode curOpts) widgetShow vteTerm pure vteTerm -- | Starts a shell in a terminal and return a new TMTerm launchShell :: Terminal -- ^ GTK 'Terminal' to spawn the shell in. -> Maybe Text -- ^ An optional path to the current working directory to start the -- shell in. If 'Nothing', use the current working directory of the -- termonad process. -> IO Int launchShell vteTerm maybeCurrDir = do -- Should probably use GI.Vte.Functions.getUserShell, but contrary to its -- documentation it raises an exception rather wrap in Maybe. mShell <- lookupEnv "SHELL" let argv = fromMaybe ["/usr/bin/env", "bash"] (pure <$> mShell) -- Launch the shell shellPid <- terminalSpawnSync vteTerm [PtyFlagsDefault] maybeCurrDir argv Nothing ([SpawnFlagsDefault] :: [SpawnFlags]) Nothing noCancellable pure (fromIntegral shellPid) -- | Add a page to the notebook and switch to it. addPage :: TMState -> TMNotebookTab -> Box -- ^ The GTK Object holding the label we want to show for the tab of the -- newly created page of the notebook. -> IO () addPage mvarTMState notebookTab tabLabelBox = do -- Append a new notebook page and update the TMState to reflect this. (note, pageIndex) <- modifyMVar mvarTMState appendNotebookPage -- Switch the current Notebook page to the the newly added page. notebookSetCurrentPage note pageIndex where appendNotebookPage :: TMState' -> IO (TMState', (Notebook, Int32)) appendNotebookPage tmState = do let notebook = tmStateNotebook tmState note = tmNotebook notebook tabs = tmNotebookTabs notebook scrolledWin = tmNotebookTabTermContainer notebookTab pageIndex <- notebookAppendPage note scrolledWin (Just tabLabelBox) notebookSetTabReorderable note scrolledWin True setShowTabs (tmState ^. lensTMStateConfig) note let newTabs = appendFL tabs notebookTab newTMState = tmState & lensTMStateNotebook . lensTMNotebookTabs .~ newTabs pure (newTMState, (note, pageIndex)) -- | Set the keyboard focus on a vte terminal setFocusOn :: ApplicationWindow -> Terminal -> IO() setFocusOn tmStateAppWin vteTerm = do widgetGrabFocus vteTerm windowSetFocus tmStateAppWin (Just vteTerm) -- | Create a new 'TMTerm', setting it up and adding it to the GTKNotebook. createTerm :: (TMState -> EventKey -> IO Bool) -- ^ Funtion for handling key presses on the terminal. -> TMState -> IO TMTerm createTerm handleKeyPress mvarTMState = do -- Check preconditions assertInvariantTMState mvarTMState -- Read needed data in TMVar 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 -- Create the GTK widget for the Notebook tab (tabLabelBox, tabLabel, tabCloseButton) <- createNotebookTabLabel -- Create notebook state let notebookTab = createTMNotebookTab tabLabel scrolledWin tmTerm -- 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 -- Connect callbacks void $ onButtonClicked tabCloseButton $ termClose notebookTab mvarTMState void $ onTerminalWindowTitleChanged vteTerm $ do 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 -- 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 -- | Popup the context menu on right click handleMousePress :: Terminal -> EventButton -> IO Bool handleMousePress vteTerm event = do button <- getEventButtonButton event let rightClick = button == fromIntegral BUTTON_SECONDARY when rightClick $ do menuModel <- menuNew menuAppend menuModel (Just "Copy") (Just "app.copy") menuAppend menuModel (Just "Paste") (Just "app.paste") menu <- menuNewFromModel menuModel menuAttachToWidget menu vteTerm Nothing menuPopupAtPointer menu Nothing pure rightClick