{-# 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
  Notebook
note <- TMNotebook -> Notebook
tmNotebook 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar TMState
mvarTMState
  forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsNotebook a) =>
a -> Int32 -> m ()
notebookSetCurrentPage Notebook
note (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

termNextPage :: TMState -> IO ()
termNextPage :: TMState -> IO ()
termNextPage TMState
mvarTMState = do
  Notebook
note <- TMNotebook -> Notebook
tmNotebook 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar TMState
mvarTMState
  forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsNotebook a) =>
a -> m ()
notebookNextPage Notebook
note

termPrevPage :: TMState -> IO ()
termPrevPage :: TMState -> IO ()
termPrevPage TMState
mvarTMState = do
  Notebook
note <- TMNotebook -> Notebook
tmNotebook 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar TMState
mvarTMState
  forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsNotebook a) =>
a -> m ()
notebookPrevPage Notebook
note

termExitFocused :: TMState -> IO ()
termExitFocused :: TMState -> IO ()
termExitFocused TMState
mvarTMState = do
  TMState'
tmState <- forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar TMState
mvarTMState
  let maybeTab :: Maybe TMNotebookTab
maybeTab =
        TMState'
tmState forall s a. s -> Getting a s a -> a
^. Lens' TMState' TMNotebook
lensTMStateNotebook forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Lens' TMNotebook (FocusList TMNotebookTab)
lensTMNotebookTabs forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to forall a. FocusList a -> Maybe a
getFocusItemFL
  case Maybe TMNotebookTab
maybeTab of
    Maybe TMNotebookTab
Nothing -> 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 <- forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar TMState
mvarTMState
  let confirm :: Bool
confirm = TMState'
tmState forall s a. s -> Getting a s a -> a
^. Lens' TMState' TMConfig
lensTMStateConfig forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Lens' TMConfig ConfigOptions
lensOptions forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. 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 TMNotebookTab
tab TMState
mvarTMState = do
  TMState'
tmState <- forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar TMState
mvarTMState
  let app :: Application
app = TMState'
tmState forall s a. s -> Getting a s a -> a
^. Lens' TMState' Application
lensTMStateApp
  Maybe Window
win <- forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsApplication a) =>
a -> m (Maybe Window)
applicationGetActiveWindow Application
app
  Dialog
dialog <- forall (m :: * -> *). (HasCallStack, MonadIO m) => m Dialog
dialogNew
  Box
box <- forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsDialog a) =>
a -> m Box
dialogGetContentArea Dialog
dialog
  Label
label <- forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Maybe Text -> m Label
labelNew (forall a. a -> Maybe a
Just Text
"Close tab?")
  forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
containerAdd Box
box Label
label
  forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
widgetShow Label
label
  forall (m :: * -> *) o.
(MonadIO m, IsWidget o) =>
o -> Int32 -> m ()
setWidgetMargin Label
label Int32
10
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsDialog a) =>
a -> Text -> Int32 -> m Widget
dialogAddButton
      Dialog
dialog
      Text
"No, do NOT close tab"
      (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Enum a => a -> Int
fromEnum ResponseType
ResponseTypeNo))
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsDialog a) =>
a -> Text -> Int32 -> m Widget
dialogAddButton
      Dialog
dialog
      Text
"Yes, close tab"
      (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Enum a => a -> Int
fromEnum ResponseType
ResponseTypeYes))
  forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsWindow a, IsWindow b) =>
a -> Maybe b -> m ()
windowSetTransientFor Dialog
dialog Maybe Window
win
  Int32
res <- forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsDialog a) =>
a -> m Int32
dialogRun Dialog
dialog
  forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
widgetDestroy Dialog
dialog
  case forall a. Enum a => Int -> a
toEnum (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
res) of
    ResponseType
ResponseTypeYes -> TMNotebookTab -> TMState -> IO ()
termExit TMNotebookTab
tab TMState
mvarTMState
    ResponseType
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

termExit :: TMNotebookTab -> TMState -> IO ()
termExit :: TMNotebookTab -> TMState -> IO ()
termExit TMNotebookTab
tab TMState
mvarTMState = do
  IO ()
detachTabAction <-
    forall (m :: * -> *) a b.
MonadUnliftIO m =>
MVar a -> (a -> m (a, b)) -> m b
modifyMVar TMState
mvarTMState forall a b. (a -> b) -> a -> b
$ \TMState'
tmState -> do
      let notebook :: TMNotebook
notebook = TMState' -> TMNotebook
tmStateNotebook TMState'
tmState
          detachTabAction :: IO ()
