Types.hs

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

module Termonad.Types where

import Termonad.Prelude

import Control.Lens (ifoldMap, imap)
import Data.FocusList (FocusList, emptyFL, getFocusItemFL, lengthFL)
import Data.Foldable (toList)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import Data.Unique (Unique, hashUnique, newUnique)
import Data.Yaml
  ( FromJSON(parseJSON)
  , ToJSON(toJSON)
  , Value(String)
  , withText
  )
import GI.Gdk
  ( pattern KEY_0
  , pattern KEY_1
  , pattern KEY_2
  , pattern KEY_3
  , pattern KEY_4
  , pattern KEY_5
  , pattern KEY_6
  , pattern KEY_7
  , pattern KEY_8
  , pattern KEY_9
  , ModifierType(..)
  )
import GI.Gtk
  ( Application
  , ApplicationWindow
  , IsWidget
  , Label
  , Notebook
  , ScrolledWindow
  , Widget
  , notebookGetCurrentPage
  , notebookGetNthPage
  , notebookGetNPages
  , notebookSetCurrentPage
  )
import GI.Pango (FontDescription, fontDescriptionGetSize, fontDescriptionGetSizeIsAbsolute, pattern SCALE, fontDescriptionGetFamily, fontDescriptionNew, fontDescriptionSetFamily, fontDescriptionSetSize, fontDescriptionSetAbsoluteSize)
import GI.Vte (Terminal, CursorBlinkMode(..))
import Termonad.Gtk (widgetEq)
import Termonad.IdMap (IdMap, IdMapKey, singletonIdMap, lookupIdMap)
import Text.Pretty.Simple (pPrint)

-- | 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
  { term :: !Terminal
    -- ^ The actual 'Terminal'.
  , pid :: !Int
    -- ^ The process ID of the process running in 'term'.
  , unique :: !Unique
    -- ^ A 'Unique' for comparing different 'TMTerm' for uniqueness.
  }

instance Show TMTerm where
  showsPrec :: Int -> TMTerm -> ShowS
  showsPrec d TMTerm{..} =
    showParen (d > 10) $
      showString "TMTerm {" .
      showString "term = " .
      showString "(GI.GTK.Terminal)" .
      showString ", " .
      showString "pid = " .
      showsPrec (d + 1) pid .
      showString ", " .
      showString "unique = " .
      showsPrec (d + 1) (hashUnique unique) .
      showString "}"

-- | 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
  { tmNotebookTabTermContainer :: !ScrolledWindow
    -- ^ The 'ScrolledWindow' holding the VTE 'Terminal'.
  , tmNotebookTabTerm :: !TMTerm
    -- ^ The 'Terminal' insidie the 'ScrolledWindow'.
  , tmNotebookTabLabel :: !Label
    -- ^ The 'Label' holding the title of the 'Terminal' in the 'Notebook' tab.
  }

instance Show TMNotebookTab where
  showsPrec :: Int -> TMNotebookTab -> ShowS
  showsPrec d TMNotebookTab{..} =
    showParen (d > 10) $
      showString "TMNotebookTab {" .
      showString "tmNotebookTabTermContainer = " .
      showString "(GI.GTK.ScrolledWindow)" .
      showString ", " .
      showString "tmNotebookTabTerm = " .
      showsPrec (d + 1) tmNotebookTabTerm .
      showString ", " .
      showString "tmNotebookTabLabel = " .
      showString "(GI.GTK.Label)" .
      showString "}"

-- | 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
    -- ^ This is the GTK 'Notebook' that holds multiple tabs of 'Terminal's.
  , tmNotebookTabs :: !(FocusList TMNotebookTab)
    -- ^ A 'FocusList' containing references to each individual 'TMNotebookTab'.
  }

instance Show TMNotebook where
  showsPrec :: Int -> TMNotebook -> ShowS
  showsPrec d TMNotebook{..} =
    showParen (d > 10) $
      showString "TMNotebook {" .
      showString "tmNotebook = " .
      showString "(GI.GTK.Notebook)" .
      showString ", " .
      showString "tmNotebookTabs = " .
      showsPrec (d + 1) tmNotebookTabs .
      showString "}"

