{-# 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
  ( Event (Event)
  , EventButton
  , EventKey
  , RGBA
  , getEventButtonButton
  , newZeroRGBA
  , setRGBABlue
  , setRGBAGreen
  , setRGBARed
  , pattern BUTTON_SECONDARY
  , pattern CURRENT_TIME
  )
import GI.Gio
  ( Cancellable
  , actionMapAddAction
  , menuAppend
  , menuNew
  , onSimpleActionActivate
  , simpleActionNew
  )
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
  , Window
  , applicationGetActiveWindow
  , boxNew
  , buttonNewFromIconName
  , buttonSetRelief
  , containerAdd
  , dialogAddButton
  , dialogGetContentArea
  , dialogNew
  , dialogRun
  , labelNew
  , labelSetEllipsize
  , labelSetLabel
  , labelSetMaxWidthChars
  , menuAttachToWidget
  , menuNewFromModel
  , menuPopupAtPointer
  , notebookAppendPage
  , notebookDetachTab
  , notebookGetNPages
  , notebookNextPage
  , notebookPageNum
  , notebookPrevPage
  , notebookSetCurrentPage
  , notebookSetShowTabs
  , notebookSetTabReorderable
  , onButtonClicked
  , onWidgetButtonPressEvent
  , onWidgetKeyPressEvent
  , scrolledWindowNew
  , scrolledWindowSetPolicy
  , setWidgetMargin
  , showUriOnWindow
  , widgetDestroy
  , widgetGrabFocus
  , widgetSetCanFocus
  , widgetSetHalign
  , widgetSetHexpand
  , widgetShow
  , windowSetFocus
  , windowSetTransientFor
  )
import GI.Pango (EllipsizeMode(EllipsizeModeMiddle), FontDescription)
import GI.Vte
  ( PtyFlags(PtyFlagsDefault)
  , Terminal
  , onTerminalChildExited
  , onTerminalWindowTitleChanged
  , regexNewForMatch
  , terminalGetAllowHyperlink
  , terminalGetWindowTitle
  , terminalMatchAddRegex
  , terminalMatchCheckEvent
  , terminalNew
  , terminalSetBoldIsBright
  , terminalSetCursorBlinkMode
  , terminalSetFont
  , terminalSetScrollbackLines
  , terminalSetWordCharExceptions
  , terminalSpawnSync
  , terminalSetAllowBold
  )
import System.Directory (getSymbolicLinkTarget)
import System.Environment (lookupEnv)

import Termonad.Gtk (terminalSetEnableSixelIfExists)
import Termonad.Lenses
  ( lensConfirmExit
  , lensOptions
  , lensShowScrollbar
  , lensShowTabBar
  , lensTMNotebookTabLabel
  , lensTMNotebookTabTerm
  , lensTMNotebookTabTermContainer
  , lensTMNotebookTabs
  , lensTMStateApp
  , lensTMStateConfig
  , lensTMStateNotebook
  , lensTerm
  )
import Termonad.Types
  ( ConfigHooks(createTermHook)
  , ConfigOptions(scrollbackLen, wordCharExceptions, cursorBlinkMode, boldIsBright, enableSixel, allowBold)
  , ShowScrollbar(..)
  , ShowTabBar(..)
  , TMConfig(hooks, options)
  , TMNotebook
  , TMNotebookTab
  , TMState
  , TMState'(TMState, tmStateAppWin, tmStateConfig, tmStateFontDesc, tmStateNotebook)
  , TMTerm
  , assertInvariantTMState
  , createTMNotebookTab
  , newTMTerm
  , pid
  , tmNotebook
  , tmNotebookTabTerm
  , tmNotebookTabTermContainer
  , tmNotebookTabs
  )
import Data.Coerce (coerce)
import Data.GI.Base (toManagedPtr)
import Termonad.Pcre (pcre2Multiline)

focusTerm :: Int -> TMState -> IO ()
focusTerm :: Int -> TMState -> IO ()
focusTerm Int
i TMState
mvarTMState = do
  note <- TMNotebook -> Notebook