detachTabAction =
            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 = forall a. Eq a => a -> FocusList a -> FocusList a
deleteFL TMNotebookTab
tab (TMNotebook -> FocusList TMNotebookTab
tmNotebookTabs TMNotebook
notebook)
      let newTMState :: TMState'
newTMState =
            forall s t a b. ASetter s t a b -> b -> s -> t
set (Lens' TMState' TMNotebook
lensTMStateNotebook forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Lens' TMNotebook (FocusList TMNotebookTab)
lensTMNotebookTabs) FocusList TMNotebookTab
newTabs TMState'
tmState
      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 TMState
mvarTMState = do
  TMState{TMNotebook
tmStateNotebook :: TMNotebook
tmStateNotebook :: TMState' -> TMNotebook
tmStateNotebook} <- 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
  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 TMNotebookTab
tmNotebookTab = do
      let label :: Label
label = TMNotebookTab
tmNotebookTab forall s a. s -> Getting a s a -> a
^. Lens' TMNotebookTab Label
lensTMNotebookTabLabel
          scrolledWin :: ScrolledWindow
scrolledWin = TMNotebookTab
tmNotebookTab forall s a. s -> Getting a s a -> a
^. Lens' TMNotebookTab ScrolledWindow
lensTMNotebookTabTermContainer
          term' :: Terminal
term' = TMNotebookTab
tmNotebookTab forall s a. s -> Getting a s a -> a
^. Lens' TMNotebookTab TMTerm
lensTMNotebookTabTerm forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. 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 = forall a. a -> Maybe a -> a
fromMaybe Text
"shell" Maybe Text
maybeTitle
  in forall a. Show a => a -> Text
tshow (Int
pageNum forall a. Num a => a -> a -> a
+ Int
1) forall a. Semigroup a => a -> a -> a
<> 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
  Int32
tabNum <- forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsNotebook a, IsWidget b) =>
a -> b -> m Int32
notebookPageNum Notebook
notebook ScrolledWindow
scrolledWin
  Maybe Text
maybeTitle <- forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsTerminal a) =>
a -> m (Maybe Text)
terminalGetWindowTitle Terminal
term'
  let labelText :: Text
labelText = Int -> Maybe Text -> Text
computeTabLabel (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
tabNum) Maybe Text
maybeTitle
  forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsLabel a) =>
a -> Text -> m ()
labelSetLabel Label
label Text
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 <- forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar TMState
mvarTMState
  let showScrollbarVal :: ShowScrollbar
showScrollbarVal =
        TMState'
tmState forall s a. s -> Getting a s a -> a
^. Lens' TMState' TMConfig
lensTMStateConfig forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Lens' TMConfig ConfigOptions
lensOptions forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Lens' ConfigOptions ShowScrollbar
lensShowScrollbar
      vScrollbarPolicy :: PolicyType
vScrollbarPolicy = ShowScrollbar -> PolicyType
showScrollbarToPolicy ShowScrollbar
showScrollbarVal
  ScrolledWindow
scrolledWin <-
    forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsAdjustment a, IsAdjustment b) =>
Maybe a -> Maybe b -> m ScrolledWindow
scrolledWindowNew
      (forall a. Maybe a
Nothing :: Maybe Adjustment)
      (forall a. Maybe a
Nothing :: Maybe Adjustment)
  forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
widgetShow ScrolledWindow
scrolledWin
  forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsScrolledWindow a) =>
a -> PolicyType -> PolicyType -> m ()
scrolledWindowSetPolicy ScrolledWindow
scrolledWin PolicyType
PolicyTypeAutomatic PolicyType
vScrollbarPolicy
  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 <- forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Orientation -> Int32 -> m Box
boxNew Orientation
OrientationHorizontal Int32
5
  Label
label <- forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Maybe Text -> m Label
labelNew (forall a. a -> Maybe a
Just Text
"")
  forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsLabel a) =>
a -> EllipsizeMode -> m ()
labelSetEllipsize Label
label EllipsizeMode
EllipsizeModeMiddle
  forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsLabel a) =>
a -> Int32 -> m ()
labelSetMaxWidthChars Label
label Int32
10
  forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> Bool -> m ()
widgetSetHexpand Label
label Bool
True
  forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> Align -> m ()
widgetSetHalign Label
label Align
AlignFill
  Button
button <-
    forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Maybe Text -> Int32 -> m Button
buttonNewFromIconName
      (forall a. a -> Maybe a
Just Text
"window-close")
      (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Enum a => a -> Int
fromEnum IconSize
IconSizeMenu))
  forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsButton a) =>
