{-# OPTIONS_GHC -fno-warn-orphans #-}

module Termonad.Types where

import Termonad.Prelude

import Control.Monad.Fail (fail)
import Data.FocusList (FocusList, emptyFL, singletonFL, getFocusItemFL, lengthFL)
import Data.Unique (Unique, hashUnique, newUnique)
import Data.Yaml
  ( FromJSON(parseJSON)
  , ToJSON(toJSON)
  , Value(String)
  , withText
  )
import GI.Gtk
  ( Application
  , ApplicationWindow
  , IsWidget
  , Label
  , Notebook
  , ScrolledWindow
  , Widget
  , notebookGetCurrentPage
  , notebookGetNthPage
  , notebookGetNPages
  )
import GI.Pango (FontDescription)
import GI.Vte (Terminal, CursorBlinkMode(..))
import Text.Pretty.Simple (pPrint)
import Text.Show (ShowS, showParen, showString)

import Termonad.Gtk (widgetEq)

-- | A wrapper around a VTE 'Terminal'.  This also stores the process ID of the
-- process running on this terminal, as well as a 'Unique' that can be used for
-- comparing terminals.
data TMTerm = TMTerm
  { TMTerm -> Terminal
term :: !Terminal
    -- ^ The actual 'Terminal'.
  , TMTerm -> Int
pid :: !Int
    -- ^ The process ID of the process running in 'term'.
  , TMTerm -> Unique
unique :: !Unique
    -- ^ A 'Unique' for comparing different 'TMTerm' for uniqueness.
  }

instance Show TMTerm where
  showsPrec :: Int -> TMTerm -> ShowS
  showsPrec :: Int -> TMTerm -> ShowS
showsPrec Int
d TMTerm{Int
Unique
Terminal
unique :: Unique
pid :: Int
term :: Terminal
unique :: TMTerm -> Unique
pid :: TMTerm -> Int
term :: TMTerm -> Terminal
..} =
    Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
      String -> ShowS
showString String
"TMTerm {" ShowS -> ShowS -> ShowS
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
      String -> ShowS
showString String
"term = " ShowS -> ShowS -> ShowS
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
      String -> ShowS
showString String
"(GI.GTK.Terminal)" ShowS -> ShowS -> ShowS
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
      String -> ShowS
showString String
", " ShowS -> ShowS -> ShowS
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
      String -> ShowS
showString String
"pid = " ShowS -> ShowS -> ShowS
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
      Int -> Int -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
pid ShowS -> ShowS -> ShowS
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
      String -> ShowS
showString String
", " ShowS -> ShowS -> ShowS
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
      String -> ShowS
showString String
"unique = " ShowS -> ShowS -> ShowS
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
      Int -> Int -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Unique -> Int
hashUnique Unique
unique) ShowS -> ShowS -> ShowS
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
      String -> ShowS
showString String
"}"

-- | A container that holds everything in a given terminal window.  The 'term'
-- in the 'TMTerm' is inside the 'tmNotebookTabTermContainer' 'ScrolledWindow'.
-- The notebook tab 'Label' is also available.
data TMNotebookTab = TMNotebookTab
  { TMNotebookTab -> ScrolledWindow
tmNotebookTabTermContainer :: !ScrolledWindow
    -- ^ The 'ScrolledWindow' holding the VTE 'Terminal'.
  , TMNotebookTab -> TMTerm
tmNotebookTabTerm :: !TMTerm
    -- ^ The 'Terminal' insidie the 'ScrolledWindow'.
  , TMNotebookTab -> Label
tmNotebookTabLabel :: !Label
    -- ^ The 'Label' holding the title of the 'Terminal' in the 'Notebook' tab.
  }

instance Show TMNotebookTab where
  showsPrec :: Int -> TMNotebookTab -> ShowS
  showsPrec :: Int -> TMNotebookTab -> ShowS
showsPrec Int
d TMNotebookTab{ScrolledWindow
Label
TMTerm
tmNotebookTabLabel :: Label
tmNotebookTabTerm :: TMTerm
tmNotebookTabTermContainer :: ScrolledWindow
tmNotebookTabLabel :: TMNotebookTab -> Label
tmNotebookTabTerm :: TMNotebookTab -> TMTerm
tmNotebookTabTermContainer :: TMNotebookTab -> ScrolledWindow
..} =
    Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
      String -> ShowS
showString String
"TMNotebookTab {" ShowS -> ShowS -> ShowS
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
      String -> ShowS
showString String
"tmNotebookTabTermContainer = " ShowS -> ShowS -> ShowS
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
      String -> ShowS
showString String
"(GI.GTK.ScrolledWindow)" ShowS -> ShowS -> ShowS
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
      String -> ShowS
showString String
", " ShowS -> ShowS -> ShowS
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
      String -> ShowS
showString String
"tmNotebookTabTerm = " ShowS -> ShowS -> ShowS
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
      Int -> TMTerm -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) TMTerm
tmNotebookTabTerm ShowS -> ShowS -> ShowS
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
      String -> ShowS
showString String
", " ShowS -> ShowS -> ShowS
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
      String -> ShowS
showString String
"tmNotebookTabLabel = " ShowS -> ShowS -> ShowS
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
      String -> ShowS
showString String
"(GI.GTK.Label)" ShowS -> ShowS -> ShowS
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
      String -> ShowS
showString String
"}"

-- | This holds the GTK 'Notebook' containing multiple tabs of 'Terminal's.  We
-- keep a separate list of terminals in 'tmNotebookTabs'.
data TMNotebook = TMNotebook
  { TMNotebook -> Notebook
tmNotebook :: !Notebook
    -- ^ This is the GTK 'Notebook' that holds multiple tabs of 'Terminal's.
  , TMNotebook -> FocusList TMNotebookTab
tmNotebookTabs :: !(FocusList TMNotebookTab)
    -- ^ A 'FocusList' containing references to each individual 'TMNotebookTab'.
  }

instance Show TMNotebook where
  showsPrec :: Int -> TMNotebook -> ShowS
  showsPrec :: Int -> TMNotebook -> ShowS
showsPrec Int
d TMNotebook{FocusList TMNotebookTab
Notebook
tmNotebookTabs :: FocusList TMNotebookTab
tmNotebook :: Notebook
tmNotebookTabs :: TMNotebook -> FocusList TMNotebookTab
tmNotebook :: TMNotebook -> Notebook
..} =
    Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
      String -> ShowS
showString String
"TMNotebook {" ShowS -> ShowS -> ShowS
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
      String -> ShowS
showString String
"tmNotebook = " ShowS -> ShowS -> ShowS
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
      String -> ShowS
showString String
"(GI.GTK.Notebook)" ShowS -> ShowS -> ShowS
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
      String -> ShowS
showString String
", " ShowS -> ShowS -> ShowS
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
      String -> ShowS
showString String
"tmNotebookTabs = " ShowS -> ShowS -> ShowS
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
      Int -> FocusList TMNotebookTab -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) FocusList TMNotebookTab
tmNotebookTabs ShowS -> ShowS -> ShowS
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
      String -> ShowS
showString String
"}"

data TMState' = TMState
  { TMState' -> Application
tmStateApp :: !Application
  , TMState' -> ApplicationWindow
tmStateAppWin :: !ApplicationWindow
  , TMState' -> TMNotebook
tmStateNotebook :: !TMNotebook
  , TMState' -> FontDescription
tmStateFontDesc :: !FontDescription
  , TMState' -> TMConfig
tmStateConfig :: !TMConfig
  }

instance Show TMState' where
  showsPrec :: Int -> TMState' -> ShowS
  showsPrec :: Int -> TMState' -> ShowS
showsPrec Int
d TMState{ApplicationWindow
Application
FontDescription
TMConfig
TMNotebook
tmStateConfig :: TMConfig
tmStateFontDesc :: FontDescription
tmStateNotebook :: TMNotebook
tmStateAppWin :: ApplicationWindow
tmStateApp :: Application
tmStateConfig :: TMState' -> TMConfig
tmStateFontDesc :: TMState' -> FontDescription
tmStateNotebook :: TMState' -> TMNotebook
tmStateAppWin :: TMState' -> ApplicationWindow
tmStateApp :: TMState' -> Application
..} =
    Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
      String -> ShowS
showString String
"TMState {" ShowS -> ShowS -> ShowS
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
      String -> ShowS
showString String
"tmStateApp = " ShowS -> ShowS -> ShowS
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
      String -> ShowS
showString String
"(GI.GTK.Application)" ShowS -> ShowS -> ShowS
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
      String -> ShowS
showString String
", " ShowS -> ShowS -> ShowS
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
      String -> ShowS
showString String
"tmStateAppWin = " ShowS -> ShowS -> ShowS
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
      String -> ShowS
showString String
"(GI.GTK.ApplicationWindow)" ShowS -> ShowS -> ShowS
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
      String -> ShowS
showString String
", " ShowS -> ShowS -> ShowS
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
      String -> ShowS
showString String
"tmStateNotebook = " ShowS -> ShowS -> ShowS
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
      Int -> TMNotebook -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) TMNotebook
tmStateNotebook ShowS -> ShowS -> ShowS
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
      String -> ShowS
showString String
", " ShowS -> ShowS -> ShowS
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
      String -> ShowS
showString String
"tmStateFontDesc = " ShowS -> ShowS -> ShowS
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
      String -> ShowS
showString String
"(GI.Pango.FontDescription)" ShowS -> ShowS -> ShowS
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
      String -> ShowS
showString String
", " ShowS -> ShowS -> ShowS
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
      String -> ShowS
showString String
"tmStateConfig = " ShowS -> ShowS -> ShowS
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
      Int -> TMConfig -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) TMConfig
tmStateConfig ShowS -> ShowS -> ShowS
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
      String -> ShowS
showString String
"}"

type TMState = MVar TMState'

instance Eq TMTerm where
  (==) :: TMTerm -> TMTerm -> Bool
  == :: TMTerm -> TMTerm -> Bool