tmNotebook (TMNotebook -> Notebook)
-> (TMState' -> TMNotebook) -> TMState' -> Notebook
forall b c a. (b -> c) -> (a -> b) -> a -> c
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
  notebookSetCurrentPage note (fromIntegral i)

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

termNextPage :: TMState -> IO ()
termNextPage :: TMState -> IO ()
termNextPage TMState
mvarTMState = do
  note <- TMNotebook -> Notebook
tmNotebook (TMNotebook -> Notebook)
-> (TMState' -> TMNotebook) -> TMState' -> Notebook
forall b c a. (b -> c) -> (a -> b) -> a -> c
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
  notebookNextPage note

termPrevPage :: TMState -> IO ()
termPrevPage :: TMState -> IO ()
termPrevPage TMState
mvarTMState = do
  note <- TMNotebook -> Notebook
tmNotebook (TMNotebook -> Notebook)
-> (TMState' -> TMNotebook) -> TMState' -> Notebook
forall b c a. (b -> c) -> (a -> b) -> a -> c
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
  notebookPrevPage note

termExitFocused :: TMState -> IO ()
termExitFocused :: TMState -> IO ()
termExitFocused TMState
mvarTMState = do
  tmState <- TMState -> IO TMState'
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar TMState
mvarTMState
  let 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 b c a. (b -> c) -> (a -> b) -> a -> c
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 b c a. (b -> c) -> (a -> b) -> a -> c
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 maybeTab of
    Maybe TMNotebookTab
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just TMNotebookTab
tab -> TMNotebookTab -> TMState -> IO ()
termClose TMNotebookTab
tab TMState
mvarTMState

termClose :: TMNotebookTab -> TMState -> IO ()
termClose :: TMNotebookTab -> TMState -> IO ()
termClose TMNotebookTab
tab TMState
mvarTMState = do
  tmState <- TMState -> IO TMState'
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar TMState
mvarTMState
  let 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 b c a. (b -> c) -> (a -> b) -> a -> c
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 b c a. (b -> c) -> (a -> b) -> a -> c
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 = if Bool
confirm then TMNotebookTab -> TMState -> IO ()
termExitWithConfirmation else TMNotebookTab -> TMState -> IO ()
termExit
  close tab mvarTMState

termExitWithConfirmation :: TMNotebookTab -> TMState -> IO ()
termExitWithConfirmation :: TMNotebookTab -> TMState -> IO ()
termExitWithConfirmation TMNotebookTab
tab TMState
mvarTMState = do
  tmState <- TMState -> IO TMState'
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar TMState
mvarTMState
  let 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
  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
    ResponseType
ResponseTypeYes -> TMNotebookTab -> TMState -> IO ()
termExit TMNotebookTab
tab TMState
mvarTMState
    ResponseType
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

termExit :: TMNotebookTab -> TMState -> IO ()
termExit :: TMNotebookTab -> TMState -> IO ()
termExit TMNotebookTab
tab TMState
mvarTMState = do
  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 -> 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 b c a. (b -> c) -> (a -> b) -> a -> c
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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TMState'
newTMState, IO ()
detachTabAction)
  detachTabAction
  relabelTabs mvarTMState

relabelTabs :: TMState -> IO ()
relabelTabs :: TMState -> IO ()
relabelTabs TMState
mvarTMState = do
  TMState{tmStateNotebook} <- TMState -> IO TMState'
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar TMState
mvarTMState
  let notebook = TMNotebook -> Notebook
tmNotebook TMNotebook
tmStateNotebook
      tabFocusList = TMNotebook -> FocusList TMNotebookTab
tmNotebookTabs TMNotebook
tmStateNotebook
  foldMap (go notebook) tabFocusList
  where
    go :: Notebook -> TMNotebookTab -> IO ()
    go :: Notebook -> TMNotebookTab -> IO ()
go Notebook
notebook 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 b c a. (b -> c) -> (a -> b) -> a -> c
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 Int
pageNum Maybe Text
maybeTitle =
  let title :: Text
title = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"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
+ Int
1) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
". " 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 Label
label ScrolledWindow
scrolledWin Terminal
term' = do
  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
  maybeTitle <- terminalGetWindowTitle term'
  let labelText = Int -> Maybe Text -> Text
computeTabLabel (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
tabNum) Maybe Text
maybeTitle
  labelSetLabel label labelText

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

createScrolledWin :: TMState -> IO ScrolledWindow
createScrolledWin :: TMState -> IO ScrolledWindow
createScrolledWin TMState
mvarTMState = do
  tmState <- TMState -> IO TMState'
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar TMState
mvarTMState
  let 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 b c a. (b -> c) -> (a -> b) -> a -> c
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 b c a. (b -> c) -> (a -> b) -> a -> c
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 = ShowScrollbar -> PolicyType
showScrollbarToPolicy ShowScrollbar
showScrollbarVal
  scrolledWin <-
    scrolledWindowNew
      (Nothing :: Maybe Adjustment)
      (Nothing :: Maybe Adjustment)
  widgetShow scrolledWin
  scrolledWindowSetPolicy scrolledWin PolicyTypeAutomatic vScrollbarPolicy
  pure scrolledWin

createNotebookTabLabel :: IO (Box, Label, Button)
createNotebookTabLabel :: IO (Box, Label, Button)
createNotebookTabLabel = do
  box <- Orientation -> Int32 -> IO Box
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Orientation -> Int32 -> m Box
boxNew Orientation
OrientationHorizontal Int32
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 -> Notebook -> IO ()
setShowTabs TMConfig
tmConfig Notebook
note = do
  npages <- Notebook -> IO Int32
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsNotebook a) =>
a -> m Int32
notebookGetNPages Notebook
note
  let 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 b c a. (b -> c) -> (a -> b) -> a -> c
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
          ShowTabBar
