{-# 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) -- | 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 "}" 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 ------------ -- 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, Show) -- | 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 -- | 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, Show) -- | The default 'FontConfig' to use if not specified. -- -- >>> defaultFontConfig == FontConfig {fontFamily = "Monospace", fontSize = defaultFontSize} -- True defaultFontConfig :: FontConfig defaultFontConfig = FontConfig { fontFamily = "Monospace" , 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 (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 -> \_ -> 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 (Eq, Show) -- | 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 (Eq, Show) -- | 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. } deriving (Eq, Show) -- | The default 'ConfigOptions'. -- -- >>> :{ -- let defConfOpt = -- ConfigOptions -- { fontConfig = defaultFontConfig -- , showScrollbar = ShowScrollbarIfNeeded -- , scrollbackLen = 10000 -- , confirmExit = True -- , wordCharExceptions = "-#%&+,./=?@\\_~\183:" -- , showMenu = True -- , showTabBar = ShowTabBarIfNeeded -- , cursorBlinkMode = CursorBlinkModeOn -- } -- in defaultConfigOptions == defConfOpt -- :} -- True defaultConfigOptions :: ConfigOptions defaultConfigOptions = ConfigOptions { fontConfig = defaultFontConfig , showScrollbar = ShowScrollbarIfNeeded , scrollbackLen = 10000 , confirmExit = True , wordCharExceptions = "-#%&+,./=?@\\_~\183:" , showMenu = True , showTabBar = ShowTabBarIfNeeded , cursorBlinkMode = CursorBlinkModeOn } -- | The Termonad 'ConfigOptions' along with the 'ConfigHooks'. data TMConfig = TMConfig { options :: !ConfigOptions , hooks :: !ConfigHooks } deriving Show -- | The default 'TMConfig'. -- -- 'options' is 'defaultConfigOptions' and 'hooks' is 'defaultConfigHooks'. defaultTMConfig :: TMConfig defaultTMConfig = TMConfig { options = defaultConfigOptions , hooks = 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. data 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 = " . 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) data TMStateInvariantErr = FocusNotSame FocusNotSameErr Int | TabsDoNotMatch TabsDoNotMatch deriving 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 = 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 -- Turns a FocusList and Notebook into two lists of widgets and compares each widget for equality 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) -- | 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