getNotebookFromTMState :: TMState -> TMWindowId -> IO Notebook
getNotebookFromTMState mvarTMState tmWinId = do
  tmNote <- getTMNotebookFromTMState mvarTMState tmWinId
  pure $ tmNotebook tmNote

getNotebookFromTMState' :: TMState' -> TMWindowId -> IO Notebook
getNotebookFromTMState' tmState tmWinId = do
  tmNote <- getTMNotebookFromTMState' tmState tmWinId
  pure $ tmNotebook tmNote

getTMNotebookFromTMState :: TMState -> TMWindowId -> IO TMNotebook
getTMNotebookFromTMState mvarTMState tmWinId = do
  tmWin <- getTMWindowFromTMState mvarTMState tmWinId
  pure $ tmWindowNotebook tmWin

getTMNotebookFromTMState' :: TMState' -> TMWindowId -> IO TMNotebook
getTMNotebookFromTMState' tmState tmWinId = do
  tmWin <- getTMWindowFromTMState' tmState tmWinId
  pure $ tmWindowNotebook tmWin

data TMWindow = TMWindow
  { tmWindowAppWin :: !ApplicationWindow
  , tmWindowNotebook :: !TMNotebook
  }

instance Show TMWindow where
  showsPrec :: Int -> TMWindow -> ShowS
  showsPrec d TMWindow{..} =
    showParen (d > 10) $
      showString "TMWindow {" .
      showString "tmWindowAppWin = " .
      showString "(GI.GTK.ApplicationWindow)" .
      showString ", " .
      showString "tmWindowNotebook = " .
      showsPrec (d + 1) tmWindowNotebook .
      showString "}"

type TMWindowId = IdMapKey

-- | Get a given 'TMWindow' from a set of 'TMWindow's given a 'TMWindowId'.
--
-- This throws an error if the 'TMWindowId' can't be found within the 'IdMap'.
getTMWindowFromWins :: IdMap TMWindow -> TMWindowId -> IO TMWindow
getTMWindowFromWins tmWins tmWinId =
  case lookupIdMap tmWinId tmWins of
    Nothing -> error $ "getTMWindowFromWins: trying to get id " <> show tmWinId <> " from wins, but doesn't exist: " <> show tmWins
    Just tmWin -> pure tmWin

-- | Get a given 'TMWindow' froma a 'TMState' given a 'TMWindowId'.
--
-- This throws an error if the 'TMWindowId' can't be found within the 'TMState'.
getTMWindowFromTMState :: TMState -> TMWindowId -> IO TMWindow
getTMWindowFromTMState mvarTMState tmWinId = do
  TMState{tmStateWindows} <- readMVar mvarTMState
  getTMWindowFromWins tmStateWindows tmWinId

getTMWindowFromTMState' :: TMState' -> TMWindowId -> IO TMWindow
getTMWindowFromTMState' tmState tmWinId =
  getTMWindowFromWins (tmStateWindows tmState) tmWinId

data TMState' = TMState
  { tmStateApp :: !Application
  , tmStateConfig :: !TMConfig
  , tmStateFontDesc :: !FontDescription
  , tmStateWindows :: !(IdMap TMWindow)
  }

instance Show TMState' where
  showsPrec :: Int -> TMState' -> ShowS
  showsPrec d TMState{..} =
    showParen (d > 10) $
      showString "TMState {" .
      showString "tmStateApp = " .
      showString "(GI.GTK.Application)" .
      showString ", " .
      showString "tmStateConfig = " .
      showsPrec (d + 1) tmStateConfig .
      showString ", " .
      showString "tmStateFontDesc = " .
      showString "(GI.Pango.FontDescription)" .
      showString ", " .
      showString "tmStateWindows = " .
      showsPrec (d + 1) tmStateWindows .
      showString "}"

type TMState = MVar TMState'

instance Eq TMTerm where
  (==) :: TMTerm -> TMTerm -> Bool
  (==) = (==) `on` (unique :: TMTerm -> Unique)

instance Eq TMNotebookTab where
  (==) :: TMNotebookTab -> TMNotebookTab -> Bool
  (==) = (==) `on` tmNotebookTabTerm

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

newTMTerm :: Terminal -> Int -> IO TMTerm
newTMTerm trm pd = createTMTerm trm pd <$> newUnique

