{-# 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
  ( Cancellable
  , menuAppend
  , menuNew
  )
import GI.GLib
  ( SpawnFlags(SpawnFlagsDefault)
  )
import GI.Gtk
  ( Adjustment
  , 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
  , 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 :: Int -> TMState -> IO ()
focusTerm i :: Int
i mvarTMState :: TMState
mvarTMState = do
  Notebook
note <- TMNotebook -> Notebook
tmNotebook (TMNotebook -> Notebook)
-> (TMState' -> TMNotebook) -> TMState' -> Notebook
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. TMState' -> TMNotebook
tmStateNotebook (TMState' -> Notebook) -> IO TMState' -> IO Notebook
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMState -> IO TMState'
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar TMState
mvarTMState
  Notebook -> Int32 -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsNotebook a) =>
a -> Int32 -> m ()
notebookSetCurrentPage Notebook
note (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)

altNumSwitchTerm :: Int -> TMState -> IO ()
altNumSwitchTerm :: Int -> TMState -> IO ()
altNumSwitchTerm = Int -> TMState -> IO ()
focusTerm

termExitFocused :: TMState -> IO ()
termExitFocused :: TMState -> IO ()
termExitFocused mvarTMState :: TMState
mvarTMState = do
  TMState'
tmState <- TMState -> IO TMState'
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar TMState
mvarTMState
  let maybeTab :: Maybe TMNotebookTab
maybeTab =
        TMState'
tmState TMState'
-> Getting (Maybe TMNotebookTab) TMState' (Maybe TMNotebookTab)
-> Maybe TMNotebookTab
forall s a. s -> Getting a s a -> a
^. (TMNotebook -> Const (Maybe TMNotebookTab) TMNotebook)
-> TMState' -> Const (Maybe TMNotebookTab) TMState'
Lens' TMState' TMNotebook
lensTMStateNotebook ((TMNotebook -> Const (Maybe TMNotebookTab) TMNotebook)
 -> TMState' -> Const (Maybe TMNotebookTab) TMState')
-> ((Maybe TMNotebookTab
     -> Const (Maybe TMNotebookTab) (Maybe TMNotebookTab))
    -> TMNotebook -> Const (Maybe TMNotebookTab) TMNotebook)
-> Getting (Maybe TMNotebookTab) TMState' (Maybe TMNotebookTab)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (FocusList TMNotebookTab
 -> Const (Maybe TMNotebookTab) (FocusList TMNotebookTab))
-> TMNotebook -> Const (Maybe TMNotebookTab) TMNotebook
Lens' TMNotebook (FocusList TMNotebookTab)
lensTMNotebookTabs ((FocusList TMNotebookTab
  -> Const (Maybe TMNotebookTab) (FocusList TMNotebookTab))
 -> TMNotebook -> Const (Maybe TMNotebookTab) TMNotebook)
-> ((Maybe TMNotebookTab
     -> Const (Maybe TMNotebookTab) (Maybe TMNotebookTab))
    -> FocusList TMNotebookTab
    -> Const (Maybe TMNotebookTab) (FocusList TMNotebookTab))
-> (Maybe TMNotebookTab
    -> Const (Maybe TMNotebookTab) (Maybe TMNotebookTab))
-> TMNotebook
-> Const (Maybe TMNotebookTab) TMNotebook
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (FocusList TMNotebookTab -> Maybe TMNotebookTab)
-> (Maybe TMNotebookTab
    -> Const (Maybe TMNotebookTab) (Maybe TMNotebookTab))
-> FocusList TMNotebookTab
-> Const (Maybe TMNotebookTab) (FocusList TMNotebookTab)
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to FocusList TMNotebookTab -> Maybe TMNotebookTab
forall a. FocusList a -> Maybe a
getFocusItemFL
  case Maybe TMNotebookTab
maybeTab of
    Nothing -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just tab :: TMNotebookTab
tab -> TMNotebookTab -> TMState -> IO ()
termClose TMNotebookTab
tab TMState
mvarTMState

termClose :: TMNotebookTab -> TMState -> IO ()
termClose :: TMNotebookTab -> TMState -> IO ()
termClose tab :: TMNotebookTab
tab mvarTMState :: TMState
mvarTMState = do
  TMState'
tmState <- TMState -> IO TMState'
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar TMState
mvarTMState
  let confirm :: Bool
confirm = TMState'
tmState TMState' -> Getting Bool TMState' Bool -> Bool
forall s a. s -> Getting a s a -> a
^. (TMConfig -> Const Bool TMConfig)
-> TMState' -> Const Bool TMState'
Lens' TMState' TMConfig
lensTMStateConfig ((TMConfig -> Const Bool TMConfig)
 -> TMState' -> Const Bool TMState')
-> ((Bool -> Const Bool Bool) -> TMConfig -> Const Bool TMConfig)
-> Getting Bool TMState' Bool
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (ConfigOptions -> Const Bool ConfigOptions)
-> TMConfig -> Const Bool TMConfig
Lens' TMConfig ConfigOptions
lensOptions ((ConfigOptions -> Const Bool ConfigOptions)
 -> TMConfig -> Const Bool TMConfig)
-> ((Bool -> Const Bool Bool)
    -> ConfigOptions -> Const Bool ConfigOptions)
-> (Bool -> Const Bool Bool)
-> TMConfig
-> Const Bool TMConfig
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Bool -> Const Bool Bool)
-> ConfigOptions -> Const Bool ConfigOptions
Lens' ConfigOptions Bool
lensConfirmExit
      close :: TMNotebookTab -> TMState -> IO ()
close = if Bool
confirm then TMNotebookTab -> TMState -> IO ()
termExitWithConfirmation else TMNotebookTab -> TMState -> IO ()
termExit
  TMNotebookTab -> TMState -> IO ()
close TMNotebookTab
tab TMState
mvarTMState

termExitWithConfirmation :: TMNotebookTab -> TMState -> IO ()
termExitWithConfirmation :: TMNotebookTab -> TMState -> IO ()
termExitWithConfirmation tab :: TMNotebookTab
tab mvarTMState :: TMState
mvarTMState = do
  TMState'
tmState <- TMState -> IO TMState'
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar TMState
mvarTMState
  let app :: Application
app = TMState'
tmState TMState' -> Getting Application TMState' Application -> Application
forall s a. s -> Getting a s a -> a
^. Getting Application TMState' Application
Lens' TMState' Application
lensTMStateApp
  Maybe Window
win <- Application -> IO (Maybe Window)
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsApplication a) =>
a -> m (Maybe Window)
applicationGetActiveWindow Application
app
  Dialog