a -> ReliefStyle -> m ()
buttonSetRelief Button
button ReliefStyle
ReliefStyleNone
  forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
containerAdd Box
box Label
label
  forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
containerAdd Box
box Button
button
  forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> Bool -> m ()
widgetSetCanFocus Button
button Bool
False
  forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> Bool -> m ()
widgetSetCanFocus Label
label Bool
False
  forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> Bool -> m ()
widgetSetCanFocus Box
box Bool
False
  forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
widgetShow Box
box
  forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
widgetShow Label
label
  forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
widgetShow Button
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 Notebook
note = do
  Int32
npages <- forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsNotebook a) =>
a -> m Int32
notebookGetNPages Notebook
note
  let shouldShowTabs :: Bool
shouldShowTabs =
        case TMConfig
tmConfig forall s a. s -> Getting a s a -> a
^. Lens' TMConfig ConfigOptions
lensOptions forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Lens' ConfigOptions ShowTabBar
lensShowTabBar of
          ShowTabBar
ShowTabBarIfNeeded -> Int32
npages forall a. Ord a => a -> a -> Bool
> Int32
1
          ShowTabBar
ShowTabBarAlways   -> Bool
True
          ShowTabBar
ShowTabBarNever    -> Bool
False
  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 Double
colour = do
  let RGB Double
red Double
green Double
blue = forall b. (Ord b, Floating b) => Colour b -> RGB b
toSRGB Colour Double
colour
  RGBA
rgba <- forall (m :: * -> *). MonadIO m => m RGBA
newZeroRGBA
  forall (m :: * -> *). MonadIO m => RGBA -> Double -> m ()
setRGBARed RGBA
rgba Double
red
  forall (m :: * -> *). MonadIO m => RGBA -> Double -> m ()
setRGBAGreen RGBA
rgba Double
green
  forall (m :: * -> *). MonadIO m => RGBA -> Double -> m ()
setRGBABlue RGBA
rgba Double
blue
  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 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
</> forall a. Show a => a -> String
show Int
pd String -> String -> String
</> String
"cwd"
  Either IOException String
eitherLinkTarget <- forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try forall a b. (a -> b) -> a -> b
$ String -> IO String
getSymbolicLinkTarget String
pidPath
  case Either IOException String
eitherLinkTarget of
    Left (IOException
_ :: IOException) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    Right String
linkTarget -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall seq. IsSequence seq => [Element seq] -> seq
pack String
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 = forall a. FocusList a -> Maybe a
getFocusItemFL (TMNotebook -> FocusList TMNotebookTab
tmNotebookTabs TMNotebook
currNote)
  case Maybe TMNotebookTab
maybeFocusedTab of
    Maybe TMNotebookTab
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure 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
  Terminal
vteTerm <- forall (m :: * -> *). (HasCallStack, MonadIO m) => m Terminal
terminalNew
  forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsTerminal a) =>
a -> Maybe FontDescription -> m ()
terminalSetFont Terminal
vteTerm (forall a. a -> Maybe a
Just FontDescription
tmStateFontDesc)
  forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsTerminal a) =>
a -> Text -> m ()
terminalSetWordCharExceptions Terminal
vteTerm forall a b. (a -> b) -> a -> b
$ ConfigOptions -> Text
wordCharExceptions ConfigOptions
curOpts
  forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsTerminal a) =>
a -> CLong -> m ()
terminalSetScrollbackLines Terminal
vteTerm (forall a b. (Integral a, Num b) => a -> b
fromIntegral (ConfigOptions -> Integer
scrollbackLen ConfigOptions
curOpts))
  forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsTerminal a) =>
a -> CursorBlinkMode -> m ()
terminalSetCursorBlinkMode Terminal
vteTerm (ConfigOptions -> CursorBlinkMode
cursorBlinkMode ConfigOptions
curOpts)
  forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsTerminal a) =>
a -> Bool -> m ()
terminalSetBoldIsBright Terminal
vteTerm (ConfigOptions -> Bool
boldIsBright ConfigOptions
curOpts)
  forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsTerminal a) =>
a -> Bool -> m ()
terminalSetEnableSixelIfExists Terminal
vteTerm (ConfigOptions -> Bool
enableSixel ConfigOptions
curOpts)
  forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsTerminal a) =>
a -> Bool -> m ()
terminalSetAllowBold Terminal
vteTerm (ConfigOptions -> Bool
allowBold ConfigOptions
curOpts)
  forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
widgetShow Terminal
vteTerm
  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 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.
  Maybe String