getFocusedTermFromState :: TMState -> TMWindowId -> IO (Maybe Terminal)
getFocusedTermFromState mvarTMState tmWinId =
  withMVar mvarTMState go
  where
    go :: TMState' -> IO (Maybe Terminal)
    go tmState = do
      tmNote <- getTMNotebookFromTMState' tmState tmWinId
      let maybeNotebookTab = getFocusItemFL $ tmNotebookTabs tmNote
      pure $ fmap (term . tmNotebookTabTerm) maybeNotebookTab

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

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

createEmptyTMNotebook :: Notebook -> TMNotebook
createEmptyTMNotebook notebook = createTMNotebook notebook emptyFL

notebookToList :: Notebook -> IO [Widget]
notebookToList notebook =
  unfoldHelper 0 []
  where unfoldHelper :: Int32 -> [Widget] -> IO [Widget]
        unfoldHelper index32 acc = do
          notePage <- notebookGetNthPage notebook index32
          case notePage of
            Nothing -> pure acc
            Just notePage' -> unfoldHelper (index32 + 1) (acc ++ [notePage'])

createTMWindow :: ApplicationWindow -> TMNotebook -> TMWindow
createTMWindow appwin notebook =
  TMWindow
    { tmWindowAppWin = appwin
    , tmWindowNotebook = notebook
    }

newEmptyTMState :: TMConfig -> Application -> ApplicationWindow -> Notebook -> FontDescription -> IO (TMState, TMWindowId)
newEmptyTMState tmConfig app appWin note fontDesc = do
  let tmnote = createEmptyTMNotebook note
      tmwin = createTMWindow appWin tmnote
      (tmwinId, tmwins) = singletonIdMap tmwin
  tmState <-
    newMVar $
      TMState
        { tmStateApp = app
        , tmStateConfig = tmConfig
        , tmStateFontDesc = fontDesc
        , tmStateWindows = tmwins
        }
  pure (tmState, tmwinId)

------------
-- 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 (Eq, FromJSON, Generic, Show, ToJSON)

-- | The default 'FontSize' used if not specified.
--
-- >>> defaultFontSize
-- FontSizePoints 12
defaultFontSize :: FontSize
defaultFontSize = FontSizePoints 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 i (FontSizePoints oldPoints) =
  let newPoints = oldPoints + i
  in FontSizePoints $ if newPoints < 1 then oldPoints else newPoints
modFontSize i (FontSizeUnits oldUnits) =
  let newUnits = oldUnits + fromIntegral i
  in FontSizeUnits $ if newUnits < 1 then oldUnits else newUnits

fontSizeFromFontDescription :: FontDescription -> IO FontSize
fontSizeFromFontDescription fontDesc = do
  currSize <- fontDescriptionGetSize fontDesc
  currAbsolute <- fontDescriptionGetSizeIsAbsolute fontDesc
  pure $
    if currAbsolute
    then FontSizeUnits $ fromIntegral currSize / fromIntegral SCALE
    else
      let fontRatio :: Double = fromIntegral currSize / fromIntegral SCALE
      in FontSizePoints $ round fontRatio

-- | Create a 'FontDescription' from a 'FontSize' and font family.
createFontDesc
  :: FontSize
  -> Text
  -- ^ font family
  -> IO FontDescription
createFontDesc fontSz fontFam = do
  fontDesc <- fontDescriptionNew
  fontDescriptionSetFamily fontDesc fontFam
  setFontDescSize fontDesc fontSz
  pure fontDesc

-- | Set the size of a 'FontDescription' from a 'FontSize'.
setFontDescSize :: FontDescription -> FontSize -> IO ()
setFontDescSize fontDesc (FontSizePoints points) =
  fontDescriptionSetSize fontDesc $ fromIntegral (points * fromIntegral SCALE)
setFontDescSize fontDesc (FontSizeUnits units) =
  fontDescriptionSetAbsoluteSize fontDesc $ units * fromIntegral SCALE

-- | Create a 'FontDescription' from the 'fontSize' and 'fontFamily' inside a 'TMConfig'.
createFontDescFromConfig :: TMConfig -> IO FontDescription
createFontDescFromConfig tmConfig = do
  let fontConf = fontConfig (options tmConfig)
  createFontDesc (fontSize fontConf) (fontFamily fontConf)