dialog <- IO Dialog
forall (m :: * -> *). (HasCallStack, MonadIO m) => m Dialog
dialogNew
  Box
box <- Dialog -> IO Box
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsDialog a) =>
a -> m Box
dialogGetContentArea Dialog
dialog
  Label
label <- Maybe Text -> IO Label
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Maybe Text -> m Label
labelNew (Text -> Maybe Text
forall a. a -> Maybe a
Just "Close tab?")
  Box -> Label -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
containerAdd Box
box Label
label
  Label -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
widgetShow Label
label
  Label -> Int32 -> IO ()
forall (m :: * -> *) o.
(MonadIO m, IsWidget o) =>
o -> Int32 -> m ()
setWidgetMargin Label
label 10
  IO Widget -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Widget -> IO ()) -> IO Widget -> IO ()
forall a b. (a -> b) -> a -> b
$
    Dialog -> Text -> Int32 -> IO Widget
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsDialog a) =>
a -> Text -> Int32 -> m Widget
dialogAddButton
      Dialog
dialog
      "No, do NOT close tab"
      (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ResponseType -> Int
forall a. Enum a => a -> Int
fromEnum ResponseType
ResponseTypeNo))
  IO Widget -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Widget -> IO ()) -> IO Widget -> IO ()
forall a b. (a -> b) -> a -> b
$
    Dialog -> Text -> Int32 -> IO Widget
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsDialog a) =>
a -> Text -> Int32 -> m Widget
dialogAddButton
      Dialog
dialog
      "Yes, close tab"
      (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ResponseType -> Int
forall a. Enum a => a -> Int
fromEnum ResponseType
ResponseTypeYes))
  Dialog -> Maybe Window -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsWindow a, IsWindow b) =>
a -> Maybe b -> m ()
windowSetTransientFor Dialog
dialog Maybe Window
win
  Int32
res <- Dialog -> IO Int32
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsDialog a) =>
a -> m Int32
dialogRun Dialog
dialog
  Dialog -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
widgetDestroy Dialog
dialog
  case Int -> ResponseType
forall a. Enum a => Int -> a
toEnum (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
res) of
    ResponseTypeYes -> TMNotebookTab -> TMState -> IO ()
termExit TMNotebookTab
tab TMState
mvarTMState
    _ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

termExit :: TMNotebookTab -> TMState -> IO ()
termExit :: TMNotebookTab -> TMState -> IO ()
termExit tab :: TMNotebookTab
tab mvarTMState :: TMState
mvarTMState = do
  IO ()
detachTabAction <-
    TMState -> (TMState' -> IO (TMState', IO ())) -> IO (IO ())
forall (m :: * -> *) a b.
MonadUnliftIO m =>
MVar a -> (a -> m (a, b)) -> m b
modifyMVar TMState
mvarTMState ((TMState' -> IO (TMState', IO ())) -> IO (IO ()))
-> (TMState' -> IO (TMState', IO ())) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ \tmState :: TMState'
tmState -> do
      let notebook :: TMNotebook
notebook = TMState' -> TMNotebook
tmStateNotebook TMState'
tmState
          detachTabAction :: IO ()
detachTabAction =
            Notebook -> ScrolledWindow -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsNotebook a, IsWidget b) =>
a -> b -> m ()
notebookDetachTab
              (TMNotebook -> Notebook
tmNotebook TMNotebook
notebook)
              (TMNotebookTab -> ScrolledWindow
tmNotebookTabTermContainer TMNotebookTab
tab)
      let newTabs :: FocusList TMNotebookTab
newTabs = TMNotebookTab -> FocusList TMNotebookTab -> FocusList TMNotebookTab
forall a. Eq a => a -> FocusList a -> FocusList a
deleteFL TMNotebookTab
tab (TMNotebook -> FocusList TMNotebookTab
tmNotebookTabs TMNotebook
notebook)
      let newTMState :: TMState'
newTMState =
            ASetter
  TMState'
  TMState'
  (FocusList TMNotebookTab)
  (FocusList TMNotebookTab)
-> FocusList TMNotebookTab -> TMState' -> TMState'
forall s t a b. ASetter s t a b -> b -> s -> t
set ((TMNotebook -> Identity TMNotebook)
-> TMState' -> Identity TMState'
Lens' TMState' TMNotebook
lensTMStateNotebook ((TMNotebook -> Identity TMNotebook)
 -> TMState' -> Identity TMState')
-> ((FocusList TMNotebookTab -> Identity (FocusList TMNotebookTab))
    -> TMNotebook -> Identity TMNotebook)
-> ASetter
     TMState'
     TMState'
     (FocusList TMNotebookTab)
     (FocusList TMNotebookTab)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (FocusList TMNotebookTab -> Identity (FocusList TMNotebookTab))
-> TMNotebook -> Identity TMNotebook
Lens' TMNotebook (FocusList TMNotebookTab)
lensTMNotebookTabs) FocusList TMNotebookTab
newTabs TMState'
tmState
      (TMState', IO ()) -> IO (TMState', IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TMState'
newTMState, IO ()
detachTabAction)
  IO ()