ShowTabBarIfNeeded -> Int32
npages Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
> Int32
1
          ShowTabBar
ShowTabBarAlways   -> Bool
True
          ShowTabBar
ShowTabBarNever    -> Bool
False
  notebookSetShowTabs note shouldShowTabs

toRGBA :: Colour Double -> IO RGBA
toRGBA :: Colour Double -> IO RGBA
toRGBA Colour Double
colour = do
  let RGB Double
red Double
green Double
blue = Colour Double -> RGB Double
forall b. (Ord b, Floating b) => Colour b -> RGB b
toSRGB Colour Double
colour
  rgba <- IO RGBA
forall (m :: * -> *). MonadIO m => m 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 :: Int -> IO (Maybe Text)
cwdOfPid Int
pd = do
#ifdef mingw32_HOST_OS
  pure Nothing
#else
#ifdef darwin_HOST_OS
  pure Nothing
#else
  let pidPath :: String
pidPath = String
"/proc" String -> String -> String
</> Int -> String
forall a. Show a => a -> String
show Int
pd String -> String -> String
</> String
"cwd"
  eitherLinkTarget <- IO String -> IO (Either IOException String)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (IO String -> IO (Either IOException String))
-> IO String -> IO (Either IOException String)
forall a b. (a -> b) -> a -> b
$ String -> IO String
getSymbolicLinkTarget String
pidPath
  case eitherLinkTarget of
    Left (IOException
_ :: IOException) -> Maybe Text -> IO (Maybe Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing
    Right String
linkTarget -> Maybe Text -> IO (Maybe Text)
forall a. a -> IO a
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 String
[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 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
    Maybe TMNotebookTab
Nothing -> Maybe Text -> IO (Maybe Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing
    Just 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 FontDescription
tmStateFontDesc ConfigOptions
curOpts = do
  vteTerm <- IO Terminal
forall (m :: * -> *). (HasCallStack, MonadIO m) => m Terminal
terminalNew
  terminalSetFont vteTerm (Just tmStateFontDesc)
  terminalSetWordCharExceptions vteTerm $ wordCharExceptions curOpts
  terminalSetScrollbackLines vteTerm (fromIntegral (scrollbackLen curOpts))
  terminalSetCursorBlinkMode vteTerm (cursorBlinkMode curOpts)
  terminalSetBoldIsBright vteTerm (boldIsBright curOpts)
  terminalSetEnableSixelIfExists vteTerm (enableSixel curOpts)
  terminalSetAllowBold vteTerm (allowBold 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 :: Terminal -> Maybe Text -> IO Int
launchShell Terminal
vteTerm Maybe Text
maybeCurrDir = do
  -- Should probably use GI.Vte.Functions.getUserShell, but contrary to its
  -- documentation it raises an exception rather wrap in Maybe.
  mShell <- String -> IO (Maybe String)
lookupEnv String
"SHELL"
  let argv = [String] -> (String -> [String]) -> Maybe String -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [String
Item [String]
"/usr/bin/env", String
Item [String]
"bash"] String -> [String]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
mShell
  -- Launch the shell
  shellPid <-
    terminalSpawnSync
      vteTerm
      [PtyFlagsDefault]
      maybeCurrDir
      argv
      Nothing
      ([SpawnFlagsDefault] :: [SpawnFlags])
      Nothing
      (Nothing :: Maybe Cancellable)
  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 :: TMState -> TMNotebookTab -> Box -> IO ()
addPage TMState
mvarTMState TMNotebookTab
notebookTab Box
tabLabelBox = do
  -- Append a new notebook page and update the TMState to reflect this.
  (note, 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.
  notebookSetCurrentPage note pageIndex
  where
    appendNotebookPage :: TMState' -> IO (TMState', (Notebook, Int32))
    appendNotebookPage :: TMState' -> IO (TMState', (Notebook, Int32))
appendNotebookPage 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
      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)
      notebookSetTabReorderable note scrolledWin True
      setShowTabs (tmState ^. lensTMStateConfig) note
      let newTabs = FocusList TMNotebookTab -> TMNotebookTab -> FocusList TMNotebookTab
forall a. FocusList a -> a -> FocusList a
appendFL FocusList TMNotebookTab
tabs TMNotebookTab
notebookTab
          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 b c a. (b -> c) -> (a -> b) -> a -> c
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
      pure (newTMState, (note, pageIndex))

-- | Set the keyboard focus on a vte terminal
setFocusOn :: ApplicationWindow -> Terminal -> IO()
setFocusOn :: ApplicationWindow -> Terminal -> IO ()
setFocusOn ApplicationWindow
tmStateAppWin 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 TMState -> EventKey -> IO Bool
handleKeyPress TMState
mvarTMState = do
  -- Check preconditions
  TMState -> IO ()
assertInvariantTMState TMState
mvarTMState

  -- Read needed data in TMVar
  TMState{tmStateAppWin, tmStateFontDesc, tmStateConfig, tmStateNotebook=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
  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 = Label -> ScrolledWindow -> TMTerm -> TMNotebookTab
createTMNotebookTab Label
tabLabel ScrolledWindow
scrolledWin TMTerm
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 -> Notebook
tmNotebook TMNotebook
tmStateNotebook
    relabelTab notebook tabLabel scrolledWin vteTerm
  void $ onWidgetKeyPressEvent vteTerm $ handleKeyPress mvarTMState
  void $ onWidgetKeyPressEvent scrolledWin $ handleKeyPress mvarTMState
  void $ onWidgetButtonPressEvent vteTerm $ handleMousePress tmStateAppWin vteTerm
  void $ onTerminalChildExited vteTerm $ \Int32
_ -> TMNotebookTab -> TMState -> IO ()
termExit TMNotebookTab
notebookTab TMState
mvarTMState

  -- Underline URLs so that the user can see they are right-clickable.
  --
  -- This regex is from https://www.regextester.com/94502
  --
  -- TODO: Roxterm and gnome-terminal have a much more in-depth set of regexes
  -- for URLs and things similar to URLs.  At some point it might make sense to
  -- switch to something like this:
  -- https://github.com/realh/roxterm/blob/30f1faf8be4ccac8ba12b59feb5b8f758bc65a7b/src/roxterm-regex.c
  -- and
  -- https://github.com/realh/roxterm/blob/30f1faf8be4ccac8ba12b59feb5b8f758bc65a7b/src/terminal-regex.h
  let regexPat =
        Text
"(?:http(s)?:\\/\\/)[\\w.-]+(?:\\.[\\w\\.-]+)+[\\w\\-\\._~:/?#[\\]@!\\$&'\\(\\)\\*\\+,;=.]+"
  -- We must set the pcre2Multiline option, otherwise VTE prints a warning.
  let pcreFlags = CUInt -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral CUInt
pcre2Multiline
  regex <- regexNewForMatch regexPat (fromIntegral $ length regexPat) pcreFlags
  void $ terminalMatchAddRegex vteTerm regex 0

  -- 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 :: ApplicationWindow -> Terminal -> EventButton -> IO Bool
handleMousePress :: ApplicationWindow -> Terminal -> WidgetButtonPressEventCallback
handleMousePress ApplicationWindow
win Terminal
vteTerm EventButton
eventButton = do
  x <- Terminal -> IO Bool
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsTerminal a) =>
a -> m Bool
terminalGetAllowHyperlink Terminal
vteTerm
  print x
  button <- getEventButtonButton eventButton
  let 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
  when rightClick $ do
    menuModel <- menuNew

    -- if the user right-clicked on a URL, add an option to open the URL
    -- in a browser
    (maybeUrl, _regexId) <- terminalMatchCheckEvent vteTerm (eventButtonToEvent eventButton)
    case maybeUrl of
      Maybe Text
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just Text
url -> do
        openUrlAction <- Text -> Maybe VariantType -> IO SimpleAction
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Text -> Maybe VariantType -> m SimpleAction
simpleActionNew Text
"openurl" Maybe VariantType
forall a. Maybe a
Nothing
        void $ onSimpleActionActivate openUrlAction $ \Maybe GVariant
_ ->
          Maybe Window -> Text -> Word32 -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWindow a) =>
Maybe a -> Text -> Word32 -> m ()
showUriOnWindow (Maybe Window
forall a. Maybe a
Nothing :: Maybe Window) Text
url (Int32 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
CURRENT_TIME)
        -- This will add the openurl action to the Application Window's action
        -- map everytime the user right-clicks on a URL.  It is okay to add
        -- actions multiple times.
        actionMapAddAction win openUrlAction
        menuAppend menuModel (Just "Open URL in browser") (Just "win.openurl")


    menuAppend menuModel (Just "Copy") (Just "app.copy")
    menuAppend menuModel (Just "Paste") (Just "app.paste")
    menuAppend menuModel (Just "Preferences") (Just "app.preferences")
    menu <- menuNewFromModel menuModel
    menuAttachToWidget menu vteTerm Nothing
    menuPopupAtPointer menu Nothing
  pure rightClick

-- The terminalMatchCheckEvent function takes an Event, while we only
-- have an EventButton.  It is apparently okay to just cast an EventButton
-- to an Event, since they are just pointers under the hood, and they
-- are laid out the same in memory.  See
-- https://github.com/haskell-gi/haskell-gi/issues/109
eventButtonToEvent :: EventButton -> Event
eventButtonToEvent :: EventButton -> Event
eventButtonToEvent = ManagedPtr Event -> Event
Event (ManagedPtr Event -> Event)
-> (EventButton -> ManagedPtr Event) -> EventButton -> Event
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ManagedPtr EventButton -> ManagedPtr Event
forall a b. Coercible a b => a -> b
coerce (ManagedPtr EventButton -> ManagedPtr Event)
-> (EventButton -> ManagedPtr EventButton)
-> EventButton
-> ManagedPtr Event
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. EventButton -> ManagedPtr EventButton
forall a. ManagedPtrNewtype a => a -> ManagedPtr a
toManagedPtr