-- | Settings for the font to be used in Termonad.
data FontConfig = FontConfig
  { fontFamily :: !Text
    -- ^ The font family to use.  Example: @"DejaVu Sans Mono"@ or @"Source Code Pro"@
  , fontSize :: !FontSize
    -- ^ The font size.
  } deriving (Eq, FromJSON, Generic, Show, ToJSON)

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

fontConfigFromFontDescription :: FontDescription -> IO (Maybe FontConfig)
fontConfigFromFontDescription fontDescription = do
  fontSize <- fontSizeFromFontDescription fontDescription
  maybeFontFamily <- fontDescriptionGetFamily fontDescription
  return $ (`FontConfig` fontSize) <$> maybeFontFamily

-- | 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 explicitly setting
-- 'cursorFgColour'.
data Option a = Unset | Set !a
  deriving (Show, Read, Eq, Ord, Functor, 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 = \case
  Unset -> const mempty
  Set x -> \f -> f 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 (Enum, Eq, Generic, FromJSON, Show, ToJSON)

showScrollbarToString :: ShowScrollbar -> Text
showScrollbarToString = \case
  ShowScrollbarNever -> "never"
  ShowScrollbarAlways -> "always"
  ShowScrollbarIfNeeded -> "if-needed"

showScrollbarFromString :: Text -> Maybe ShowScrollbar
showScrollbarFromString = \case
  "never" -> Just ShowScrollbarNever
  "always" -> Just ShowScrollbarAlways
  "if-needed" -> Just ShowScrollbarIfNeeded
  _ -> Nothing

-- | 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 (Enum, Eq, Generic, FromJSON, Show, ToJSON)

showTabBarToString :: ShowTabBar -> Text
showTabBarToString = \case
  ShowTabBarNever -> "never"
  ShowTabBarAlways -> "always"
  ShowTabBarIfNeeded -> "if-needed"

showTabBarFromString :: Text -> Maybe ShowTabBar
showTabBarFromString = \case
  "never" -> Just ShowTabBarNever
  "always" -> Just ShowTabBarAlways
  "if-needed" -> Just ShowTabBarIfNeeded
  _ -> Nothing

-- | Configuration options for Termonad.
--
-- See 'defaultConfigOptions' for the default values.
data ConfigOptions = ConfigOptions
  { fontConfig :: !FontConfig
    -- ^ Specific options for fonts.
  , showScrollbar :: !ShowScrollbar
    -- ^ When to show the scroll bar.
  , scrollbackLen :: !Integer
    -- ^ The number of lines to keep in the scroll back history for each terminal.
  , 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'.
  , 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.
  , showMenu :: !Bool
    -- ^ Whether or not to show the @File@ @Edit@ etc menu.
  , showTabBar :: !ShowTabBar
    -- ^ When to show the tab bar.
  , cursorBlinkMode :: !CursorBlinkMode
    -- ^ How to handle cursor blink.
  , 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'.
  , 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.
  , allowBold :: !Bool
    -- ^ Allow terminal to use bold text.
    --
    -- You may want to disable this, for instance, if you use a font that
    -- doesn't look good when bold.
  } deriving (Eq, Generic, FromJSON, Show, ToJSON)

cursorBlinkModeToString :: CursorBlinkMode -> Text
cursorBlinkModeToString = \case
  CursorBlinkModeSystem -> "system"
  CursorBlinkModeOn -> "on"
  CursorBlinkModeOff -> "off"
  AnotherCursorBlinkMode _ -> "other"

cursorBlinkModeFromString :: Text -> Maybe CursorBlinkMode
cursorBlinkModeFromString = \case
  "system" -> Just CursorBlinkModeSystem
  "on" -> Just CursorBlinkModeOn
  "off" -> Just CursorBlinkModeOff
  _ -> Nothing

instance FromJSON CursorBlinkMode where
  parseJSON = withText "CursorBlinkMode" $ \c -> do
    case (c :: Text) of
      "CursorBlinkModeSystem" -> pure CursorBlinkModeSystem
      "CursorBlinkModeOn" -> pure CursorBlinkModeOn
      "CursorBlinkModeOff" -> pure CursorBlinkModeOff
      _ -> fail "Wrong value for CursorBlinkMode"

instance ToJSON CursorBlinkMode where
  toJSON CursorBlinkModeSystem = String "CursorBlinkModeSystem"
  toJSON CursorBlinkModeOn = String "CursorBlinkModeOn"
  toJSON CursorBlinkModeOff = String "CursorBlinkModeOff"
  -- Not supposed to happened fall back to system
  toJSON (AnotherCursorBlinkMode _) = String "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
--           , allowBold = True
--           }
--   in defaultConfigOptions == defConfOpt
-- :}
-- True
defaultConfigOptions :: ConfigOptions
defaultConfigOptions =
  ConfigOptions
    { fontConfig = defaultFontConfig
    , showScrollbar = ShowScrollbarIfNeeded
    , scrollbackLen = 10000
    , confirmExit = True
    , wordCharExceptions = "-#%&+,./=?@\\_~\183:"
    , showMenu = True
    , showTabBar = ShowTabBarIfNeeded
    , cursorBlinkMode = CursorBlinkModeOn
    , boldIsBright = False
    , enableSixel = False
    , allowBold = True
    }