detachTabAction
  TMState -> IO ()
relabelTabs TMState
mvarTMState

relabelTabs :: TMState -> IO ()
relabelTabs :: TMState -> IO ()
relabelTabs mvarTMState :: TMState
mvarTMState = do
  TMState{TMNotebook
tmStateNotebook :: TMNotebook
tmStateNotebook :: TMState' -> TMNotebook
tmStateNotebook} <- TMState -> IO TMState'
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar TMState
mvarTMState
  let notebook :: Notebook
notebook = TMNotebook -> Notebook
tmNotebook TMNotebook
tmStateNotebook
      tabFocusList :: FocusList TMNotebookTab
tabFocusList = TMNotebook -> FocusList TMNotebookTab
tmNotebookTabs TMNotebook
tmStateNotebook
  (Element (FocusList TMNotebookTab) -> IO ())
-> FocusList TMNotebookTab -> IO ()
forall mono m.
(MonoFoldable mono, Monoid m) =>
(Element mono -> m) -> mono -> m
foldMap (Notebook -> TMNotebookTab -> IO ()
go Notebook
notebook) FocusList TMNotebookTab
tabFocusList
  where
    go :: Notebook -> TMNotebookTab -> IO ()
    go :: Notebook -> TMNotebookTab -> IO ()
go notebook :: Notebook
notebook tmNotebookTab :: TMNotebookTab
tmNotebookTab = do
      let label :: Label
label = TMNotebookTab
tmNotebookTab TMNotebookTab -> Getting Label TMNotebookTab Label -> Label
forall s a. s -> Getting a s a -> a
^. Getting Label TMNotebookTab Label
Lens' TMNotebookTab Label
lensTMNotebookTabLabel
          scrolledWin :: ScrolledWindow
scrolledWin = TMNotebookTab
tmNotebookTab TMNotebookTab
-> Getting ScrolledWindow TMNotebookTab ScrolledWindow
-> ScrolledWindow
forall s a. s -> Getting a s a -> a
^. Getting ScrolledWindow TMNotebookTab ScrolledWindow
Lens' TMNotebookTab ScrolledWindow
lensTMNotebookTabTermContainer
          term' :: Terminal
term' = TMNotebookTab
tmNotebookTab TMNotebookTab
-> Getting Terminal TMNotebookTab Terminal -> Terminal
forall s a. s -> Getting a s a -> a
^. (TMTerm -> Const Terminal TMTerm)
-> TMNotebookTab -> Const Terminal TMNotebookTab
Lens' TMNotebookTab TMTerm
lensTMNotebookTabTerm ((TMTerm -> Const Terminal TMTerm)
 -> TMNotebookTab -> Const Terminal TMNotebookTab)
-> ((Terminal -> Const Terminal Terminal)
    -> TMTerm -> Const Terminal TMTerm)
-> Getting Terminal TMNotebookTab Terminal
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Terminal -> Const Terminal Terminal)
-> TMTerm -> Const Terminal TMTerm
Lens' TMTerm Terminal
lensTerm
      Notebook -> Label -> ScrolledWindow -> Terminal -> IO ()
relabelTab Notebook
notebook Label
label ScrolledWindow
scrolledWin Terminal
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 :: Int -> Maybe Text -> Text
computeTabLabel pageNum :: Int
pageNum maybeTitle :: Maybe Text
maybeTitle =
  let title :: Text
title = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe "shell" Maybe Text
maybeTitle
  in Int -> Text
forall a. Show a => a -> Text
tshow (Int
pageNum Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ". " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
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 -> ScrolledWindow -> Terminal -> IO ()
relabelTab notebook :: Notebook
notebook label :: Label
label scrolledWin :: ScrolledWindow
scrolledWin term' :: Terminal
term' = do
  Int32
tabNum <- Notebook -> ScrolledWindow -> IO Int32
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsNotebook a, IsWidget b) =>
a -> b -> m Int32
notebookPageNum Notebook
notebook ScrolledWindow
scrolledWin
  Maybe Text
maybeTitle <- Terminal -> IO (Maybe Text)
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsTerminal a) =>
a -> m (Maybe Text)
terminalGetWindowTitle Terminal
term'
  let labelText :: Text
labelText = Int -> Maybe Text -> Text
computeTabLabel (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
tabNum) Maybe Text
maybeTitle
  Label -> Text -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsLabel a) =>
a -> Text -> m ()
labelSetLabel Label
label Text
labelText

showScrollbarToPolicy :: ShowScrollbar -> PolicyType
showScrollbarToPolicy :: ShowScrollbar -> PolicyType
showScrollbarToPolicy ShowScrollbarNever = PolicyType
PolicyTypeNever
showScrollbarToPolicy ShowScrollbarIfNeeded = PolicyType
PolicyTypeAutomatic
showScrollbarToPolicy ShowScrollbarAlways = PolicyType
PolicyTypeAlways

createScrolledWin :: TMState -> IO ScrolledWindow
createScrolledWin :: TMState -> IO ScrolledWindow
createScrolledWin mvarTMState :: TMState
mvarTMState = do
  TMState'
tmState <- TMState -> IO TMState'
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar TMState
mvarTMState
  let showScrollbarVal :: ShowScrollbar
showScrollbarVal =
        TMState'