mShell <- String -> IO (Maybe String)
lookupEnv String
"SHELL"
  let argv :: [String]
argv = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [String
"/usr/bin/env", String
"bash"] forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
mShell
  -- Launch the shell
  Int32
shellPid <-
    forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsTerminal a, IsCancellable b) =>
a
-> [PtyFlags]
-> Maybe Text
-> [String]
-> Maybe [String]
-> [SpawnFlags]
-> Maybe (IO ())
-> Maybe b
-> m Int32
terminalSpawnSync
      Terminal
vteTerm
      [PtyFlags
PtyFlagsDefault]
      Maybe Text
maybeCurrDir
      [String]
argv
      forall a. Maybe a
Nothing
      ([SpawnFlags
SpawnFlagsDefault] :: [SpawnFlags])
      forall a. Maybe a
Nothing
      (forall a. Maybe a
Nothing :: Maybe Cancellable)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 TMState
mvarTMState TMNotebookTab
notebookTab Box
tabLabelBox = do
  -- Append a new notebook page and update the TMState to reflect this.
  (Notebook
note, Int32
pageIndex) <- 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.
  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 = 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 <- 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 (forall a. a -> Maybe a
Just Box
tabLabelBox)
      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 forall s a. s -> Getting a s a -> a
^. Lens' TMState' TMConfig
lensTMStateConfig) Notebook
note
      let newTabs :: FocusList TMNotebookTab
newTabs = forall a. FocusList a -> a -> FocusList a
appendFL FocusList TMNotebookTab
tabs TMNotebookTab
notebookTab
          newTMState :: TMState'
newTMState =
            TMState'
tmState forall a b. a -> (a -> b) -> b
& Lens' TMState' TMNotebook
lensTMStateNotebook forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Lens' TMNotebook (FocusList TMNotebookTab)
lensTMNotebookTabs forall s t a b. ASetter s t a b -> b -> s -> t
.~ FocusList TMNotebookTab
newTabs
      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 ApplicationWindow
tmStateAppWin Terminal
vteTerm = do
  forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
widgetGrabFocus Terminal
vteTerm
  forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsWindow a, IsWidget b) =>
a -> Maybe b -> m ()
windowSetFocus ApplicationWindow
tmStateAppWin (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{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} <-
    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
  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
  (Box
tabLabelBox, Label
tabLabel, 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
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *).
(IsButton a, MonadIO m) =>
a -> ((?self::a) => IO ()) -> m SignalHandlerId
onButtonClicked Button
tabCloseButton forall a b. (a -> b) -> a -> b
$ TMNotebookTab -> TMState -> IO ()
termClose TMNotebookTab
notebookTab TMState
mvarTMState
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *).
(IsTerminal a, MonadIO m) =>
a -> ((?self::a) => IO ()) -> m SignalHandlerId
onTerminalWindowTitleChanged Terminal
vteTerm forall a b. (a -> b) -> a -> b
$ do
    TMState{TMNotebook
tmStateNotebook :: TMNotebook
tmStateNotebook :: TMState' -> TMNotebook
tmStateNotebook} <- 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
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *).
(IsWidget a, MonadIO m) =>
a -> ((?self::a) => EventKey -> IO Bool) -> m SignalHandlerId
onWidgetKeyPressEvent Terminal
vteTerm forall a b. (a -> b) -> a -> b
$ TMState -> EventKey -> IO Bool
handleKeyPress TMState
mvarTMState
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *).
(IsWidget a, MonadIO m) =>
a -> ((?self::a) => EventKey -> IO Bool) -> m SignalHandlerId
onWidgetKeyPressEvent ScrolledWindow
scrolledWin forall a b. (a -> b) -> a -> b
$ TMState -> EventKey -> IO Bool
handleKeyPress TMState
mvarTMState
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *).
(IsWidget a, MonadIO m) =>
a
-> ((?self::a) => WidgetButtonPressEventCallback)
-> m SignalHandlerId
onWidgetButtonPressEvent Terminal
vteTerm forall a b. (a -> b) -> a -> b
$ ApplicationWindow -> Terminal -> WidgetButtonPressEventCallback
handleMousePress ApplicationWindow
tmStateAppWin Terminal
vteTerm
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *).
(IsTerminal a, MonadIO m) =>
a
-> ((?self::a) => TerminalChildExitedCallback) -> m SignalHandlerId
onTerminalChildExited Terminal
vteTerm forall a b. (a -> b) -> a -> b
$ \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
regexPat =
        Text