-- | The Termonad 'ConfigOptions' along with the 'ConfigHooks'.
data TMConfig = TMConfig
  { options :: !ConfigOptions
  , hooks :: !ConfigHooks
  , keys :: Map Key (TMState -> TMWindowId -> IO Bool)
  }

instance Show TMConfig where
  show cfg = (show . options) cfg <> (show . hooks) cfg

-- | The default 'TMConfig'.
--
-- 'options' is 'defaultConfigOptions' and 'hooks' is 'defaultConfigHooks'.
defaultTMConfig :: TMConfig
defaultTMConfig =
  TMConfig
    { options = defaultConfigOptions
    , hooks = defaultConfigHooks
    , keys = keyMap
    }

data Key = Key
  { keyVal :: !Word32
  , keyMods :: !(Set ModifierType)
  } deriving (Eq, Ord, Show)

toKey :: Word32 -> Set ModifierType -> Key
toKey = Key

keyMap :: Map Key (TMState -> TMWindowId -> IO Bool)
keyMap =
  let numKeys :: [Word32]
      numKeys =
        [ KEY_1
        , KEY_2
        , KEY_3
        , KEY_4
        , KEY_5
        , KEY_6
        , KEY_7
        , KEY_8
        , KEY_9
        , KEY_0
        ]
      altNumKeys :: [(Key, TMState -> TMWindowId -> IO Bool)]
      altNumKeys =
        imap
          (\i k ->
             (toKey k [ModifierTypeMod1Mask], stopProp (altNumSwitchTerm i))
          )
          numKeys
  in
  Map.fromList altNumKeys

stopProp :: (TMState -> TMWindowId -> IO a) -> TMState -> TMWindowId -> IO Bool
stopProp callback terState tmWinId = callback terState tmWinId $> True

focusTerm :: Int -> TMState -> TMWindowId -> IO ()
focusTerm i mvarTMState tmWinId = do
  note <- getNotebookFromTMState mvarTMState tmWinId
  notebookSetCurrentPage note (fromIntegral i)

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

---------------------
-- 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.
  createTermHook :: TMState -> Terminal -> IO ()
}

instance Show ConfigHooks where
  showsPrec :: Int -> ConfigHooks -> ShowS
  showsPrec _ _ =
    showString "ConfigHooks {" .
    showString "createTermHook = <function>" .
    showString "}"

-- | Default values for the 'ConfigHooks'.
--
-- - The default function for 'createTermHook' is 'defaultCreateTermHook'.
defaultConfigHooks :: ConfigHooks
defaultConfigHooks =
  ConfigHooks
    { createTermHook = defaultCreateTermHook
    }

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

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

data FocusNotSameErr
  = FocusListFocusExistsButNoNotebookTabWidget
  | NotebookTabWidgetDiffersFromFocusListFocus
  | NotebookTabWidgetExistsButNoFocusListFocus
  deriving 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 (Show)

-- | An invariant error on a given 'TMWindow'.
data TMWinInvariantErr
  = FocusNotSame FocusNotSameErr Int
  | TabsDoNotMatch TabsDoNotMatch
  deriving Show