tmState TMState'
-> Getting ShowScrollbar TMState' ShowScrollbar -> ShowScrollbar
forall s a. s -> Getting a s a -> a
^. (TMConfig -> Const ShowScrollbar TMConfig)
-> TMState' -> Const ShowScrollbar TMState'
Lens' TMState' TMConfig
lensTMStateConfig ((TMConfig -> Const ShowScrollbar TMConfig)
 -> TMState' -> Const ShowScrollbar TMState')
-> ((ShowScrollbar -> Const ShowScrollbar ShowScrollbar)
    -> TMConfig -> Const ShowScrollbar TMConfig)
-> Getting ShowScrollbar TMState' ShowScrollbar
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (ConfigOptions -> Const ShowScrollbar ConfigOptions)
-> TMConfig -> Const ShowScrollbar TMConfig
Lens' TMConfig ConfigOptions
lensOptions ((ConfigOptions -> Const ShowScrollbar ConfigOptions)
 -> TMConfig -> Const ShowScrollbar TMConfig)
-> ((ShowScrollbar -> Const ShowScrollbar ShowScrollbar)
    -> ConfigOptions -> Const ShowScrollbar ConfigOptions)
-> (ShowScrollbar -> Const ShowScrollbar ShowScrollbar)
-> TMConfig
-> Const ShowScrollbar TMConfig
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (ShowScrollbar -> Const ShowScrollbar ShowScrollbar)
-> ConfigOptions -> Const ShowScrollbar ConfigOptions
Lens' ConfigOptions ShowScrollbar
lensShowScrollbar
      vScrollbarPolicy :: PolicyType
vScrollbarPolicy = ShowScrollbar -> PolicyType
showScrollbarToPolicy ShowScrollbar
showScrollbarVal
  ScrolledWindow
scrolledWin <-
    Maybe Adjustment -> Maybe Adjustment -> IO ScrolledWindow
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsAdjustment a, IsAdjustment b) =>
Maybe a -> Maybe b -> m ScrolledWindow
scrolledWindowNew
      (Maybe Adjustment
forall a. Maybe a
Nothing :: Maybe Adjustment)
      (Maybe Adjustment
forall a. Maybe a
Nothing :: Maybe Adjustment)
  ScrolledWindow -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
widgetShow ScrolledWindow
scrolledWin
  ScrolledWindow -> PolicyType -> PolicyType -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsScrolledWindow a) =>
a -> PolicyType -> PolicyType -> m ()
scrolledWindowSetPolicy ScrolledWindow
scrolledWin PolicyType
PolicyTypeAutomatic PolicyType
vScrollbarPolicy
  ScrolledWindow -> IO ScrolledWindow
forall (f :: * -> *) a. Applicative f => a -> f a
pure ScrolledWindow
scrolledWin

createNotebookTabLabel :: IO (Box, Label, Button)
createNotebookTabLabel :: IO (Box, Label, Button)
createNotebookTabLabel = do
  Box
box <- Orientation -> Int32 -> IO Box
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Orientation -> Int32 -> m Box
boxNew Orientation
OrientationHorizontal 5
  Label
label <- Maybe Text -> IO Label
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Maybe Text -> m Label
labelNew (Text -> Maybe Text
forall a. a -> Maybe a
Just "")
  Label -> EllipsizeMode -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsLabel a) =>
a -> EllipsizeMode -> m ()
labelSetEllipsize Label
label EllipsizeMode
EllipsizeModeMiddle
  Label -> Int32 -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsLabel a) =>
a -> Int32 -> m ()
labelSetMaxWidthChars Label
label 10
  Label -> Bool -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> Bool -> m ()
widgetSetHexpand Label
label Bool
True
  Label -> Align -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> Align -> m ()
widgetSetHalign Label
label Align
AlignFill
  Button
button <-
    Maybe Text -> Int32 -> IO Button
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Maybe Text -> Int32 -> m Button
buttonNewFromIconName
      (Text -> Maybe Text
forall a. a -> Maybe a
Just "window-close")
      (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (IconSize -> Int
forall a. Enum a => a -> Int
fromEnum IconSize
IconSizeMenu))
  Button -> ReliefStyle -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsButton a) =>
a -> ReliefStyle -> m ()
buttonSetRelief Button
button ReliefStyle
ReliefStyleNone
  Box -> Label -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
containerAdd Box
box Label
label
  Box -> Button -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
containerAdd Box
box Button
button
  Button -> Bool -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> Bool -> m ()
widgetSetCanFocus Button
button Bool
False
  Label -> Bool -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> Bool -> m ()
widgetSetCanFocus Label
label Bool
False
  Box -> Bool -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> Bool -> m ()
widgetSetCanFocus Box
box Bool
False
  Box -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
widgetShow Box
box
  Label -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
widgetShow Label
label
  Button -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
widgetShow Button
button
  (Box, Label, Button) -> IO (Box, Label, Button)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Box
box, Label
label, Button
button)

setShowTabs :: TMConfig -> Notebook -> IO ()
setShowTabs :: TMConfig -> Notebook -> IO ()
setShowTabs tmConfig :: TMConfig
tmConfig note :: Notebook
note = do
  Int32
npages <- Notebook -> IO Int32
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsNotebook a) =>
a -> m Int32
notebookGetNPages Notebook
note
  let shouldShowTabs :: Bool
shouldShowTabs =
        case TMConfig
tmConfig TMConfig -> Getting ShowTabBar TMConfig ShowTabBar -> ShowTabBar
forall s a. s -> Getting a s a -> a
^. (ConfigOptions -> Const ShowTabBar ConfigOptions)
-> TMConfig -> Const ShowTabBar TMConfig
Lens' TMConfig ConfigOptions
lensOptions ((ConfigOptions -> Const ShowTabBar ConfigOptions)
 -> TMConfig -> Const ShowTabBar TMConfig)
