{-# LANGUAGE StandaloneDeriving #-}
module Termonad.Types where
import Termonad.Prelude
import Data.FocusList (FocusList, emptyFL, singletonFL, getFocusItemFL, lengthFL)
import Data.Unique (Unique, hashUnique, newUnique)
import GI.Gtk
( Application
, ApplicationWindow
, IsWidget
, Label
, Notebook
, ScrolledWindow
, Widget
, notebookGetCurrentPage
, notebookGetNthPage
, notebookGetNPages
)
import GI.Pango (FontDescription)
import GI.Vte (Terminal, CursorBlinkMode(CursorBlinkModeOn))
import Text.Pretty.Simple (pPrint)
import Text.Show (Show(showsPrec), ShowS, showParen, showString)
import Termonad.Gtk (widgetEq)
data TMTerm = TMTerm
{ term :: !Terminal
, pid :: !Int
, unique :: !Unique
}
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 "}"
data TMNotebookTab = TMNotebookTab
{ tmNotebookTabTermContainer :: !ScrolledWindow
, tmNotebookTabTerm :: !TMTerm
, tmNotebookTabLabel :: !Label
}
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 "}"
data TMNotebook = TMNotebook
{ tmNotebook :: !Notebook
, tmNotebookTabs :: !(FocusList 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 "}"
data TMState' = TMState
{ tmStateApp :: !Application
, tmStateAppWin :: !ApplicationWindow
, tmStateNotebook :: !TMNotebook
, tmStateFontDesc :: !FontDescription
, tmStateConfig :: !TMConfig
}
instance Show TMState' where
showsPrec :: Int -> TMState' -> ShowS
showsPrec d TMState{..} =
showParen (d > 10) $
showString "TMState {" .
showString "tmStateApp = " .
showString "(GI.GTK.Application)" .
showString ", " .
showString "tmStateAppWin = " .
showString "(GI.GTK.ApplicationWindow)" .
showString ", " .
showString "tmStateNotebook = " .
showsPrec (d + 1) tmStateNotebook .
showString ", " .
showString "tmStateFontDesc = " .
showString "(GI.Pango.FontDescription)" .
showString ", " .
showString "tmStateConfig = " .
showsPrec (d + 1) tmStateConfig .
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 = do
unq <- newUnique
pure $ createTMTerm trm pd unq
getFocusedTermFromState :: TMState -> IO (Maybe Terminal)
getFocusedTermFromState mvarTMState =
withMVar mvarTMState go
where
go :: TMState' -> IO (Maybe Terminal)
go tmState = do
let maybeNotebookTab =
getFocusItemFL $ tmNotebookTabs $ tmStateNotebook tmState
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'])
newTMState :: TMConfig -> Application -> ApplicationWindow -> TMNotebook -> FontDescription -> IO TMState
newTMState tmConfig app appWin note fontDesc =
newMVar $
TMState
{ tmStateApp = app
, tmStateAppWin = appWin
, tmStateNotebook = note
, tmStateFontDesc = fontDesc
, tmStateConfig = tmConfig
}
newEmptyTMState :: TMConfig -> Application -> ApplicationWindow -> Notebook -> FontDescription -> IO TMState
newEmptyTMState tmConfig app appWin note fontDesc =
newMVar $
TMState
{ tmStateApp = app
, tmStateAppWin = appWin
, tmStateNotebook = createEmptyTMNotebook note
, tmStateFontDesc = fontDesc
, tmStateConfig = tmConfig
}
newTMStateSingleTerm ::
TMConfig
-> Application
-> ApplicationWindow
-> Notebook
-> Label
-> ScrolledWindow
-> Terminal
-> Int
-> FontDescription
-> IO TMState
newTMStateSingleTerm tmConfig app appWin note label scrollWin trm pd fontDesc = do
tmTerm <- newTMTerm trm pd
let tmNoteTab = createTMNotebookTab label scrollWin tmTerm
tabs = singletonFL tmNoteTab
tmNote = createTMNotebook note tabs
newTMState tmConfig app appWin tmNote fontDesc
traceShowMTMState :: TMState -> IO ()
traceShowMTMState mvarTMState = do
tmState <- readMVar mvarTMState
print tmState
data FontSize
= FontSizePoints Int
| FontSizeUnits Double
deriving (Eq, Show)
defaultFontSize :: FontSize
defaultFontSize = FontSizePoints 12
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
data FontConfig = FontConfig
{ fontFamily :: !Text
, fontSize :: !FontSize
} deriving (Eq, Show)
defaultFontConfig :: FontConfig
defaultFontConfig =
FontConfig
{ fontFamily = "Monospace"
, fontSize = defaultFontSize
}
data Option a = Unset | Set !a
deriving (Show, Read, Eq, Ord, Functor, Foldable)
whenSet :: Monoid m => Option a -> (a -> m) -> m
whenSet = \case
Unset -> \_ -> mempty
Set x -> \f -> f x
data ShowScrollbar
= ShowScrollbarNever
| ShowScrollbarAlways
| ShowScrollbarIfNeeded
deriving (Eq, Show)
data ShowTabBar
= ShowTabBarNever
| ShowTabBarAlways
| ShowTabBarIfNeeded
deriving (Eq, Show)
data ConfigOptions = ConfigOptions
{ fontConfig :: !FontConfig
, showScrollbar :: !ShowScrollbar
, scrollbackLen :: !Integer
, confirmExit :: !Bool
, wordCharExceptions :: !Text
, showMenu :: !Bool
, showTabBar :: !ShowTabBar
, cursorBlinkMode :: !CursorBlinkMode
} deriving (Eq, Show)
defaultConfigOptions :: ConfigOptions
defaultConfigOptions =
ConfigOptions
{ fontConfig = defaultFontConfig
, showScrollbar = ShowScrollbarIfNeeded
, scrollbackLen = 10000
, confirmExit = True
, wordCharExceptions = "-#%&+,./=?@\\_~\183:"
, showMenu = True
, showTabBar = ShowTabBarIfNeeded
, cursorBlinkMode = CursorBlinkModeOn
}
data TMConfig = TMConfig
{ options :: !ConfigOptions
, hooks :: !ConfigHooks
} deriving Show
defaultTMConfig :: TMConfig
defaultTMConfig =
TMConfig
{ options = defaultConfigOptions
, hooks = defaultConfigHooks
}
data ConfigHooks = ConfigHooks {
createTermHook :: TMState -> Terminal -> IO ()
}
instance Show ConfigHooks where
showsPrec :: Int -> ConfigHooks -> ShowS
showsPrec _ _ =
showString "ConfigHooks {" .
showString "createTermHook = <function>" .
showString "}"
defaultConfigHooks :: ConfigHooks
defaultConfigHooks =
ConfigHooks
{ createTermHook = defaultCreateTermHook
}
defaultCreateTermHook :: TMState -> Terminal -> IO ()
defaultCreateTermHook _ _ = pure ()
data FocusNotSameErr
= FocusListFocusExistsButNoNotebookTabWidget
| NotebookTabWidgetDiffersFromFocusListFocus
| NotebookTabWidgetExistsButNoFocusListFocus
deriving Show
data TabsDoNotMatch
= TabLengthsDifferent Int Int
| TabAtIndexDifferent Int
deriving (Show)
data TMStateInvariantErr
= FocusNotSame FocusNotSameErr Int
| TabsDoNotMatch TabsDoNotMatch
deriving Show
invariantTMState' :: TMState' -> IO [TMStateInvariantErr]
invariantTMState' tmState =
runInvariants
[ invariantFocusSame
, invariantTMTabLength
, invariantTabsAllMatch
]
where
runInvariants :: [IO (Maybe TMStateInvariantErr)] -> IO [TMStateInvariantErr]
runInvariants = fmap catMaybes . sequence
invariantFocusSame :: IO (Maybe TMStateInvariantErr)
invariantFocusSame = do
let tmNote = tmNotebook $ tmStateNotebook tmState
index32 <- notebookGetCurrentPage tmNote
maybeWidgetFromNote <- notebookGetNthPage tmNote index32
let focusList = tmNotebookTabs $ tmStateNotebook tmState
maybeScrollWinFromFL =
fmap 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 TMStateInvariantErr)
invariantTMTabLength = do
let tmNote = tmNotebook $ tmStateNotebook tmState
noteLength32 <- notebookGetNPages tmNote
let noteLength = fromIntegral noteLength32
focusListLength = lengthFL $ tmNotebookTabs $ tmStateNotebook tmState
lengthEqual = focusListLength == noteLength
if lengthEqual
then pure Nothing
else pure $
Just $
TabsDoNotMatch $
TabLengthsDifferent noteLength focusListLength
invariantTabsAllMatch :: IO (Maybe TMStateInvariantErr)
invariantTabsAllMatch = do
let tmNote = tmNotebook $ tmStateNotebook tmState
focusList = tmNotebookTabs $ tmStateNotebook tmState
flList = fmap tmNotebookTabTermContainer $ toList focusList
noteList <- notebookToList tmNote
tabsMatch noteList flList
where
tabsMatch
:: forall a b
. (IsWidget a, IsWidget b)
=> [a]
-> [b]
-> IO (Maybe TMStateInvariantErr)
tabsMatch xs ys = foldr go (pure Nothing) (zip3 xs ys [0..])
where
go :: (a, b, Int) -> IO (Maybe TMStateInvariantErr) -> IO (Maybe TMStateInvariantErr)
go (x, y, i) acc = do
isEq <- widgetEq x y
if isEq
then acc
else pure . Just $ TabsDoNotMatch (TabAtIndexDifferent i)
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