-- | An invariant error on a whole 'TMState'.
data TMStateInvariantErr
  = TMWinInvariantErr Int TMWinInvariantErr
    -- ^ An invariant error with a given 'TMWindow'.  The 'Int' indicates
    -- which window it is as an index into 'tmStateWindows'.
  deriving Show

invariantTMWindow :: TMWindow -> IO [TMWinInvariantErr]
invariantTMWindow tmWin =
  runInvariants
    [ invariantFocusSame
    , invariantTMTabLength
    , invariantTabsAllMatch
    ]
  where
    runInvariants :: [IO (Maybe TMWinInvariantErr)] -> IO [TMWinInvariantErr]
    runInvariants = fmap catMaybes . sequence

    invariantFocusSame :: IO (Maybe TMWinInvariantErr)
    invariantFocusSame = do
      let tmNote = tmNotebook $ tmWindowNotebook tmWin
      index32 <- notebookGetCurrentPage tmNote
      maybeWidgetFromNote <- notebookGetNthPage tmNote index32
      let focusList = tmNotebookTabs $ tmWindowNotebook tmWin
          maybeScrollWinFromFL =
            tmNotebookTabTermContainer <$> getFocusItemFL focusList
          idx = fromIntegral index32
      case (maybeWidgetFromNote, maybeScrollWinFromFL) of
        (Nothing, Nothing) -> pure Nothing
        (Just _, Nothing) ->
          pure $
            Just $
              FocusNotSame NotebookTabWidgetExistsButNoFocusListFocus idx
        (Nothing, Just _) ->
          pure $
            Just $
              FocusNotSame FocusListFocusExistsButNoNotebookTabWidget idx
        (Just widgetFromNote, Just scrollWinFromFL) -> do
          isEq <- widgetEq widgetFromNote scrollWinFromFL
          if isEq
            then pure Nothing
            else
              pure $
                Just $
                  FocusNotSame NotebookTabWidgetDiffersFromFocusListFocus idx

    invariantTMTabLength :: IO (Maybe TMWinInvariantErr)
    invariantTMTabLength = do
      let tmNote = tmNotebook $ tmWindowNotebook tmWin
      noteLength32 <- notebookGetNPages tmNote
      let noteLength = fromIntegral noteLength32
          focusListLength = lengthFL $ tmNotebookTabs $ tmWindowNotebook tmWin
          lengthEqual = focusListLength == noteLength
      if lengthEqual
        then pure Nothing
        else  pure $
               Just $
                TabsDoNotMatch $
                 TabLengthsDifferent noteLength focusListLength

    -- Turns a FocusList and Notebook into two lists of widgets and compares each widget for equality
    invariantTabsAllMatch :: IO (Maybe TMWinInvariantErr)
    invariantTabsAllMatch = do
      let tmNote = tmNotebook $ tmWindowNotebook tmWin
          focusList = tmNotebookTabs $ tmWindowNotebook tmWin
          flList = tmNotebookTabTermContainer <$> toList focusList
      noteList <- notebookToList tmNote
      tabsMatch noteList flList
      where
        tabsMatch
          :: forall a b
           . (IsWidget a, IsWidget b)
          => [a]
          -> [b]
          -> IO (Maybe TMWinInvariantErr)
        tabsMatch xs ys = foldr go (pure Nothing) (zip3 xs ys [0..])
          where
            go :: (a, b, Int) -> IO (Maybe TMWinInvariantErr) -> IO (Maybe TMWinInvariantErr)
            go (x, y, i) acc = do
              isEq <- widgetEq x y
              if isEq
                then acc
                else pure . Just $ TabsDoNotMatch (TabAtIndexDifferent i)

-- | 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 = do
  let tmWindows = tmStateWindows tmState
  ifoldMap go tmWindows
  where
    go :: Int -> TMWindow -> IO [TMStateInvariantErr]
    go idx tmWin = do
      tmWinErrs <- invariantTMWindow tmWin
      pure $ fmap (TMWinInvariantErr idx) tmWinErrs

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

pPrintTMState :: TMState -> IO ()
pPrintTMState mvarTMState = do
  tmState <- readMVar mvarTMState
  pPrint tmState

traceShowMTMState :: TMState -> IO ()
traceShowMTMState mvarTMState = do
  tmState <- readMVar mvarTMState
  print tmState