-> ((ShowTabBar -> Const ShowTabBar ShowTabBar)
    -> ConfigOptions -> Const ShowTabBar ConfigOptions)
-> Getting ShowTabBar TMConfig ShowTabBar
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (ShowTabBar -> Const ShowTabBar ShowTabBar)
-> ConfigOptions -> Const ShowTabBar ConfigOptions
Lens' ConfigOptions ShowTabBar
lensShowTabBar of
          ShowTabBarIfNeeded -> Int32
npages Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
> 1
          ShowTabBarAlways   -> Bool
True
          ShowTabBarNever    -> Bool
False
  Notebook -> Bool -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsNotebook a) =>
a -> Bool -> m ()
notebookSetShowTabs Notebook
note Bool
shouldShowTabs

toRGBA :: Colour Double -> IO RGBA
toRGBA :: Colour Double -> IO RGBA
toRGBA colour :: Colour Double
colour = do
  let RGB red :: Double
red green :: Double
green blue :: Double
blue = Colour Double -> RGB Double
forall b. (Ord b, Floating b) => Colour b -> RGB b
toSRGB Colour Double
colour
  RGBA
rgba <- IO RGBA
forall (m :: * -> *). MonadIO m => m RGBA
newZeroRGBA
  RGBA -> Double -> IO ()
forall (m :: * -> *). MonadIO m => RGBA -> Double -> m ()
setRGBARed RGBA
rgba Double
red
  RGBA -> Double -> IO ()
forall (m :: * -> *). MonadIO m => RGBA -> Double -> m ()
setRGBAGreen RGBA
rgba Double
green
  RGBA -> Double -> IO ()
forall (m :: * -> *). MonadIO m => RGBA -> Double -> m ()
setRGBABlue RGBA
rgba Double
blue
  RGBA -> IO RGBA
forall (f :: * -> *) a. Applicative f => a -> f a
pure RGBA
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 :: Int -> IO (Maybe Text)
cwdOfPid pd :: Int
pd = do
#ifdef mingw32_HOST_OS
  pure Nothing
#else
#ifdef darwin_HOST_OS
  pure Nothing
#else
  let pidPath :: FilePath
pidPath = "/proc" FilePath -> FilePath -> FilePath
</> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
pd FilePath -> FilePath -> FilePath
</> "cwd"
  Either IOException FilePath
eitherLinkTarget <- IO FilePath -> IO (Either IOException FilePath)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (IO FilePath -> IO (Either IOException FilePath))
-> IO FilePath -> IO (Either IOException FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
getSymbolicLinkTarget FilePath
pidPath
  case Either IOException FilePath
eitherLinkTarget of
    Left (IOException
_ :: IOException) -> Maybe Text -> IO (Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing
    Right linkTarget :: FilePath
linkTarget -> Maybe Text -> IO (Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> IO (Maybe Text)) -> Maybe Text -> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ [Element Text] -> Text
forall seq. IsSequence seq => [Element seq] -> seq
pack FilePath
[Element Text]
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 :: TMNotebook -> IO (Maybe Text)
getCWDFromFocusedTab currNote :: TMNotebook
currNote = do
  let maybeFocusedTab :: Maybe TMNotebookTab
maybeFocusedTab = FocusList TMNotebookTab -> Maybe TMNotebookTab
forall a. FocusList a -> Maybe a
getFocusItemFL (TMNotebook -> FocusList TMNotebookTab
tmNotebookTabs TMNotebook
currNote)
  case Maybe TMNotebookTab
maybeFocusedTab of
    Nothing -> Maybe Text -> IO (Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing
    Just focusedNotebookTab :: TMNotebookTab
focusedNotebookTab -> do
      let shellPid :: Int
shellPid = TMTerm -> Int
pid (TMNotebookTab -> TMTerm
tmNotebookTabTerm TMNotebookTab
focusedNotebookTab)
      Int -> IO (Maybe Text)
cwdOfPid Int
shellPid

-- | Create the VTE 'Terminal', set the fonts and options
createAndInitVteTerm :: FontDescription -> ConfigOptions -> IO Terminal
createAndInitVteTerm :: FontDescription -> ConfigOptions -> IO Terminal
createAndInitVteTerm tmStateFontDesc :: FontDescription
tmStateFontDesc curOpts :: ConfigOptions
curOpts = do
  Terminal
vteTerm <- IO Terminal
forall (m :: * -> *). (HasCallStack, MonadIO m) => m Terminal
terminalNew
  Terminal -> Maybe FontDescription -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsTerminal a) =>
a -> Maybe FontDescription -> m ()
terminalSetFont Terminal
vteTerm (FontDescription -> Maybe FontDescription
forall a. a -> Maybe a
Just FontDescription
tmStateFontDesc)
  Terminal -> Text -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsTerminal a) =>
a -> Text -> m ()
terminalSetWordCharExceptions Terminal
vteTerm (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ ConfigOptions -> Text
wordCharExceptions ConfigOptions
curOpts
  Terminal -> CLong -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsTerminal a) =>
a -> CLong -> m ()
terminalSetScrollbackLines Terminal
vteTerm (Integer -> CLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ConfigOptions -> Integer
scrollbackLen ConfigOptions
curOpts))
  Terminal -> CursorBlinkMode -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsTerminal a) =>
a -> CursorBlinkMode -> m ()
terminalSetCursorBlinkMode Terminal
vteTerm (ConfigOptions -> CursorBlinkMode
cursorBlinkMode ConfigOptions
curOpts)
  Terminal -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
widgetShow Terminal
vteTerm
  Terminal -> IO Terminal