(==) = Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Unique -> Unique -> Bool)
-> (TMTerm -> Unique) -> TMTerm -> TMTerm -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (TMTerm -> Unique
unique :: TMTerm -> Unique)

instance Eq TMNotebookTab where
  (==) :: TMNotebookTab -> TMNotebookTab -> Bool
  == :: TMNotebookTab -> TMNotebookTab -> Bool
(==) = TMTerm -> TMTerm -> Bool
forall a. Eq a => a -> a -> Bool
(==) (TMTerm -> TMTerm -> Bool)
-> (TMNotebookTab -> TMTerm)
-> TMNotebookTab
-> TMNotebookTab
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` TMNotebookTab -> TMTerm
tmNotebookTabTerm

createTMTerm :: Terminal -> Int -> Unique -> TMTerm
createTMTerm :: Terminal -> Int -> Unique -> TMTerm
createTMTerm Terminal
trm Int
pd Unique
unq =
  TMTerm :: Terminal -> Int -> Unique -> TMTerm
TMTerm
    { term :: Terminal
term = Terminal
trm
    , pid :: Int
pid = Int
pd
    , unique :: Unique
unique = Unique
unq
    }

newTMTerm :: Terminal -> Int -> IO TMTerm
newTMTerm :: Terminal -> Int -> IO TMTerm
newTMTerm Terminal
trm Int
pd = Terminal -> Int -> Unique -> TMTerm
createTMTerm Terminal
trm Int
pd (Unique -> TMTerm) -> IO Unique -> IO TMTerm
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Unique
newUnique

getFocusedTermFromState :: TMState -> IO (Maybe Terminal)
getFocusedTermFromState :: TMState -> IO (Maybe Terminal)
getFocusedTermFromState TMState
mvarTMState =
  TMState -> (TMState' -> IO (Maybe Terminal)) -> IO (Maybe Terminal)
forall (m :: * -> *) a b.
MonadUnliftIO m =>
MVar a -> (a -> m b) -> m b
withMVar TMState
mvarTMState TMState' -> IO (Maybe Terminal)
go
  where
    go :: TMState' -> IO (Maybe Terminal)
    go :: TMState' -> IO (Maybe Terminal)
go TMState'
tmState = do
      let maybeNotebookTab :: Maybe TMNotebookTab
maybeNotebookTab =
            FocusList TMNotebookTab -> Maybe TMNotebookTab
forall a. FocusList a -> Maybe a
getFocusItemFL (FocusList TMNotebookTab -> Maybe TMNotebookTab)
-> FocusList TMNotebookTab -> Maybe TMNotebookTab
forall a b. (a -> b) -> a -> b
$ TMNotebook -> FocusList TMNotebookTab
tmNotebookTabs (TMNotebook -> FocusList TMNotebookTab)
-> TMNotebook -> FocusList TMNotebookTab
forall a b. (a -> b) -> a -> b
$ TMState' -> TMNotebook
tmStateNotebook TMState'
tmState
      Maybe Terminal -> IO (Maybe Terminal)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Terminal -> IO (Maybe Terminal))
-> Maybe Terminal -> IO (Maybe Terminal)
forall a b. (a -> b) -> a -> b
$ (TMNotebookTab -> Terminal)
-> Maybe TMNotebookTab -> Maybe Terminal
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TMTerm -> Terminal
term (TMTerm -> Terminal)
-> (TMNotebookTab -> TMTerm) -> TMNotebookTab -> Terminal
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. TMNotebookTab -> TMTerm
tmNotebookTabTerm) Maybe TMNotebookTab
maybeNotebookTab

createTMNotebookTab :: Label -> ScrolledWindow -> TMTerm -> TMNotebookTab
createTMNotebookTab :: Label -> ScrolledWindow -> TMTerm -> TMNotebookTab
createTMNotebookTab Label
tabLabel ScrolledWindow
scrollWin TMTerm
trm =
  TMNotebookTab :: ScrolledWindow -> TMTerm -> Label -> TMNotebookTab
TMNotebookTab
    { tmNotebookTabTermContainer :: ScrolledWindow
tmNotebookTabTermContainer = ScrolledWindow
scrollWin
    , tmNotebookTabTerm :: TMTerm
tmNotebookTabTerm = TMTerm
trm
    , tmNotebookTabLabel :: Label
tmNotebookTabLabel = Label
tabLabel
    }

createTMNotebook :: Notebook -> FocusList TMNotebookTab -> TMNotebook
createTMNotebook :: Notebook -> FocusList TMNotebookTab -> TMNotebook
createTMNotebook Notebook
note FocusList TMNotebookTab
tabs =
  TMNotebook :: Notebook -> FocusList TMNotebookTab -> TMNotebook
TMNotebook
    { tmNotebook :: Notebook
tmNotebook = Notebook
note
    , tmNotebookTabs :: FocusList TMNotebookTab
tmNotebookTabs = FocusList TMNotebookTab
tabs
    }

createEmptyTMNotebook :: Notebook -> TMNotebook
createEmptyTMNotebook :: Notebook -> TMNotebook
createEmptyTMNotebook Notebook
notebook = Notebook -> FocusList TMNotebookTab -> TMNotebook
createTMNotebook Notebook
notebook FocusList TMNotebookTab
forall a. FocusList a
emptyFL

notebookToList :: Notebook -> IO [Widget]
notebookToList :: Notebook -> IO [Widget]
notebookToList Notebook
notebook =
  Int32 -> [Widget] -> IO [Widget]
unfoldHelper Int32
0 []
  where unfoldHelper :: Int32 -> [Widget] -> IO [Widget]
        unfoldHelper :: Int32 -> [Widget] -> IO [Widget]
unfoldHelper Int32
index32 [Widget]
acc = do
          Maybe Widget
notePage <- Notebook -> Int32 -> IO (Maybe Widget)
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsNotebook a) =>
a -> Int32 -> m (Maybe Widget)
notebookGetNthPage Notebook
notebook Int32
index32
          case Maybe Widget
notePage of
            Maybe Widget
Nothing -> [Widget] -> IO [Widget]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Widget]
acc
            Just Widget
notePage' -> Int32 -> [Widget] -> IO [Widget]
unfoldHelper (Int32
index32 Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
1) ([Widget]
acc [Widget] -> [Widget] -> [Widget]
forall m. Monoid m => m -> m -> m
++ [Item [Widget]
Widget
notePage'])

newTMState :: TMConfig -> Application -> ApplicationWindow -> TMNotebook -> FontDescription -> IO TMState
newTMState :: TMConfig
-> Application
-> ApplicationWindow
-> TMNotebook
-> FontDescription
-> IO TMState
newTMState TMConfig
tmConfig Application
app ApplicationWindow
appWin TMNotebook
note FontDescription
fontDesc =
  TMState' -> IO TMState
forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar (TMState' -> IO TMState) -> TMState' -> IO TMState
forall a b. (a -> b) -> a -> b
$
    TMState :: Application
-> ApplicationWindow
-> TMNotebook
-> FontDescription
-> TMConfig
-> TMState'
TMState
      { tmStateApp :: Application
tmStateApp = Application
app
      , tmStateAppWin :: ApplicationWindow
tmStateAppWin = ApplicationWindow
appWin
      , tmStateNotebook :: TMNotebook
tmStateNotebook = TMNotebook
note
      , tmStateFontDesc :: FontDescription
tmStateFontDesc = FontDescription
fontDesc
      , tmStateConfig :: TMConfig
tmStateConfig = TMConfig
tmConfig
      }

newEmptyTMState :: TMConfig -> Application -> ApplicationWindow -> Notebook -> FontDescription -> IO TMState
newEmptyTMState :: TMConfig
-> Application
-> ApplicationWindow
-> Notebook
-> FontDescription
-> IO TMState
newEmptyTMState TMConfig
tmConfig Application
app ApplicationWindow
appWin Notebook
note FontDescription
fontDesc =
  TMState' -> IO TMState
forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar (TMState' -> IO TMState) -> TMState' -> IO TMState
forall a b. (a -> b) -> a -> b
$
    TMState :: Application
-> ApplicationWindow
-> TMNotebook
-> FontDescription
-> TMConfig
-> TMState'
TMState
      { tmStateApp :: Application
tmStateApp = Application
app
      , tmStateAppWin :: ApplicationWindow
tmStateAppWin = ApplicationWindow
appWin
      , tmStateNotebook :: TMNotebook
tmStateNotebook = Notebook -> TMNotebook
createEmptyTMNotebook Notebook
note
      , tmStateFontDesc :: FontDescription
tmStateFontDesc = FontDescription
fontDesc
      , tmStateConfig :: TMConfig
tmStateConfig = TMConfig
tmConfig
      }

newTMStateSingleTerm ::
     TMConfig
  -> Application
  -> ApplicationWindow
  -> Notebook
  -> Label
  -> ScrolledWindow
  -> Terminal
  -> Int
  -> FontDescription
  -> IO TMState
newTMStateSingleTerm :: TMConfig
-> Application
-> ApplicationWindow
-> Notebook
-> Label
-> ScrolledWindow
-> Terminal
-> Int
-> FontDescription
-> IO TMState
newTMStateSingleTerm TMConfig
tmConfig Application
app ApplicationWindow
appWin Notebook
note Label
label ScrolledWindow
scrollWin Terminal
trm Int
pd FontDescription
fontDesc = do
  TMTerm
tmTerm <- Terminal -> Int -> IO TMTerm
newTMTerm Terminal
trm Int
pd
  let tmNoteTab :: TMNotebookTab
tmNoteTab = Label -> ScrolledWindow -> TMTerm -> TMNotebookTab
createTMNotebookTab Label
label ScrolledWindow
scrollWin TMTerm
tmTerm
      tabs :: FocusList TMNotebookTab
tabs = TMNotebookTab -> FocusList TMNotebookTab
forall a. a -> FocusList a
singletonFL TMNotebookTab
tmNoteTab
      tmNote :: TMNotebook
tmNote = Notebook -> FocusList TMNotebookTab -> TMNotebook
createTMNotebook Notebook
note FocusList TMNotebookTab
tabs
  TMConfig
-> Application
-> ApplicationWindow
-> TMNotebook
-> FontDescription
-> IO TMState
newTMState TMConfig
tmConfig Application
app ApplicationWindow
appWin TMNotebook
tmNote FontDescription
fontDesc

traceShowMTMState :: TMState -> IO ()
traceShowMTMState :: TMState -> IO ()
traceShowMTMState TMState
mvarTMState = do
  TMState'
tmState <- TMState -> IO TMState'
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar TMState
mvarTMState
  TMState' -> IO ()
forall a (m :: * -> *). (Show a, MonadIO m) => a -> m ()
print TMState'
tmState

------------
-- Config --
------------

-- | The font size for the Termonad terminal.  There are two ways to set the
-- fontsize, corresponding to the two different ways to set the font size in
-- the Pango font rendering library.
--
-- If you're not sure which to use, try 'FontSizePoints' first and see how it
-- looks.  It should generally correspond to font sizes you are used to from
-- other applications.
data FontSize
  = FontSizePoints Int
    -- ^ This sets the font size based on \"points\".  The conversion between a
    -- point and an actual size depends on the system configuration and the
    -- output device.  The function 'GI.Pango.fontDescriptionSetSize' is used
    -- to set the font size.  See the documentation for that function for more
    -- info.
  | FontSizeUnits Double
    -- ^ This sets the font size based on \"device units\".  In general, this
    -- can be thought of as one pixel.  The function
    -- 'GI.Pango.fontDescriptionSetAbsoluteSize' is used to set the font size.
    -- See the documentation for that function for more info.
  deriving (FontSize -> FontSize -> Bool
(FontSize -> FontSize -> Bool)
-> (FontSize -> FontSize -> Bool) -> Eq FontSize
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FontSize -> FontSize -> Bool
$c/= :: FontSize -> FontSize -> Bool
== :: FontSize -> FontSize -> Bool
$c== :: FontSize -> FontSize -> Bool
Eq, Value -> Parser [FontSize]
Value -> Parser FontSize
(Value -> Parser FontSize)
-> (Value -> Parser [FontSize]) -> FromJSON FontSize
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [FontSize]
$cparseJSONList :: Value -> Parser [FontSize]
parseJSON :: Value -> Parser FontSize
$cparseJSON :: Value -> Parser FontSize
FromJSON, (forall x. FontSize -> Rep FontSize x)
-> (forall x. Rep FontSize x -> FontSize) -> Generic FontSize
forall x. Rep FontSize x -> FontSize
forall x. FontSize -> Rep FontSize x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep FontSize x -> FontSize
$cfrom :: forall x. FontSize -> Rep FontSize x
Generic, Int -> FontSize -> ShowS
[FontSize] -> ShowS
FontSize -> String
(Int -> FontSize -> ShowS)
-> (FontSize -> String) -> ([FontSize] -> ShowS) -> Show FontSize
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FontSize] -> ShowS
$cshowList :: [FontSize] -> ShowS
show :: FontSize -> String
$cshow :: FontSize -> String
showsPrec :: Int -> FontSize -> ShowS
$cshowsPrec :: Int -> FontSize -> ShowS
Show, [FontSize] -> Encoding
[FontSize] -> Value
FontSize -> Encoding
FontSize -> Value
(FontSize -> Value)
-> (FontSize -> Encoding)
-> ([FontSize] -> Value)
-> ([FontSize] -> Encoding)
-> ToJSON FontSize
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [FontSize] -> Encoding
$ctoEncodingList :: [FontSize] -> Encoding
toJSONList :: [FontSize] -> Value
$ctoJSONList :: [FontSize] -> Value
toEncoding :: FontSize -> Encoding
$ctoEncoding :: FontSize -> Encoding
toJSON :: FontSize -> Value
$ctoJSON :: FontSize -> Value
ToJSON)

-- | The default 'FontSize' used if not specified.
--
-- >>> defaultFontSize
-- FontSizePoints 12
defaultFontSize :: FontSize
defaultFontSize :: FontSize
defaultFontSize = Int -> FontSize
FontSizePoints Int
12

-- | Modify a 'FontSize' by adding some value.
--
-- >>> modFontSize 1 (FontSizePoints 13)
-- FontSizePoints 14
-- >>> modFontSize 1 (FontSizeUnits 9.0)
-- FontSizeUnits 10.0
--
-- You can reduce the font size by passing a negative value.
--
-- >>> modFontSize (-2) (FontSizePoints 13)
-- FontSizePoints 11
--
-- If you try to create a font size less than 1, then the old font size will be
-- used.
--
-- >>> modFontSize (-10) (FontSizePoints 5)
-- FontSizePoints 5
-- >>> modFontSize (-1) (FontSizeUnits 1.0)
-- FontSizeUnits 1.0
modFontSize :: Int -> FontSize -> FontSize
modFontSize :: Int -> FontSize -> FontSize
modFontSize Int
i (FontSizePoints Int
oldPoints) =
  let newPoints :: Int
newPoints = Int
oldPoints Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i
  in Int -> FontSize
FontSizePoints (Int -> FontSize) -> Int -> FontSize
forall a b. (a -> b) -> a -> b
$ if Int
newPoints Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 then Int
oldPoints else Int
newPoints
modFontSize Int
i (FontSizeUnits Double
oldUnits) =
  let newUnits :: Double
newUnits = Double
oldUnits Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i
  in Double -> FontSize
FontSizeUnits (Double -> FontSize) -> Double -> FontSize
forall a b. (a -> b) -> a -> b
$ if Double
newUnits Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
1 then Double
oldUnits else Double
newUnits

-- | Settings for the font to be used in Termonad.
data FontConfig = FontConfig
  { FontConfig -> Text
fontFamily :: !Text
    -- ^ The font family to use.  Example: @"DejaVu Sans Mono"@ or @"Source Code Pro"@
  , FontConfig -> FontSize
fontSize :: !FontSize
    -- ^ The font size.
  } deriving (FontConfig -> FontConfig -> Bool
(FontConfig -> FontConfig -> Bool)
-> (FontConfig -> FontConfig -> Bool) -> Eq FontConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FontConfig -> FontConfig -> Bool
$c/= :: FontConfig -> FontConfig -> Bool
== :: FontConfig -> FontConfig -> Bool
$c== :: FontConfig -> FontConfig -> Bool
Eq, Value -> Parser [FontConfig]
Value -> Parser FontConfig
(Value -> Parser FontConfig)
-> (Value -> Parser [FontConfig]) -> FromJSON FontConfig
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [FontConfig]
$cparseJSONList :: Value -> Parser [FontConfig]
parseJSON :: Value -> Parser FontConfig
$cparseJSON :: Value -> Parser FontConfig
FromJSON, (forall x. FontConfig -> Rep FontConfig x)
-> (forall x. Rep FontConfig x -> FontConfig) -> Generic FontConfig
forall x. Rep FontConfig x -> FontConfig
forall x. FontConfig -> Rep FontConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep FontConfig x -> FontConfig
$cfrom :: forall x. FontConfig -> Rep FontConfig x
Generic, Int -> FontConfig -> ShowS
[FontConfig] -> ShowS
FontConfig -> String
(Int -> FontConfig -> ShowS)
-> (FontConfig -> String)
-> ([FontConfig] -> ShowS)
-> Show FontConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FontConfig] -> ShowS
$cshowList :: [FontConfig] -> ShowS
show :: FontConfig -> String
$cshow :: FontConfig -> String
showsPrec :: Int -> FontConfig -> ShowS
$cshowsPrec :: Int -> FontConfig -> ShowS
Show, [FontConfig] -> Encoding
[FontConfig] -> Value
FontConfig -> Encoding
FontConfig -> Value
(FontConfig -> Value)
-> (FontConfig -> Encoding)
-> ([FontConfig] -> Value)
-> ([FontConfig] -> Encoding)
-> ToJSON FontConfig
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [FontConfig] -> Encoding
$ctoEncodingList :: [FontConfig] -> Encoding
toJSONList :: [FontConfig] -> Value
$ctoJSONList :: [FontConfig] -> Value
toEncoding :: FontConfig -> Encoding
$ctoEncoding :: FontConfig -> Encoding
toJSON :: FontConfig -> Value
$ctoJSON :: FontConfig -> Value
ToJSON)

-- | The default 'FontConfig' to use if not specified.
--
-- >>> defaultFontConfig == FontConfig {fontFamily = "Monospace", fontSize = defaultFontSize}
-- True
defaultFontConfig :: FontConfig
defaultFontConfig :: FontConfig
defaultFontConfig =
  FontConfig :: Text -> FontSize -> FontConfig
FontConfig
    { fontFamily :: Text
fontFamily = Text
"Monospace"
    , fontSize :: FontSize
fontSize = FontSize
defaultFontSize
    }

-- | This data type represents an option that can either be 'Set' or 'Unset'.
--
-- This data type is used in situations where leaving an option unset results
-- in a special state that is not representable by setting any specific value.
--
-- Examples of this include the 'cursorFgColour' and 'cursorBgColour' options
-- supplied by the 'ColourConfig' @ConfigExtension@.  By default,
-- 'cursorFgColour' and 'cursorBgColour' are both 'Unset'.  However, when
-- 'cursorBgColour' is 'Set', 'cursorFgColour' defaults to the color of the text
-- underneath.  There is no way to represent this by setting 'cursorFgColour'.
data Option a = Unset | Set !a
  deriving (Int -> Option a -> ShowS
[Option a] -> ShowS
Option a -> String
(Int -> Option a -> ShowS)
-> (Option a -> String) -> ([Option a] -> ShowS) -> Show (Option a)
forall a. Show a => Int -> Option a -> ShowS
forall a. Show a => [Option a] -> ShowS
forall a. Show a => Option a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Option a] -> ShowS
$cshowList :: forall a. Show a => [Option a] -> ShowS
show :: Option a -> String
$cshow :: forall a. Show a => Option a -> String
showsPrec :: Int -> Option a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Option a -> ShowS
Show, ReadPrec [Option a]
ReadPrec (Option a)
Int -> ReadS (Option a)
ReadS [Option a]
(Int -> ReadS (Option a))
-> ReadS [Option a]
-> ReadPrec (Option a)
-> ReadPrec [Option a]
-> Read (Option a)
forall a. Read a => ReadPrec [Option a]
forall a. Read a => ReadPrec (Option a)
forall a. Read a => Int -> ReadS (Option a)
forall a. Read a => ReadS [Option a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Option a]
$creadListPrec :: forall a. Read a => ReadPrec [Option a]
readPrec :: ReadPrec (Option a)
$creadPrec :: forall a. Read a => ReadPrec (Option a)
readList :: ReadS [Option a]
$creadList :: forall a. Read a => ReadS [Option a]
readsPrec :: Int -> ReadS (Option a)
$creadsPrec :: forall a. Read a => Int -> ReadS (Option a)
Read, Option a -> Option a -> Bool
(Option a -> Option a -> Bool)
-> (Option a -> Option a -> Bool) -> Eq (Option a)
forall a. Eq a => Option a -> Option a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Option a -> Option a -> Bool
$c/= :: forall a. Eq a => Option a -> Option a -> Bool
== :: Option a -> Option a -> Bool
$c== :: forall a. Eq a => Option a -> Option a -> Bool
Eq, Eq (Option a)
Eq (Option a)
-> (Option a -> Option a -> Ordering)
-> (Option a -> Option a -> Bool)
-> (Option a -> Option a -> Bool)
-> (Option a -> Option a -> Bool)
-> (Option a -> Option a -> Bool)
-> (Option a -> Option a -> Option a)
-> (Option a -> Option a -> Option a)
-> Ord (Option a)
Option a -> Option a -> Bool
Option a -> Option a -> Ordering
Option a -> Option a -> Option a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (Option a)
forall a. Ord a => Option a -> Option a -> Bool
forall a. Ord a => Option a -> Option a -> Ordering
forall a. Ord a => Option a -> Option a -> Option a
min :: Option a -> Option a -> Option a
$cmin :: forall a. Ord a => Option a -> Option a -> Option a
max :: Option a -> Option a -> Option a
$cmax :: forall a. Ord a => Option a -> Option a -> Option a
>= :: Option a -> Option a -> Bool
$c>= :: forall a. Ord a => Option a -> Option a -> Bool
> :: Option a -> Option a -> Bool
$c> :: forall a. Ord a => Option a -> Option a -> Bool
<= :: Option a -> Option a -> Bool
$c<= :: forall a. Ord a => Option a -> Option a -> Bool
< :: Option a -> Option a -> Bool
$c< :: forall a. Ord a => Option a -> Option a -> Bool
compare :: Option a -> Option a -> Ordering
$ccompare :: forall a. Ord a => Option a -> Option a -> Ordering
Ord, (forall a b. (a -> b) -> Option a -> Option b)
-> (forall a b. a -> Option b -> Option a) -> Functor Option
forall a b. a -> Option b -> Option a
forall a b. (a -> b) -> Option a -> Option b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Option b -> Option a
$c<$ :: forall a b. a -> Option b -> Option a
fmap :: forall a b. (a -> b) -> Option a -> Option b
$cfmap :: forall a b. (a -> b) -> Option a -> Option b
Functor, (forall m. Monoid m => Option m -> m)
-> (forall m a. Monoid m => (a -> m) -> Option a -> m)
-> (forall m a. Monoid m => (a -> m) -> Option a -> m)
-> (forall a b. (a -> b -> b) -> b -> Option a -> b)
-> (forall a b. (a -> b -> b) -> b -> Option a -> b)
-> (forall b a. (b -> a -> b) -> b -> Option a -> b)
-> (forall b a. (b -> a -> b) -> b -> Option a -> b)
-> (forall a. (a -> a -> a) -> Option a -> a)
-> (forall a. (a -> a -> a) -> Option a -> a)
-> (forall a. Option a -> [a])
-> (forall a. Option a -> Bool)
-> (forall a. Option a -> Int)
-> (forall a. Eq a => a -> Option a -> Bool)
-> (forall a. Ord a => Option a -> a)
-> (forall a. Ord a => Option a -> a)
-> (forall a. Num a => Option a -> a)
-> (forall a. Num a => Option a -> a)
-> Foldable Option
forall a. Eq a => a -> Option a -> Bool
forall a. Num a => Option a -> a
forall a. Ord a => Option a -> a
forall m. Monoid m => Option m -> m
forall a. Option a -> Bool
forall a. Option a -> Int
forall a. Option a -> [a]
forall a. (a -> a -> a) -> Option a -> a
forall m a. Monoid m => (a -> m) -> Option a -> m
forall b a. (b -> a -> b) -> b -> Option a -> b
forall a b. (a -> b -> b) -> b -> Option a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => Option a -> a
$cproduct :: forall a. Num a => Option a -> a
sum :: forall a. Num a => Option a -> a
$csum :: forall a. Num a => Option a -> a
minimum :: forall a. Ord a => Option a -> a
$cminimum :: forall a. Ord a => Option a -> a
maximum :: forall a. Ord a => Option a -> a
$cmaximum :: forall a. Ord a => Option a -> a
elem :: forall a. Eq a => a -> Option a -> Bool
$celem :: forall a. Eq a => a -> Option a -> Bool
length :: forall a. Option a -> Int
$clength :: forall a. Option a -> Int
null :: forall a. Option a -> Bool
$cnull :: forall a. Option a -> Bool
toList :: forall a. Option a -> [a]
$ctoList :: forall a. Option a -> [a]
foldl1 :: forall a. (a -> a -> a) -> Option a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Option a -> a
foldr1 :: forall a. (a -> a -> a) -> Option a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Option a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> Option a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Option a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Option a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Option a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Option a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Option a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Option a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Option a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> Option a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Option a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Option a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Option a -> m
fold :: forall m. Monoid m => Option m -> m
$cfold :: forall m. Monoid m => Option m -> m
Foldable)

-- | Run a function over the value contained in an 'Option'. Return 'mempty'
-- when 'Option' is 'Unset'.
--
-- >>> whenSet (Set [1,2,3]) (++ [4,5,6]) :: [Int]
-- [1,2,3,4,5,6]
-- >>> whenSet Unset (++ [4,5,6]) :: [Int]
-- []
whenSet :: Monoid m => Option a -> (a -> m) -> m
whenSet :: forall m a. Monoid m => Option a -> (a -> m) -> m
whenSet = \case
  Option a
Unset -> m -> (a -> m) -> m
forall a b. a -> b -> a
const m
forall a. Monoid a => a
mempty
  Set a
x -> \a -> m
f -> a -> m
f a
x

-- | Whether or not to show the scroll bar in a terminal.
data ShowScrollbar
  = ShowScrollbarNever -- ^ Never show the scroll bar, even if there are too
                       -- many lines on the terminal to show all at once.  You
                       -- should still be able to scroll with the mouse wheel.
  | ShowScrollbarAlways -- ^ Always show the scrollbar, even if it is not
                        -- needed.
  | ShowScrollbarIfNeeded -- ^ Only show the scrollbar if there are too many
                          -- lines on the terminal to show all at once.
  deriving (Int -> ShowScrollbar
ShowScrollbar -> Int
ShowScrollbar -> [ShowScrollbar]
ShowScrollbar -> ShowScrollbar
ShowScrollbar -> ShowScrollbar -> [ShowScrollbar]
ShowScrollbar -> ShowScrollbar -> ShowScrollbar -> [ShowScrollbar]
(ShowScrollbar -> ShowScrollbar)
-> (ShowScrollbar -> ShowScrollbar)
-> (Int -> ShowScrollbar)
-> (ShowScrollbar -> Int)
-> (ShowScrollbar -> [ShowScrollbar])
-> (ShowScrollbar -> ShowScrollbar -> [ShowScrollbar])
-> (ShowScrollbar -> ShowScrollbar -> [ShowScrollbar])
-> (ShowScrollbar
    -> ShowScrollbar -> ShowScrollbar -> [ShowScrollbar])
-> Enum ShowScrollbar
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: ShowScrollbar -> ShowScrollbar -> ShowScrollbar -> [ShowScrollbar]
$cenumFromThenTo :: ShowScrollbar -> ShowScrollbar -> ShowScrollbar -> [ShowScrollbar]
enumFromTo :: ShowScrollbar -> ShowScrollbar -> [ShowScrollbar]
$cenumFromTo :: ShowScrollbar -> ShowScrollbar -> [ShowScrollbar]
enumFromThen :: ShowScrollbar -> ShowScrollbar -> [ShowScrollbar]
$cenumFromThen :: ShowScrollbar -> ShowScrollbar -> [ShowScrollbar]
enumFrom :: ShowScrollbar -> [ShowScrollbar]
$cenumFrom :: ShowScrollbar -> [ShowScrollbar]
fromEnum :: ShowScrollbar -> Int
$cfromEnum :: ShowScrollbar -> Int
toEnum :: Int -> ShowScrollbar
$ctoEnum :: Int -> ShowScrollbar
pred :: ShowScrollbar -> ShowScrollbar
$cpred :: ShowScrollbar -> ShowScrollbar
succ :: ShowScrollbar -> ShowScrollbar
$csucc :: ShowScrollbar -> ShowScrollbar
Enum, ShowScrollbar -> ShowScrollbar -> Bool
(ShowScrollbar -> ShowScrollbar -> Bool)
-> (ShowScrollbar -> ShowScrollbar -> Bool) -> Eq ShowScrollbar
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ShowScrollbar -> ShowScrollbar -> Bool
$c/= :: ShowScrollbar -> ShowScrollbar -> Bool
== :: ShowScrollbar -> ShowScrollbar -> Bool
$c== :: ShowScrollbar -> ShowScrollbar -> Bool
Eq, (forall x. ShowScrollbar -> Rep ShowScrollbar x)
-> (forall x. Rep ShowScrollbar x -> ShowScrollbar)
-> Generic ShowScrollbar
forall x. Rep ShowScrollbar x -> ShowScrollbar
forall x. ShowScrollbar -> Rep ShowScrollbar x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ShowScrollbar x -> ShowScrollbar
$cfrom :: forall x. ShowScrollbar -> Rep ShowScrollbar x
Generic, Value -> Parser [ShowScrollbar]
Value -> Parser ShowScrollbar
(Value -> Parser ShowScrollbar)
-> (Value -> Parser [ShowScrollbar]) -> FromJSON ShowScrollbar
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [ShowScrollbar]
$cparseJSONList :: Value -> Parser [ShowScrollbar]
parseJSON :: Value -> Parser ShowScrollbar
$cparseJSON :: Value -> Parser ShowScrollbar
FromJSON, Int -> ShowScrollbar -> ShowS
[ShowScrollbar] -> ShowS
ShowScrollbar -> String
(Int -> ShowScrollbar -> ShowS)
-> (ShowScrollbar -> String)
-> ([ShowScrollbar] -> ShowS)
-> Show ShowScrollbar
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ShowScrollbar] -> ShowS
$cshowList :: [ShowScrollbar] -> ShowS
show :: ShowScrollbar -> String
$cshow :: ShowScrollbar -> String
showsPrec :: Int -> ShowScrollbar -> ShowS
$cshowsPrec :: Int -> ShowScrollbar -> ShowS
Show, [ShowScrollbar] -> Encoding
[ShowScrollbar] -> Value
ShowScrollbar -> Encoding
ShowScrollbar -> Value
(ShowScrollbar -> Value)
-> (ShowScrollbar -> Encoding)
-> ([ShowScrollbar] -> Value)
-> ([ShowScrollbar] -> Encoding)
-> ToJSON ShowScrollbar
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [ShowScrollbar] -> Encoding
$ctoEncodingList :: [ShowScrollbar] -> Encoding
toJSONList :: [ShowScrollbar] -> Value
$ctoJSONList :: [ShowScrollbar] -> Value
toEncoding :: ShowScrollbar -> Encoding
$ctoEncoding :: ShowScrollbar -> Encoding
toJSON :: ShowScrollbar -> Value
$ctoJSON :: ShowScrollbar -> Value
ToJSON)

-- | Whether or not to show the tab bar for switching tabs.
data ShowTabBar
  = ShowTabBarNever -- ^ Never show the tab bar, even if there are multiple tabs
                    -- open.  This may be confusing if you plan on using multiple tabs.
  | ShowTabBarAlways -- ^ Always show the tab bar, even if you only have one tab open.
  | ShowTabBarIfNeeded  -- ^ Only show the tab bar if you have multiple tabs open.
  deriving (Int -> ShowTabBar
ShowTabBar -> Int
ShowTabBar -> [ShowTabBar]
ShowTabBar -> ShowTabBar
ShowTabBar -> ShowTabBar -> [ShowTabBar]
ShowTabBar -> ShowTabBar -> ShowTabBar -> [ShowTabBar]
(ShowTabBar -> ShowTabBar)
-> (ShowTabBar -> ShowTabBar)
-> (Int -> ShowTabBar)
-> (ShowTabBar -> Int)
-> (ShowTabBar -> [ShowTabBar])
-> (ShowTabBar -> ShowTabBar -> [ShowTabBar])
-> (ShowTabBar -> ShowTabBar -> [ShowTabBar])
-> (ShowTabBar -> ShowTabBar -> ShowTabBar -> [ShowTabBar])
-> Enum ShowTabBar
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: ShowTabBar -> ShowTabBar -> ShowTabBar -> [ShowTabBar]
$cenumFromThenTo :: ShowTabBar -> ShowTabBar -> ShowTabBar -> [ShowTabBar]
enumFromTo :: ShowTabBar -> ShowTabBar -> [ShowTabBar]
$cenumFromTo :: ShowTabBar -> ShowTabBar -> [ShowTabBar]
enumFromThen :: ShowTabBar -> ShowTabBar -> [ShowTabBar]
$cenumFromThen :: ShowTabBar -> ShowTabBar -> [ShowTabBar]
enumFrom :: ShowTabBar -> [ShowTabBar]
$cenumFrom :: ShowTabBar -> [ShowTabBar]
fromEnum :: ShowTabBar -> Int
$cfromEnum :: ShowTabBar -> Int
toEnum :: Int -> ShowTabBar
$ctoEnum :: Int -> ShowTabBar
pred :: ShowTabBar -> ShowTabBar
$cpred :: ShowTabBar -> ShowTabBar
succ :: ShowTabBar -> ShowTabBar
$csucc :: ShowTabBar -> ShowTabBar
Enum, ShowTabBar -> ShowTabBar -> Bool
(ShowTabBar -> ShowTabBar -> Bool)
-> (ShowTabBar -> ShowTabBar -> Bool) -> Eq ShowTabBar
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ShowTabBar -> ShowTabBar -> Bool
$c/= :: ShowTabBar -> ShowTabBar -> Bool
== :: ShowTabBar -> ShowTabBar -> Bool
$c== :: ShowTabBar -> ShowTabBar -> Bool
Eq, (forall x. ShowTabBar -> Rep ShowTabBar x)
-> (forall x. Rep ShowTabBar x -> ShowTabBar) -> Generic ShowTabBar
forall x. Rep ShowTabBar x -> ShowTabBar
forall x. ShowTabBar -> Rep ShowTabBar x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ShowTabBar x -> ShowTabBar
$cfrom :: forall x. ShowTabBar -> Rep ShowTabBar x
Generic, Value -> Parser [ShowTabBar]
Value -> Parser ShowTabBar
(Value -> Parser ShowTabBar)
-> (Value -> Parser [ShowTabBar]) -> FromJSON ShowTabBar
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [ShowTabBar]
$cparseJSONList :: Value -> Parser [ShowTabBar]
parseJSON :: Value -> Parser ShowTabBar
$cparseJSON :: Value -> Parser ShowTabBar
FromJSON, Int -> ShowTabBar -> ShowS
[ShowTabBar] -> ShowS
ShowTabBar -> String
(Int -> ShowTabBar -> ShowS)
-> (ShowTabBar -> String)
-> ([ShowTabBar] -> ShowS)
-> Show ShowTabBar
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ShowTabBar] -> ShowS
$cshowList :: [ShowTabBar] -> ShowS
show :: ShowTabBar -> String
$cshow :: ShowTabBar -> String
showsPrec :: Int -> ShowTabBar -> ShowS
$cshowsPrec :: Int -> ShowTabBar -> ShowS
Show, [ShowTabBar] -> Encoding
[ShowTabBar] -> Value
ShowTabBar -> Encoding
ShowTabBar -> Value
(ShowTabBar -> Value)
-> (ShowTabBar -> Encoding)
-> ([ShowTabBar] -> Value)
-> ([ShowTabBar] -> Encoding)
-> ToJSON ShowTabBar
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [ShowTabBar] -> Encoding
$ctoEncodingList :: [ShowTabBar] -> Encoding
toJSONList :: [ShowTabBar] -> Value
$ctoJSONList :: [ShowTabBar] -> Value
toEncoding :: ShowTabBar -> Encoding
$ctoEncoding :: ShowTabBar -> Encoding
toJSON :: ShowTabBar -> Value
$ctoJSON :: ShowTabBar -> Value
ToJSON)

-- | Configuration options for Termonad.
--
-- See 'defaultConfigOptions' for the default values.
data ConfigOptions = ConfigOptions
  { ConfigOptions -> FontConfig
fontConfig :: !FontConfig
    -- ^ Specific options for fonts.
  , ConfigOptions -> ShowScrollbar
showScrollbar :: !ShowScrollbar
    -- ^ When to show the scroll bar.
  , ConfigOptions -> Integer
scrollbackLen :: !Integer
    -- ^ The number of lines to keep in the scroll back history for each terminal.
  , ConfigOptions -> Bool
confirmExit :: !Bool
    -- ^ Whether or not to ask you for confirmation when closing individual
    -- terminals or Termonad itself.  It is generally safer to keep this as
    -- 'True'.
  , ConfigOptions -> Text
wordCharExceptions :: !Text
    -- ^ When double-clicking on text in the terminal with the mouse, Termonad
    -- will use this value to determine what to highlight.  The individual
    -- characters in this list will be counted as part of a word.
    --
    -- For instance if 'wordCharExceptions' is @""@, then when you double-click
    -- on the text @http://@, only the @http@ portion will be highlighted.  If
    -- 'wordCharExceptions' is @":"@, then the @http:@ portion will be
    -- highlighted.
  , ConfigOptions -> Bool
showMenu :: !Bool
    -- ^ Whether or not to show the @File@ @Edit@ etc menu.
  , ConfigOptions -> ShowTabBar
showTabBar :: !ShowTabBar
    -- ^ When to show the tab bar.
  , ConfigOptions -> CursorBlinkMode
cursorBlinkMode :: !CursorBlinkMode
    -- ^ How to handle cursor blink.
  , ConfigOptions -> Bool
boldIsBright :: !Bool
    -- ^ This option controls whether or not to force bold text to use colors
    -- from the 'Termonad.Config.Colour.ExtendedPalatte'.
    --
    -- If 'True', then colored bold text will /always/ use colors from the
    -- 'Termonad.Config.Colour.ExtendedPalatte'.  There will be no way to print
    -- bold text colored with the 'Termonad.Config.Colour.BasicPalatte'.
    --
    -- This often isn't a big problem, since many TUI applications use
    -- bold in combination with colors from the 'Termonad.Config.Colour.ExtendedPalatte'.
    -- Also, the VTE default blue color can be difficult to read with a dark
    -- background, and enabling this can work around the problem.
    -- See <https://github.com/cdepillabout/termonad/issues/177> for more information.
    --
    -- If 'False', then bold can be applied separately to colors from both the
    -- 'Termonad.Config.Colour.BasicPalatte' and
    -- 'Termonad.Config.Colour.ExtendedPalatte'.
  , ConfigOptions -> Bool
enableSixel :: !Bool
    -- ^ Enable SIXEL to draw graphics in a terminal.
    --
    -- In order for this option to do anything, you need to be using a version
    -- of VTE >= 0.63, and compile VTE with SIXEL support.
    --
    -- Note that even if you do the above, there may still be some problems
    -- with SIXEL support in VTE. Follow
    -- <https://gitlab.gnome.org/GNOME/vte/-/issues/253> for more information.
  } deriving (ConfigOptions -> ConfigOptions -> Bool
(ConfigOptions -> ConfigOptions -> Bool)
-> (ConfigOptions -> ConfigOptions -> Bool) -> Eq ConfigOptions
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConfigOptions -> ConfigOptions -> Bool
$c/= :: ConfigOptions -> ConfigOptions -> Bool
== :: ConfigOptions -> ConfigOptions -> Bool
$c== :: ConfigOptions -> ConfigOptions -> Bool
Eq, (forall x. ConfigOptions -> Rep ConfigOptions x)
-> (forall x. Rep ConfigOptions x -> ConfigOptions)
-> Generic ConfigOptions
forall x. Rep ConfigOptions x -> ConfigOptions
forall x. ConfigOptions -> Rep ConfigOptions x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ConfigOptions x -> ConfigOptions
$cfrom :: forall x. ConfigOptions -> Rep ConfigOptions x
Generic, Value -> Parser [ConfigOptions]
Value -> Parser ConfigOptions
(Value -> Parser ConfigOptions)
-> (Value -> Parser [ConfigOptions]) -> FromJSON ConfigOptions
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [ConfigOptions]
$cparseJSONList :: Value -> Parser [ConfigOptions]
parseJSON :: Value -> Parser ConfigOptions
$cparseJSON :: Value -> Parser ConfigOptions
FromJSON, Int -> ConfigOptions -> ShowS
[ConfigOptions] -> ShowS
ConfigOptions -> String
(Int -> ConfigOptions -> ShowS)
-> (ConfigOptions -> String)
-> ([ConfigOptions] -> ShowS)
-> Show ConfigOptions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ConfigOptions] -> ShowS
$cshowList :: [ConfigOptions] -> ShowS
show :: ConfigOptions -> String
$cshow :: ConfigOptions -> String
showsPrec :: Int -> ConfigOptions -> ShowS
$cshowsPrec :: Int -> ConfigOptions -> ShowS
Show, [ConfigOptions] -> Encoding
[ConfigOptions] -> Value
ConfigOptions -> Encoding
ConfigOptions -> Value
(ConfigOptions -> Value)
-> (ConfigOptions -> Encoding)
-> ([ConfigOptions] -> Value)
-> ([ConfigOptions] -> Encoding)
-> ToJSON ConfigOptions
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [ConfigOptions] -> Encoding
$ctoEncodingList :: [ConfigOptions] -> Encoding
toJSONList :: [ConfigOptions] -> Value
$ctoJSONList :: [ConfigOptions] -> Value
toEncoding :: ConfigOptions -> Encoding
$ctoEncoding :: ConfigOptions -> Encoding
toJSON :: ConfigOptions -> Value
$ctoJSON :: ConfigOptions -> Value
ToJSON)

instance FromJSON CursorBlinkMode where
  parseJSON :: Value -> Parser CursorBlinkMode
parseJSON = String
-> (Text -> Parser CursorBlinkMode)
-> Value
-> Parser CursorBlinkMode
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"CursorBlinkMode" ((Text -> Parser CursorBlinkMode)
 -> Value -> Parser CursorBlinkMode)
-> (Text -> Parser CursorBlinkMode)
-> Value
-> Parser CursorBlinkMode
forall a b. (a -> b) -> a -> b
$ \Text
c -> do
    case (Text
c :: Text) of
      Text
"CursorBlinkModeSystem" -> CursorBlinkMode -> Parser CursorBlinkMode
forall (f :: * -> *) a. Applicative f => a -> f a
pure CursorBlinkMode
CursorBlinkModeSystem
      Text
"CursorBlinkModeOn" -> CursorBlinkMode -> Parser CursorBlinkMode
forall (f :: * -> *) a. Applicative f => a -> f a
pure CursorBlinkMode
CursorBlinkModeOn
      Text
"CursorBlinkModeOff" -> CursorBlinkMode -> Parser CursorBlinkMode
forall (f :: * -> *) a. Applicative f => a -> f a
pure CursorBlinkMode
CursorBlinkModeOff
      Text
_ -> String -> Parser CursorBlinkMode
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Wrong value for CursorBlinkMode"

instance ToJSON CursorBlinkMode where
  toJSON :: CursorBlinkMode -> Value
toJSON CursorBlinkMode
CursorBlinkModeSystem = Text -> Value
String Text
"CursorBlinkModeSystem"
  toJSON CursorBlinkMode
CursorBlinkModeOn = Text -> Value
String Text
"CursorBlinkModeOn"
  toJSON CursorBlinkMode
CursorBlinkModeOff = Text -> Value
String Text
"CursorBlinkModeOff"
  -- Not supposed to happened fall back to system
  toJSON (AnotherCursorBlinkMode Int
_) = Text -> Value
String Text
"CursorBlinkModeSystem"

-- | The default 'ConfigOptions'.
--
-- >>> :{
--   let defConfOpt =
--         ConfigOptions
--           { fontConfig = defaultFontConfig
--           , showScrollbar = ShowScrollbarIfNeeded
--           , scrollbackLen = 10000
--           , confirmExit = True
--           , wordCharExceptions = "-#%&+,./=?@\\_~\183:"
--           , showMenu = True
--           , showTabBar = ShowTabBarIfNeeded
--           , cursorBlinkMode = CursorBlinkModeOn
--           , boldIsBright = False
--           , enableSixel = False
--           }
--   in defaultConfigOptions == defConfOpt
-- :}
-- True
defaultConfigOptions :: ConfigOptions
defaultConfigOptions :: ConfigOptions
defaultConfigOptions =
  ConfigOptions :: FontConfig
-> ShowScrollbar
-> Integer
-> Bool
-> Text
-> Bool
-> ShowTabBar
-> CursorBlinkMode
-> Bool
-> Bool
-> ConfigOptions
ConfigOptions
    { fontConfig :: FontConfig
fontConfig = FontConfig
defaultFontConfig
    , showScrollbar :: ShowScrollbar
showScrollbar = ShowScrollbar
ShowScrollbarIfNeeded
    , scrollbackLen :: Integer
scrollbackLen = Integer
10000
    , confirmExit :: Bool
confirmExit = Bool
True
    , wordCharExceptions :: Text
wordCharExceptions = Text
"-#%&+,./=?@\\_~\183:"
    , showMenu :: Bool
showMenu = Bool
True
    , showTabBar :: ShowTabBar
showTabBar = ShowTabBar
ShowTabBarIfNeeded
    , cursorBlinkMode :: CursorBlinkMode
cursorBlinkMode = CursorBlinkMode
CursorBlinkModeOn
    , boldIsBright :: Bool
boldIsBright = Bool
False
    , enableSixel :: Bool
enableSixel = Bool
False
    }

-- | The Termonad 'ConfigOptions' along with the 'ConfigHooks'.
data TMConfig = TMConfig
  { TMConfig -> ConfigOptions
options :: !ConfigOptions
  , TMConfig -> ConfigHooks
hooks :: !ConfigHooks
  } deriving Int -> TMConfig -> ShowS
[TMConfig] -> ShowS
TMConfig -> String
(Int -> TMConfig -> ShowS)
-> (TMConfig -> String) -> ([TMConfig] -> ShowS) -> Show TMConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TMConfig] -> ShowS
$cshowList :: [TMConfig] -> ShowS
show :: TMConfig -> String
$cshow :: TMConfig -> String
showsPrec :: Int -> TMConfig -> ShowS
$cshowsPrec :: Int -> TMConfig -> ShowS
Show

-- | The default 'TMConfig'.
--
-- 'options' is 'defaultConfigOptions' and 'hooks' is 'defaultConfigHooks'.
defaultTMConfig :: TMConfig
defaultTMConfig :: TMConfig
defaultTMConfig =
  TMConfig :: ConfigOptions -> ConfigHooks -> TMConfig
TMConfig
    { options :: ConfigOptions
options = ConfigOptions
defaultConfigOptions
    , hooks :: ConfigHooks
hooks = ConfigHooks
defaultConfigHooks
    }

---------------------
-- ConfigHooks --
---------------------

-- | Hooks into certain termonad operations and VTE events. Used to modify
-- termonad's behaviour in order to implement new functionality. Fields should
-- have sane @Semigroup@ and @Monoid@ instances so that config extensions can
-- be combined uniformly and new hooks can be added without incident.
newtype ConfigHooks = ConfigHooks {
  -- | Produce an IO action to run on creation of new @Terminal@, given @TMState@
  -- and the @Terminal@ in question.
  ConfigHooks -> TMState -> Terminal -> IO ()
createTermHook :: TMState -> Terminal -> IO ()
}

instance Show ConfigHooks where
  showsPrec :: Int -> ConfigHooks -> ShowS
  showsPrec :: Int -> ConfigHooks -> ShowS
showsPrec Int
_ ConfigHooks
_ =
    String -> ShowS
showString String
"ConfigHooks {" ShowS -> ShowS -> ShowS
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
    String -> ShowS
showString String
"createTermHook = <function>" ShowS -> ShowS -> ShowS
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
    String -> ShowS
showString String
"}"

-- | Default values for the 'ConfigHooks'.
--
-- - The default function for 'createTermHook' is 'defaultCreateTermHook'.
defaultConfigHooks :: ConfigHooks
defaultConfigHooks :: ConfigHooks
defaultConfigHooks =
  ConfigHooks :: (TMState -> Terminal -> IO ()) -> ConfigHooks
ConfigHooks
    { createTermHook :: TMState -> Terminal -> IO ()
createTermHook = TMState -> Terminal -> IO ()
defaultCreateTermHook
    }

-- | Default value for 'createTermHook'.  Does nothing.
defaultCreateTermHook :: TMState -> Terminal -> IO ()
defaultCreateTermHook :: TMState -> Terminal -> IO ()
defaultCreateTermHook TMState
_ Terminal
_ = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

----------------
-- Invariants --
----------------

data FocusNotSameErr
  = FocusListFocusExistsButNoNotebookTabWidget
  | NotebookTabWidgetDiffersFromFocusListFocus
  | NotebookTabWidgetExistsButNoFocusListFocus
  deriving Int -> FocusNotSameErr -> ShowS
[FocusNotSameErr] -> ShowS
FocusNotSameErr -> String
(Int -> FocusNotSameErr -> ShowS)
-> (FocusNotSameErr -> String)
-> ([FocusNotSameErr] -> ShowS)
-> Show FocusNotSameErr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FocusNotSameErr] -> ShowS
$cshowList :: [FocusNotSameErr] -> ShowS
show :: FocusNotSameErr -> String
$cshow :: FocusNotSameErr -> String
showsPrec :: Int -> FocusNotSameErr -> ShowS
$cshowsPrec :: Int -> FocusNotSameErr -> ShowS
Show

data TabsDoNotMatch
  = TabLengthsDifferent Int Int -- ^ The first 'Int' is the number of tabs in the
                                -- actual GTK 'Notebook'.  The second 'Int' is
                                -- the number of tabs in the 'FocusList'.
  | TabAtIndexDifferent Int     -- ^ The tab at index 'Int' is different between
                                -- the actual GTK 'Notebook' and the 'FocusList'.
  deriving (Int -> TabsDoNotMatch -> ShowS
[TabsDoNotMatch] -> ShowS
TabsDoNotMatch -> String
(Int -> TabsDoNotMatch -> ShowS)
-> (TabsDoNotMatch -> String)
-> ([TabsDoNotMatch] -> ShowS)
-> Show TabsDoNotMatch
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TabsDoNotMatch] -> ShowS
$cshowList :: [TabsDoNotMatch] -> ShowS
show :: TabsDoNotMatch -> String
$cshow :: TabsDoNotMatch -> String
showsPrec :: Int -> TabsDoNotMatch -> ShowS
$cshowsPrec :: Int -> TabsDoNotMatch -> ShowS
Show)

data TMStateInvariantErr
  = FocusNotSame FocusNotSameErr Int
  | TabsDoNotMatch TabsDoNotMatch
  deriving Int -> TMStateInvariantErr -> ShowS
[TMStateInvariantErr] -> ShowS
TMStateInvariantErr -> String
(Int -> TMStateInvariantErr -> ShowS)
-> (TMStateInvariantErr -> String)
-> ([TMStateInvariantErr] -> ShowS)
-> Show TMStateInvariantErr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TMStateInvariantErr] -> ShowS
$cshowList :: [TMStateInvariantErr] -> ShowS
show :: TMStateInvariantErr -> String
$cshow :: TMStateInvariantErr -> String
showsPrec :: Int -> TMStateInvariantErr -> ShowS
$cshowsPrec :: Int -> TMStateInvariantErr -> ShowS
Show

-- | Gather up the invariants for 'TMState' and return them as a list.
--
-- If no invariants have been violated, then this function should return an
-- empty list.
invariantTMState' :: TMState' -> IO [TMStateInvariantErr]
invariantTMState' :: TMState' -> IO [TMStateInvariantErr]
invariantTMState' TMState'
tmState =
  [IO (Maybe TMStateInvariantErr)] -> IO [TMStateInvariantErr]
runInvariants
    [ IO (Maybe TMStateInvariantErr)
Item [IO (Maybe TMStateInvariantErr)]
invariantFocusSame
    , IO (Maybe TMStateInvariantErr)
Item [IO (Maybe TMStateInvariantErr)]
invariantTMTabLength
    , IO (Maybe TMStateInvariantErr)
Item [IO (Maybe TMStateInvariantErr)]
invariantTabsAllMatch
    ]
  where
    runInvariants :: [IO (Maybe TMStateInvariantErr)] -> IO [TMStateInvariantErr]
    runInvariants :: [IO (Maybe TMStateInvariantErr)] -> IO [TMStateInvariantErr]
runInvariants = ([Maybe TMStateInvariantErr] -> [TMStateInvariantErr])
-> IO [Maybe TMStateInvariantErr] -> IO [TMStateInvariantErr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe TMStateInvariantErr] -> [TMStateInvariantErr]
forall (f :: * -> *) t.
(IsSequence (f (Maybe t)), Functor f,
 Element (f (Maybe t)) ~ Maybe t) =>
f (Maybe t) -> f t
catMaybes (IO [Maybe TMStateInvariantErr] -> IO [TMStateInvariantErr])
-> ([IO (Maybe TMStateInvariantErr)]
    -> IO [Maybe TMStateInvariantErr])
-> [IO (Maybe TMStateInvariantErr)]
-> IO [TMStateInvariantErr]
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [IO (Maybe TMStateInvariantErr)] -> IO [Maybe TMStateInvariantErr]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence

    invariantFocusSame :: IO (Maybe TMStateInvariantErr)
    invariantFocusSame :: IO (Maybe TMStateInvariantErr)
invariantFocusSame = do
      let tmNote :: Notebook
tmNote = TMNotebook -> Notebook
tmNotebook (TMNotebook -> Notebook) -> TMNotebook -> Notebook
forall a b. (a -> b) -> a -> b
$ TMState' -> TMNotebook
tmStateNotebook TMState'
tmState
      Int32
index32 <- Notebook -> IO Int32
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsNotebook a) =>
a -> m Int32
notebookGetCurrentPage Notebook
tmNote
      Maybe Widget
maybeWidgetFromNote <- Notebook -> Int32 -> IO (Maybe Widget)
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsNotebook a) =>
a -> Int32 -> m (Maybe Widget)
notebookGetNthPage Notebook
tmNote Int32
index32
      let focusList :: FocusList TMNotebookTab
focusList = TMNotebook -> FocusList TMNotebookTab
tmNotebookTabs (TMNotebook -> FocusList TMNotebookTab)
-> TMNotebook -> FocusList TMNotebookTab
forall a b. (a -> b) -> a -> b
$ TMState' -> TMNotebook
tmStateNotebook TMState'
tmState
          maybeScrollWinFromFL :: Maybe ScrolledWindow
maybeScrollWinFromFL =
            TMNotebookTab -> ScrolledWindow
tmNotebookTabTermContainer (TMNotebookTab -> ScrolledWindow)
-> Maybe TMNotebookTab -> Maybe ScrolledWindow
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FocusList TMNotebookTab -> Maybe TMNotebookTab
forall a. FocusList a -> Maybe a
getFocusItemFL FocusList TMNotebookTab
focusList
          idx :: Int
idx = Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
index32
      case (Maybe Widget
maybeWidgetFromNote, Maybe ScrolledWindow
maybeScrollWinFromFL) of
        (Maybe Widget
Nothing, Maybe ScrolledWindow
Nothing) -> Maybe TMStateInvariantErr -> IO (Maybe TMStateInvariantErr)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe TMStateInvariantErr
forall a. Maybe a
Nothing
        (Just Widget
_, Maybe ScrolledWindow
Nothing) ->
          Maybe TMStateInvariantErr -> IO (Maybe TMStateInvariantErr)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe TMStateInvariantErr -> IO (Maybe TMStateInvariantErr))
-> Maybe TMStateInvariantErr -> IO (Maybe TMStateInvariantErr)
forall a b. (a -> b) -> a -> b
$
            TMStateInvariantErr -> Maybe TMStateInvariantErr
forall a. a -> Maybe a
Just (TMStateInvariantErr -> Maybe TMStateInvariantErr)
-> TMStateInvariantErr -> Maybe TMStateInvariantErr
forall a b. (a -> b) -> a -> b
$
              FocusNotSameErr -> Int -> TMStateInvariantErr
FocusNotSame FocusNotSameErr
NotebookTabWidgetExistsButNoFocusListFocus Int
idx
        (Maybe Widget
Nothing, Just ScrolledWindow
_) ->
          Maybe TMStateInvariantErr -> IO (Maybe TMStateInvariantErr)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe TMStateInvariantErr -> IO (Maybe TMStateInvariantErr))
-> Maybe TMStateInvariantErr -> IO (Maybe TMStateInvariantErr)
forall a b. (a -> b) -> a -> b
$
            TMStateInvariantErr -> Maybe TMStateInvariantErr
forall a. a -> Maybe a
Just (TMStateInvariantErr -> Maybe TMStateInvariantErr)
-> TMStateInvariantErr -> Maybe TMStateInvariantErr
forall a b. (a -> b) -> a -> b
$
              FocusNotSameErr -> Int -> TMStateInvariantErr
FocusNotSame FocusNotSameErr
FocusListFocusExistsButNoNotebookTabWidget Int
idx
        (Just Widget
widgetFromNote, Just ScrolledWindow
scrollWinFromFL) -> do
          Bool
isEq <- Widget -> ScrolledWindow -> IO Bool
forall (m :: * -> *) a b.
(MonadIO m, IsWidget a, IsWidget b) =>
a -> b -> m Bool
widgetEq Widget
widgetFromNote ScrolledWindow
scrollWinFromFL
          if Bool
isEq
            then Maybe TMStateInvariantErr -> IO (Maybe TMStateInvariantErr)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe TMStateInvariantErr
forall a. Maybe a
Nothing
            else
              Maybe TMStateInvariantErr -> IO (Maybe TMStateInvariantErr)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe TMStateInvariantErr -> IO (Maybe TMStateInvariantErr))
-> Maybe TMStateInvariantErr -> IO (Maybe TMStateInvariantErr)
forall a b. (a -> b) -> a -> b
$
                TMStateInvariantErr -> Maybe TMStateInvariantErr
forall a. a -> Maybe a
Just (TMStateInvariantErr -> Maybe TMStateInvariantErr)
-> TMStateInvariantErr -> Maybe TMStateInvariantErr
forall a b. (a -> b) -> a -> b
$
                  FocusNotSameErr -> Int -> TMStateInvariantErr
FocusNotSame FocusNotSameErr
NotebookTabWidgetDiffersFromFocusListFocus Int
idx

    invariantTMTabLength :: IO (Maybe TMStateInvariantErr)
    invariantTMTabLength :: IO (Maybe TMStateInvariantErr)
invariantTMTabLength = do
      let tmNote :: Notebook
tmNote = TMNotebook -> Notebook
tmNotebook (TMNotebook -> Notebook) -> TMNotebook -> Notebook
forall a b. (a -> b) -> a -> b
$ TMState' -> TMNotebook
tmStateNotebook TMState'
tmState
      Int32
noteLength32 <- Notebook -> IO Int32
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsNotebook a) =>
a -> m Int32
notebookGetNPages Notebook
tmNote
      let noteLength :: Int
noteLength = Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
noteLength32
          focusListLength :: Int
focusListLength = FocusList TMNotebookTab -> Int
forall a. FocusList a -> Int
lengthFL (FocusList TMNotebookTab -> Int) -> FocusList TMNotebookTab -> Int
forall a b. (a -> b) -> a -> b
$ TMNotebook -> FocusList TMNotebookTab
tmNotebookTabs (TMNotebook -> FocusList TMNotebookTab)
-> TMNotebook -> FocusList TMNotebookTab
forall a b. (a -> b) -> a -> b
$ TMState' -> TMNotebook
tmStateNotebook TMState'
tmState
          lengthEqual :: Bool
lengthEqual = Int
focusListLength Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
noteLength
      if Bool
lengthEqual
        then Maybe TMStateInvariantErr -> IO (Maybe TMStateInvariantErr)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe TMStateInvariantErr
forall a. Maybe a
Nothing
        else  Maybe TMStateInvariantErr -> IO (Maybe TMStateInvariantErr)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe TMStateInvariantErr -> IO (Maybe TMStateInvariantErr))
-> Maybe TMStateInvariantErr -> IO (Maybe TMStateInvariantErr)
forall a b. (a -> b) -> a -> b
$
               TMStateInvariantErr -> Maybe TMStateInvariantErr
forall a. a -> Maybe a
Just (TMStateInvariantErr -> Maybe TMStateInvariantErr)
-> TMStateInvariantErr -> Maybe TMStateInvariantErr
forall a b. (a -> b) -> a -> b
$
                TabsDoNotMatch -> TMStateInvariantErr
TabsDoNotMatch (TabsDoNotMatch -> TMStateInvariantErr)
-> TabsDoNotMatch -> TMStateInvariantErr
forall a b. (a -> b) -> a -> b
$
                 Int -> Int -> TabsDoNotMatch
TabLengthsDifferent Int
noteLength Int
focusListLength

    -- Turns a FocusList and Notebook into two lists of widgets and compares each widget for equality
    invariantTabsAllMatch :: IO (Maybe TMStateInvariantErr)
    invariantTabsAllMatch :: IO (Maybe TMStateInvariantErr)
invariantTabsAllMatch = do
      let tmNote :: Notebook
tmNote = TMNotebook -> Notebook
tmNotebook (TMNotebook -> Notebook) -> TMNotebook -> Notebook
forall a b. (a -> b) -> a -> b
$ TMState' -> TMNotebook
tmStateNotebook TMState'
tmState
          focusList :: FocusList TMNotebookTab
focusList = TMNotebook -> FocusList TMNotebookTab
tmNotebookTabs (TMNotebook -> FocusList TMNotebookTab)
-> TMNotebook -> FocusList TMNotebookTab
forall a b. (a -> b) -> a -> b
$ TMState' -> TMNotebook
tmStateNotebook TMState'
tmState
          flList :: [ScrolledWindow]
flList = TMNotebookTab -> ScrolledWindow
tmNotebookTabTermContainer (TMNotebookTab -> ScrolledWindow)
-> [TMNotebookTab] -> [ScrolledWindow]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FocusList TMNotebookTab -> [Element (FocusList TMNotebookTab)]
forall mono. MonoFoldable mono => mono -> [Element mono]
toList FocusList TMNotebookTab
focusList
      [Widget]
noteList <- Notebook -> IO [Widget]
notebookToList Notebook
tmNote
      [Widget] -> [ScrolledWindow] -> IO (Maybe TMStateInvariantErr)
forall a b.
(IsWidget a, IsWidget b) =>
[a] -> [b] -> IO (Maybe TMStateInvariantErr)
tabsMatch [Widget]
noteList [ScrolledWindow]
flList
      where
        tabsMatch
          :: forall a b
           . (IsWidget a, IsWidget b)
          => [a]
          -> [b]
          -> IO (Maybe TMStateInvariantErr)
        tabsMatch :: forall a b.
(IsWidget a, IsWidget b) =>
[a] -> [b] -> IO (Maybe TMStateInvariantErr)
tabsMatch [a]
xs [b]
ys = (Element [(a, b, Int)]
 -> IO (Maybe TMStateInvariantErr)
 -> IO (Maybe TMStateInvariantErr))
-> IO (Maybe TMStateInvariantErr)
-> [(a, b, Int)]
-> IO (Maybe TMStateInvariantErr)
forall mono b.
MonoFoldable mono =>
(Element mono -> b -> b) -> b -> mono -> b
foldr (a, b, Int)
-> IO (Maybe TMStateInvariantErr) -> IO (Maybe TMStateInvariantErr)
Element [(a, b, Int)]
-> IO (Maybe TMStateInvariantErr) -> IO (Maybe TMStateInvariantErr)
go (Maybe TMStateInvariantErr -> IO (Maybe TMStateInvariantErr)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe TMStateInvariantErr
forall a. Maybe a
Nothing) ([a] -> [b] -> [Int] -> [(a, b, Int)]
forall (f :: * -> *) a b c.
Zip3 f =>
f a -> f b -> f c -> f (a, b, c)
zip3 [a]
xs [b]
ys [Item [Int]
0..])
          where
            go :: (a, b, Int) -> IO (Maybe TMStateInvariantErr) -> IO (Maybe TMStateInvariantErr)
            go :: (a, b, Int)
-> IO (Maybe TMStateInvariantErr) -> IO (Maybe TMStateInvariantErr)
go (a
x, b
y, Int
i) IO (Maybe TMStateInvariantErr)
acc = do
              Bool
isEq <- a -> b -> IO Bool
forall (m :: * -> *) a b.
(MonadIO m, IsWidget a, IsWidget b) =>
a -> b -> m Bool
widgetEq a
x b
y
              if Bool
isEq
                then IO (Maybe TMStateInvariantErr)
acc
                else Maybe TMStateInvariantErr -> IO (Maybe TMStateInvariantErr)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe TMStateInvariantErr -> IO (Maybe TMStateInvariantErr))
-> (TMStateInvariantErr -> Maybe TMStateInvariantErr)
-> TMStateInvariantErr
-> IO (Maybe TMStateInvariantErr)
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. TMStateInvariantErr -> Maybe TMStateInvariantErr
forall a. a -> Maybe a
Just (TMStateInvariantErr -> IO (Maybe TMStateInvariantErr))
-> TMStateInvariantErr -> IO (Maybe TMStateInvariantErr)
forall a b. (a -> b) -> a -> b
$ TabsDoNotMatch -> TMStateInvariantErr
TabsDoNotMatch (Int -> TabsDoNotMatch
TabAtIndexDifferent Int
i)

-- | Check the invariants for 'TMState', and call 'fail' if we find that they
-- have been violated.
assertInvariantTMState :: TMState -> IO ()
assertInvariantTMState :: TMState -> IO ()
assertInvariantTMState TMState
mvarTMState = do
  TMState'
tmState <- TMState -> IO TMState'
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar TMState
mvarTMState
  [TMStateInvariantErr]
assertValue <- TMState' -> IO [TMStateInvariantErr]
invariantTMState' TMState'
tmState
  case [TMStateInvariantErr]
assertValue of
    [] x-> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    errs :: [TMStateInvariantErr]
errs@(TMStateInvariantErr
_:[TMStateInvariantErr]
_) -> do
      Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putStrLn Text
"In assertInvariantTMState, some invariants for TMState are being violated."
      Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putStrLn Text
"\nInvariants violated:"
      [TMStateInvariantErr] -> IO ()
forall a (m :: * -> *). (Show a, MonadIO m) => a -> m ()
print [TMStateInvariantErr]
errs
      Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putStrLn Text
"\nTMState:"
      TMState' -> IO ()
forall (m :: * -> *) a. (MonadIO m, Show a) => a -> m ()
pPrint TMState'
tmState
      Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putStrLn Text
""
      String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invariants violated for TMState"

pPrintTMState :: TMState -> IO ()
pPrintTMState :: TMState -> IO ()
pPrintTMState TMState
mvarTMState = do
  TMState'
tmState <- TMState -> IO TMState'
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar TMState
mvarTMState
  TMState' -> IO ()
forall (m :: * -> *) a. (MonadIO m, Show a) => a -> m ()
pPrint TMState'
tmState