"(?:http(s)?:\\/\\/)[\\w.-]+(?:\\.[\\w\\.-]+)+[\\w\\-\\._~:/?#[\\]@!\\$&'\\(\\)\\*\\+,;=.]+"
  -- We must set the pcre2Multiline option, otherwise VTE prints a warning.
  let pcreFlags :: Word32
pcreFlags = forall a b. (Integral a, Num b) => a -> b
fromIntegral CUInt
pcre2Multiline
  Regex
regex <- forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Text -> Int64 -> Word32 -> m Regex
regexNewForMatch Text
regexPat (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall mono. MonoFoldable mono => mono -> Int
length Text
regexPat) Word32
pcreFlags
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsTerminal a) =>
a -> Regex -> Word32 -> m Int32
terminalMatchAddRegex Terminal
vteTerm Regex
regex Word32
0

  -- 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
  forall (f :: * -> *) a. Applicative f => a -> f a
pure TMTerm
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
  Bool
x <- forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsTerminal a) =>
a -> m Bool
terminalGetAllowHyperlink Terminal
vteTerm
  forall a (m :: * -> *). (Show a, MonadIO m) => a -> m ()
print Bool
x
  Word32
button <- forall (m :: * -> *). MonadIO m => EventButton -> m Word32
getEventButtonButton EventButton
eventButton
  let rightClick :: Bool
rightClick = Word32
button forall a. Eq a => a -> a -> Bool
== forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
BUTTON_SECONDARY
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
rightClick forall a b. (a -> b) -> a -> b
$ do
    Menu
menuModel <- forall (m :: * -> *). (HasCallStack, MonadIO m) => m Menu
menuNew

    -- if the user right-clicked on a URL, add an option to open the URL
    -- in a browser
    (Maybe Text
maybeUrl, Int32
_regexId) <- forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsTerminal a) =>
a -> Event -> m (Maybe Text, Int32)
terminalMatchCheckEvent Terminal
vteTerm (EventButton -> Event
eventButtonToEvent EventButton
eventButton)
    case Maybe Text
maybeUrl of
      Maybe Text
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just Text
url -> do
        SimpleAction
openUrlAction <- forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Text -> Maybe VariantType -> m SimpleAction
simpleActionNew Text
"openurl" forall a. Maybe a
Nothing
        forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *).
(IsSimpleAction a, MonadIO m) =>
a
-> ((?self::a) => SimpleActionActivateCallback)
-> m SignalHandlerId
onSimpleActionActivate SimpleAction
openUrlAction forall a b. (a -> b) -> a -> b
$ \Maybe GVariant
_ ->
          forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWindow a) =>
Maybe a -> Text -> Word32 -> m ()
showUriOnWindow (forall a. Maybe a
Nothing :: Maybe Window) Text
url (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.
        forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsActionMap a, IsAction b) =>
a -> b -> m ()
actionMapAddAction ApplicationWindow
win SimpleAction
openUrlAction
        forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsMenu a) =>
a -> Maybe Text -> Maybe Text -> m ()
menuAppend Menu
menuModel (forall a. a -> Maybe a
Just Text
"Open URL in browser") (forall a. a -> Maybe a
Just Text
"win.openurl")


    forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsMenu a) =>
a -> Maybe Text -> Maybe Text -> m ()
menuAppend Menu
menuModel (forall a. a -> Maybe a
Just Text
"Copy") (forall a. a -> Maybe a
Just Text
"app.copy")
    forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsMenu a) =>
a -> Maybe Text -> Maybe Text -> m ()
menuAppend Menu
menuModel (forall a. a -> Maybe a
Just Text
"Paste") (forall a. a -> Maybe a
Just Text
"app.paste")
    forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsMenu a) =>
a -> Maybe Text -> Maybe Text -> m ()
menuAppend Menu
menuModel (forall a. a -> Maybe a
Just Text
"Preferences") (forall a. a -> Maybe a
Just Text
"app.preferences")
    Menu
menu <- forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsMenuModel a) =>
a -> m Menu
menuNewFromModel Menu
menuModel
    forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsMenu a, IsWidget b) =>
a -> b -> Maybe MenuDetachFunc -> m ()
menuAttachToWidget Menu
menu Terminal
vteTerm forall a. Maybe a
Nothing
    forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsMenu a) =>
a -> Maybe Event -> m ()
menuPopupAtPointer Menu
menu forall a. Maybe a
Nothing
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
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 forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. coerce :: forall a b. Coercible a b => a -> b
coerce forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. ManagedPtrNewtype a => a -> ManagedPtr a
toManagedPtr