forall (f :: * -> *) a. Applicative f => a -> f a
pure Terminal
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 :: Terminal -> Maybe Text -> IO Int
launchShell vteTerm :: Terminal
vteTerm maybeCurrDir :: Maybe Text
maybeCurrDir = do
  -- Should probably use GI.Vte.Functions.getUserShell, but contrary to its
  -- documentation it raises an exception rather wrap in Maybe.
  Maybe FilePath
mShell <- FilePath -> IO (Maybe FilePath)
lookupEnv "SHELL"
  let argv :: [FilePath]
argv = [FilePath] -> Maybe [FilePath] -> [FilePath]
forall a. a -> Maybe a -> a
fromMaybe ["/usr/bin/env", "bash"] (FilePath -> [FilePath]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> [FilePath]) -> Maybe FilePath -> Maybe [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe FilePath
mShell)
  -- Launch the shell
  Int32
shellPid <-
    Terminal
-> [PtyFlags]
-> Maybe Text
-> [FilePath]
-> Maybe [FilePath]
-> [SpawnFlags]
-> Maybe (IO ())
-> Maybe Cancellable
-> IO Int32
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsTerminal a, IsCancellable b) =>
a
-> [PtyFlags]
-> Maybe Text
-> [FilePath]
-> Maybe [FilePath]
-> [SpawnFlags]
-> Maybe (IO ())
-> Maybe b
-> m Int32
terminalSpawnSync
      Terminal
vteTerm
      [Item [PtyFlags]
PtyFlags
PtyFlagsDefault]
      Maybe Text
maybeCurrDir
      [FilePath]
argv
      Maybe [FilePath]
forall a. Maybe a
Nothing
      ([Item [SpawnFlags]
SpawnFlags
SpawnFlagsDefault] :: [SpawnFlags])
      Maybe (IO ())
forall a. Maybe a
Nothing
      (Maybe Cancellable
forall a. Maybe a
Nothing :: Maybe Cancellable)
  Int -> IO Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
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 :: TMState -> TMNotebookTab -> Box -> IO ()
addPage mvarTMState :: TMState
mvarTMState notebookTab :: TMNotebookTab
notebookTab tabLabelBox :: Box
tabLabelBox = do
  -- Append a new notebook page and update the TMState to reflect this.
  (note :: Notebook
note, pageIndex :: Int32
pageIndex) <- TMState
-> (TMState' -> IO (TMState', (Notebook, Int32)))
-> IO (Notebook, Int32)
forall (m :: * -> *) a b.
MonadUnliftIO m =>
MVar a -> (a -> m (a, b)) -> m b
modifyMVar TMState
mvarTMState TMState' -> IO (TMState', (Notebook, Int32))
appendNotebookPage

  -- Switch the current Notebook page to the the newly added page.
  Notebook -> Int32 -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsNotebook a) =>
a -> Int32 -> m ()
notebookSetCurrentPage Notebook
note Int32
pageIndex
  where
    appendNotebookPage :: TMState' -> IO (TMState', (Notebook, Int32))
    appendNotebookPage :: TMState' -> IO (TMState', (Notebook, Int32))
appendNotebookPage tmState :: TMState'
tmState = do
      let notebook :: TMNotebook
notebook = TMState' -> TMNotebook
tmStateNotebook TMState'
tmState
          note :: Notebook
note = TMNotebook -> Notebook
tmNotebook TMNotebook
notebook
          tabs :: FocusList TMNotebookTab
tabs = TMNotebook -> FocusList TMNotebookTab
tmNotebookTabs TMNotebook
notebook
          scrolledWin :: ScrolledWindow
scrolledWin = TMNotebookTab -> ScrolledWindow
tmNotebookTabTermContainer TMNotebookTab
notebookTab
      Int32
pageIndex <- Notebook -> ScrolledWindow -> Maybe Box -> IO Int32
forall (m :: * -> *) a b c.
(HasCallStack, MonadIO m, IsNotebook a, IsWidget b, IsWidget c) =>
a -> b -> Maybe c -> m Int32
notebookAppendPage Notebook
note ScrolledWindow
scrolledWin (Box -> Maybe Box
forall a. a -> Maybe a
Just Box
tabLabelBox)
      Notebook -> ScrolledWindow -> Bool -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsNotebook a, IsWidget b) =>
a -> b -> Bool -> m ()
notebookSetTabReorderable Notebook
note ScrolledWindow
scrolledWin Bool
True
      TMConfig -> Notebook -> IO ()
setShowTabs (TMState'
tmState TMState' -> Getting TMConfig TMState' TMConfig -> TMConfig
forall s a. s -> Getting a s a -> a
^. Getting TMConfig TMState' TMConfig
Lens' TMState' TMConfig
lensTMStateConfig) Notebook
note
      let newTabs :: FocusList TMNotebookTab
newTabs = FocusList TMNotebookTab -> TMNotebookTab -> FocusList TMNotebookTab
forall a. FocusList a -> a -> FocusList a
appendFL FocusList TMNotebookTab
tabs TMNotebookTab
notebookTab
          newTMState :: TMState'
newTMState =
            TMState'
tmState TMState' -> (TMState' -> TMState') -> TMState'
forall a b. a -> (a -> b) -> b
& (TMNotebook -> Identity TMNotebook)
-> TMState' -> Identity TMState'
Lens' TMState' TMNotebook
lensTMStateNotebook ((TMNotebook -> Identity TMNotebook)
 -> TMState' -> Identity TMState')
-> ((FocusList TMNotebookTab -> Identity (FocusList TMNotebookTab))
    -> TMNotebook -> Identity TMNotebook)
-> ASetter
     TMState'
     TMState'
     (FocusList TMNotebookTab)
     (FocusList TMNotebookTab)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (FocusList TMNotebookTab -> Identity (FocusList TMNotebookTab))
-> TMNotebook -> Identity TMNotebook
Lens' TMNotebook (FocusList TMNotebookTab)
lensTMNotebookTabs ASetter
  TMState'
  TMState'
  (FocusList TMNotebookTab)
  (FocusList TMNotebookTab)
-> FocusList TMNotebookTab -> TMState' -> TMState'
forall s t a b. ASetter s t a b -> b -> s -> t
.~ FocusList TMNotebookTab
newTabs
      (TMState', (Notebook, Int32)) -> IO (TMState', (Notebook, Int32))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TMState'
newTMState, (Notebook
note, Int32
pageIndex))

-- | Set the keyboard focus on a vte terminal
setFocusOn :: ApplicationWindow -> Terminal -> IO()
setFocusOn :: ApplicationWindow -> Terminal -> IO ()
setFocusOn tmStateAppWin :: ApplicationWindow
tmStateAppWin vteTerm :: Terminal
vteTerm = do
  Terminal -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
widgetGrabFocus Terminal
vteTerm
  ApplicationWindow -> Maybe Terminal -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsWindow a, IsWidget b) =>
a -> Maybe b -> m ()
windowSetFocus ApplicationWindow
tmStateAppWin (Terminal -> Maybe Terminal
forall a. a -> Maybe a
Just Terminal
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 :: (TMState -> EventKey -> IO Bool) -> TMState -> IO TMTerm
createTerm handleKeyPress :: TMState -> EventKey -> IO Bool
handleKeyPress mvarTMState :: TMState
mvarTMState = do
  -- Check preconditions
  TMState -> IO ()
assertInvariantTMState TMState
mvarTMState

  -- Read needed data in TMVar
  TMState{ApplicationWindow
tmStateAppWin :: ApplicationWindow
tmStateAppWin :: TMState' -> ApplicationWindow
tmStateAppWin, FontDescription
tmStateFontDesc :: FontDescription
tmStateFontDesc :: TMState' -> FontDescription
tmStateFontDesc, TMConfig
tmStateConfig :: TMConfig
tmStateConfig :: TMState' -> TMConfig
tmStateConfig, tmStateNotebook :: TMState' -> TMNotebook
tmStateNotebook=TMNotebook
currNote} <-
    TMState -> IO TMState'
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar TMState
mvarTMState

  -- Create a new terminal and launch a shell in it
  Terminal
vteTerm <- FontDescription -> ConfigOptions -> IO Terminal
createAndInitVteTerm FontDescription
tmStateFontDesc (TMConfig -> ConfigOptions
options TMConfig
tmStateConfig)
  Maybe Text
maybeCurrDir <- TMNotebook -> IO (Maybe Text)
getCWDFromFocusedTab TMNotebook
currNote
  Int
termShellPid <- Terminal -> Maybe Text -> IO Int
launchShell Terminal
vteTerm Maybe Text
maybeCurrDir
  TMTerm
tmTerm <- Terminal -> Int -> IO TMTerm
newTMTerm Terminal
vteTerm Int
termShellPid

  -- Create the container add the VTE term in it
  ScrolledWindow
scrolledWin <- TMState -> IO ScrolledWindow
createScrolledWin TMState
mvarTMState
  ScrolledWindow -> Terminal -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
containerAdd ScrolledWindow
scrolledWin Terminal
vteTerm

  -- Create the GTK widget for the Notebook tab
  (tabLabelBox :: Box
tabLabelBox, tabLabel :: Label
tabLabel, tabCloseButton :: Button
tabCloseButton) <- IO (Box, Label, Button)
createNotebookTabLabel

  -- Create notebook state
  let notebookTab :: TMNotebookTab
notebookTab = Label -> ScrolledWindow -> TMTerm -> TMNotebookTab
createTMNotebookTab Label
tabLabel ScrolledWindow
scrolledWin TMTerm
tmTerm

  -- Add the new notebooktab to the notebook.
  TMState -> TMNotebookTab -> Box -> IO ()
addPage TMState
mvarTMState TMNotebookTab
notebookTab Box
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.
  Notebook -> Label -> ScrolledWindow -> Terminal -> IO ()
relabelTab (TMNotebook -> Notebook
tmNotebook TMNotebook
currNote) Label
tabLabel ScrolledWindow
scrolledWin Terminal
vteTerm

  -- Connect callbacks
  IO SignalHandlerId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO SignalHandlerId -> IO ()) -> IO SignalHandlerId -> IO ()
forall a b. (a -> b) -> a -> b
$ Button -> IO () -> IO SignalHandlerId
forall a (m :: * -> *).
(IsButton a, MonadIO m) =>
a -> IO () -> m SignalHandlerId
onButtonClicked Button
tabCloseButton (IO () -> IO SignalHandlerId) -> IO () -> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ TMNotebookTab -> TMState -> IO ()
termClose TMNotebookTab
notebookTab TMState
mvarTMState
  IO SignalHandlerId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO SignalHandlerId -> IO ()) -> IO SignalHandlerId -> IO ()
forall a b. (a -> b) -> a -> b
$ Terminal -> IO () -> IO SignalHandlerId
forall a (m :: * -> *).
(IsTerminal a, MonadIO m) =>
a -> IO () -> m SignalHandlerId
onTerminalWindowTitleChanged Terminal
vteTerm (IO () -> IO SignalHandlerId) -> IO () -> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ do
    TMState{TMNotebook
tmStateNotebook :: TMNotebook
tmStateNotebook :: TMState' -> TMNotebook
tmStateNotebook} <- TMState -> IO TMState'
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar TMState
mvarTMState
    let notebook :: Notebook
notebook = TMNotebook -> Notebook
tmNotebook TMNotebook
tmStateNotebook
    Notebook -> Label -> ScrolledWindow -> Terminal -> IO ()
relabelTab Notebook
notebook Label
tabLabel ScrolledWindow
scrolledWin Terminal
vteTerm
  IO SignalHandlerId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO SignalHandlerId -> IO ()) -> IO SignalHandlerId -> IO ()
forall a b. (a -> b) -> a -> b
$ Terminal -> (EventKey -> IO Bool) -> IO SignalHandlerId
forall a (m :: * -> *).
(IsWidget a, MonadIO m) =>
a -> (EventKey -> IO Bool) -> m SignalHandlerId
onWidgetKeyPressEvent Terminal
vteTerm ((EventKey -> IO Bool) -> IO SignalHandlerId)
-> (EventKey -> IO Bool) -> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ TMState -> EventKey -> IO Bool
handleKeyPress TMState
mvarTMState
  IO SignalHandlerId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO SignalHandlerId -> IO ()) -> IO SignalHandlerId -> IO ()
forall a b. (a -> b) -> a -> b
$ ScrolledWindow -> (EventKey -> IO Bool) -> IO SignalHandlerId
forall a (m :: * -> *).
(IsWidget a, MonadIO m) =>
a -> (EventKey -> IO Bool) -> m SignalHandlerId
onWidgetKeyPressEvent ScrolledWindow
scrolledWin ((EventKey -> IO Bool) -> IO SignalHandlerId)
-> (EventKey -> IO Bool) -> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ TMState -> EventKey -> IO Bool
handleKeyPress TMState
mvarTMState
  IO SignalHandlerId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO SignalHandlerId -> IO ()) -> IO SignalHandlerId -> IO ()
forall a b. (a -> b) -> a -> b
$ Terminal -> WidgetButtonPressEventCallback -> IO SignalHandlerId
forall a (m :: * -> *).
(IsWidget a, MonadIO m) =>
a -> WidgetButtonPressEventCallback -> m SignalHandlerId
onWidgetButtonPressEvent Terminal
vteTerm (WidgetButtonPressEventCallback -> IO SignalHandlerId)
-> WidgetButtonPressEventCallback -> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ Terminal -> WidgetButtonPressEventCallback
handleMousePress Terminal
vteTerm
  IO SignalHandlerId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO SignalHandlerId -> IO ()) -> IO SignalHandlerId -> IO ()
forall a b. (a -> b) -> a -> b
$ Terminal -> (Int32 -> IO ()) -> IO SignalHandlerId
forall a (m :: * -> *).
(IsTerminal a, MonadIO m) =>
a -> (Int32 -> IO ()) -> m SignalHandlerId
onTerminalChildExited Terminal
vteTerm ((Int32 -> IO ()) -> IO SignalHandlerId)
-> (Int32 -> IO ()) -> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ \_ -> TMNotebookTab -> TMState -> IO ()
termExit TMNotebookTab
notebookTab TMState
mvarTMState

  -- Put the keyboard focus on the term
  ApplicationWindow -> Terminal -> IO ()
setFocusOn ApplicationWindow
tmStateAppWin Terminal
vteTerm

  -- Make sure the state is still right
  TMState -> IO ()
assertInvariantTMState TMState
mvarTMState

  -- Run user-defined hooks for modifying the newly-created VTE Terminal.
  ConfigHooks -> TMState -> Terminal -> IO ()
createTermHook (TMConfig -> ConfigHooks
hooks TMConfig
tmStateConfig) TMState
mvarTMState Terminal
vteTerm
  TMTerm -> IO TMTerm
forall (f :: * -> *) a. Applicative f => a -> f a
pure TMTerm
tmTerm

-- | Popup the context menu on right click
handleMousePress :: Terminal -> EventButton -> IO Bool
handleMousePress :: Terminal -> WidgetButtonPressEventCallback
handleMousePress vteTerm :: Terminal
vteTerm event :: EventButton
event = do
  Word32
button <- EventButton -> IO Word32
forall (m :: * -> *). MonadIO m => EventButton -> m Word32
getEventButtonButton EventButton
event
  let rightClick :: Bool
rightClick = Word32
button Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Int32 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
BUTTON_SECONDARY
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
rightClick (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Menu
menuModel <- IO Menu
forall (m :: * -> *). (HasCallStack, MonadIO m) => m Menu
menuNew
    Menu -> Maybe Text -> Maybe Text -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsMenu a) =>
a -> Maybe Text -> Maybe Text -> m ()
menuAppend Menu
menuModel (Text -> Maybe Text
forall a. a -> Maybe a
Just "Copy") (Text -> Maybe Text
forall a. a -> Maybe a
Just "app.copy")
    Menu -> Maybe Text -> Maybe Text -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsMenu a) =>
a -> Maybe Text -> Maybe Text -> m ()
menuAppend Menu
menuModel (Text -> Maybe Text
forall a. a -> Maybe a
Just "Paste") (Text -> Maybe Text
forall a. a -> Maybe a
Just "app.paste")
    Menu
menu <- Menu -> IO Menu
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsMenuModel a) =>
a -> m Menu
menuNewFromModel Menu
menuModel
    Menu -> Terminal -> Maybe MenuDetachFunc -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsMenu a, IsWidget b) =>
a -> b -> Maybe MenuDetachFunc -> m ()
menuAttachToWidget Menu
menu Terminal
vteTerm Maybe MenuDetachFunc
forall a. Maybe a
Nothing
    Menu -> Maybe Event -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsMenu a) =>
a -> Maybe Event -> m ()
menuPopupAtPointer Menu
menu Maybe Event
forall a. Maybe a
Nothing
  Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
rightClick