diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,2 @@ + +## 0.1.0.0 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Dennis Gosnell (c) 2018 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,15 @@ + +Termonad +========= + +[![Build Status](https://secure.travis-ci.org/cdepillabout/termonad.svg)](http://travis-ci.org/cdepillabout/termonad) +[![Hackage](https://img.shields.io/hackage/v/termonad.svg)](https://hackage.haskell.org/package/termonad) +[![Stackage LTS](http://stackage.org/package/termonad/badge/lts)](http://stackage.org/lts/package/termonad) +[![Stackage Nightly](http://stackage.org/package/termonad/badge/nightly)](http://stackage.org/nightly/package/termonad) +![BSD3 license](https://img.shields.io/badge/license-BSD3-blue.svg) + +TODO + + +**Table of Contents** + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,111 @@ +-- This file comes from cabal-doctest: +-- https://github.com/phadej/cabal-doctest/blob/master/simple-example +-- +-- It is needed so that doctest can be run with the same options as the modules +-- are compiled with. + +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedLists #-} +{-# OPTIONS_GHC -Wall #-} +module Main (main) where + +import Data.Maybe (catMaybes) +import Data.Monoid ((<>)) +import Data.Version (Version) +import Distribution.PackageDescription (HookedBuildInfo, cppOptions, emptyBuildInfo) +import Distribution.Simple (UserHooks, defaultMainWithHooks, preBuild, preRepl, simpleUserHooks) +import Distribution.Simple.Program (configureProgram, defaultProgramConfiguration, getDbProgramOutput, pkgConfigProgram) +import Distribution.Text (simpleParse) +import Distribution.Verbosity (normal) + +#ifndef MIN_VERSION_cabal_doctest +#define MIN_VERSION_cabal_doctest(x,y,z) 0 +#endif + +#if MIN_VERSION_cabal_doctest(1,0,0) + +import Distribution.Extra.Doctest (addDoctestsUserHook) +main :: IO () +main = do + cppOpts <- getGtkVersionCPPOpts + defaultMainWithHooks . addPkgConfigGtkUserHook cppOpts $ + addDoctestsUserHook "doctests" simpleUserHooks + +#else + +#ifdef MIN_VERSION_Cabal +-- If the macro is defined, we have new cabal-install, +-- but for some reason we don't have cabal-doctest in package-db +-- +-- Probably we are running cabal sdist, when otherwise using new-build +-- workflow +#warning You are configuring this package without cabal-doctest installed. \ + The doctests test-suite will not work as a result. \ + To fix this, install cabal-doctest before configuring. +#endif + +main :: IO () +main = do + cppOpts <- getGtkVersionCPPOpts + defaultMainWithHooks $ addPkgConfigGtkUserHook cppOpts simpleUserHooks + +#endif + +-- | Add CPP macros representing the version of the GTK system library. +addPkgConfigGtkUserHook :: [String] -> UserHooks -> UserHooks +addPkgConfigGtkUserHook cppOpts oldUserHooks = do + oldUserHooks + { preBuild = pkgConfigGtkHook cppOpts $ preBuild oldUserHooks + , preRepl = pkgConfigGtkHook cppOpts (preRepl oldUserHooks) + } + +pkgConfigGtkHook :: [String] -> (args -> flags -> IO HookedBuildInfo) -> args -> flags -> IO HookedBuildInfo +pkgConfigGtkHook cppOpts oldFunc args flags = do + (maybeOldLibHookedInfo, oldExesHookedInfo) <- oldFunc args flags + case maybeOldLibHookedInfo of + Just oldLibHookedInfo -> do + let newLibHookedInfo = + oldLibHookedInfo + { cppOptions = cppOptions oldLibHookedInfo <> cppOpts + } + pure (Just newLibHookedInfo, oldExesHookedInfo) + Nothing -> do + let newLibHookedInfo = + emptyBuildInfo + { cppOptions = cppOpts + } + pure (Just newLibHookedInfo, oldExesHookedInfo) + +getGtkVersionCPPOpts :: IO [String] +getGtkVersionCPPOpts = do + pkgDb <- configureProgram normal pkgConfigProgram defaultProgramConfiguration + pkgConfigOutput <- + getDbProgramOutput normal pkgConfigProgram pkgDb ["--modversion", "gtk+-3.0"] + -- Drop the newline on the end of the pkgConfigOutput. + -- This should give us a version number like @3.22.11@. + let rawGtkVersion = reverse $ drop 1 $ reverse pkgConfigOutput + let maybeGtkVersion = simpleParse rawGtkVersion + case maybeGtkVersion of + Nothing -> do + putStrLn "In Setup.hs, in getGtkVersionCPPOpts, could not parse gtk version:" + print pkgConfigOutput + putStrLn "\nNot defining any CPP macros based on the version of the system GTK library." + putStrLn "\nCompilation of termonad may fail." + pure [] + Just gtkVersion -> do + let cppOpts = createGtkVersionCPPOpts gtkVersion + pure cppOpts + +-- | Based on the version of the GTK3 library as reported by @pkg-config@, return +-- a list of CPP macros that contain the GTK version. These can be used in the +-- Haskell code to work around differences in the gi-gtk library Haskell +-- library when compiled against different versions of the GTK system library. +-- +-- This list may need to be added to. +createGtkVersionCPPOpts + :: Version -- ^ 'Version' of the GTK3 library as reported by @pkg-config@. + -> [String] -- ^ A list of CPP macros to show the GTK version. +createGtkVersionCPPOpts gtkVersion = + catMaybes $ + [ if gtkVersion >= [3,22] then Just "-DGTK_VERSION_GEQ_3_22" else Nothing + ] diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,8 @@ + +module Main where + +import Termonad (defaultMain) +import Termonad.Config (defaultTMConfig) + +main :: IO () +main = defaultMain defaultTMConfig diff --git a/src/Termonad.hs b/src/Termonad.hs new file mode 100644 --- /dev/null +++ b/src/Termonad.hs @@ -0,0 +1,7 @@ +module Termonad + ( defaultMain + , module Config + ) where + +import Termonad.App (defaultMain) +import Termonad.Config as Config diff --git a/src/Termonad/App.hs b/src/Termonad/App.hs new file mode 100644 --- /dev/null +++ b/src/Termonad/App.hs @@ -0,0 +1,354 @@ + +module Termonad.App where + +import Termonad.Prelude + +import Config.Dyre (defaultParams, projectName, realMain, showError, wrapMain) +import Control.Lens ((&), (^.), (.~)) +import GI.Gdk (castTo, managedForeignPtr, screenGetDefault) +import GI.Gio + ( ApplicationFlags(ApplicationFlagsFlagsNone) + , MenuModel(MenuModel) + , actionMapAddAction + , applicationQuit + , applicationRun + , onApplicationActivate + , onApplicationStartup + , onSimpleActionActivate + , simpleActionNew + ) +import GI.Gtk + ( Application + , ApplicationWindow(ApplicationWindow) + , Box(Box) + , ResponseType(ResponseTypeNo, ResponseTypeYes) + , ScrolledWindow(ScrolledWindow) + , pattern STYLE_PROVIDER_PRIORITY_APPLICATION + , aboutDialogNew + , applicationAddWindow + , applicationGetActiveWindow + , applicationSetAccelsForAction + , applicationSetMenubar + , boxPackStart + , builderNewFromString + , builderSetApplication + , containerAdd + , cssProviderLoadFromData + , cssProviderNew + , dialogAddButton + , dialogGetContentArea + , dialogNew + , dialogRun + , labelNew + , notebookGetNPages + , notebookNew + , onNotebookPageRemoved + , onNotebookPageReordered + , onNotebookSwitchPage + , onWidgetDestroy + , setWidgetMargin + , styleContextAddProviderForScreen + , widgetDestroy + , widgetGrabFocus + , widgetSetCanFocus + , widgetShow + , widgetShowAll + , windowClose + , windowPresent + , windowSetTransientFor + ) +import qualified GI.Gtk as Gtk +import GI.Pango + ( FontDescription + , pattern SCALE + , fontDescriptionNew + , fontDescriptionSetFamily + , fontDescriptionSetSize + ) +import GI.Vte + ( terminalCopyClipboard + , terminalPasteClipboard + ) + +import Termonad.Config + ( FontConfig(fontFamily, fontSize) + , TMConfig + , lensFontConfig + ) +import Termonad.FocusList (findFL, moveFromToFL, updateFocusFL) +import Termonad.Gtk (appNew, objFromBuildUnsafe) +import Termonad.Keys (handleKeyPress) +import Termonad.Term (createTerm, relabelTabs, termExitFocused) +import Termonad.Types + ( TMNotebookTab + , TMState + , TMState'(TMState) + , getFocusedTermFromState + , lensTMNotebookTabs + , lensTMNotebookTabTerm + , lensTMStateApp + , lensTMStateNotebook + , lensTerm + , newEmptyTMState + , tmNotebookTabTermContainer + , tmNotebookTabs + , tmStateNotebook + ) +import Termonad.XML (interfaceText, menuText) + +setupScreenStyle :: IO () +setupScreenStyle = do + maybeScreen <- screenGetDefault + case maybeScreen of + Nothing -> pure () + Just screen -> do + cssProvider <- cssProviderNew + let (textLines :: [Text]) = + [ + "scrollbar {" + -- , " -GtkRange-slider-width: 200px;" + -- , " -GtkRange-stepper-size: 200px;" + -- , " border-width: 200px;" + , " background-color: #aaaaaa;" + -- , " color: #ff0000;" + , " min-width: 4px;" + , "}" + -- , "scrollbar trough {" + -- , " -GtkRange-slider-width: 200px;" + -- , " -GtkRange-stepper-size: 200px;" + -- , " border-width: 200px;" + -- , " background-color: #00ff00;" + -- , " color: #00ff00;" + -- , " min-width: 50px;" + -- , "}" + -- , "scrollbar slider {" + -- , " -GtkRange-slider-width: 200px;" + -- , " -GtkRange-stepper-size: 200px;" + -- , " border-width: 200px;" + -- , " background-color: #0000ff;" + -- , " color: #0000ff;" + -- , " min-width: 50px;" + -- , "}" + , "tab {" + , " background-color: transparent;" + , "}" + ] + let styleData = encodeUtf8 (unlines textLines :: Text) + cssProviderLoadFromData cssProvider styleData + styleContextAddProviderForScreen + screen + cssProvider + (fromIntegral STYLE_PROVIDER_PRIORITY_APPLICATION) + +createFontDesc :: TMConfig -> IO FontDescription +createFontDesc tmConfig = do + fontDesc <- fontDescriptionNew + let fontConf = tmConfig ^. lensFontConfig + fontDescriptionSetFamily fontDesc (fontFamily fontConf) + fontDescriptionSetSize fontDesc (fromIntegral (fontSize fontConf) * SCALE) + pure fontDesc + +compareScrolledWinAndTab :: ScrolledWindow -> a -> TMNotebookTab -> Bool +compareScrolledWinAndTab scrollWin _ flTab = + let ScrolledWindow managedPtrFLTab = tmNotebookTabTermContainer flTab + foreignPtrFLTab = managedForeignPtr managedPtrFLTab + ScrolledWindow managedPtrScrollWin = scrollWin + foreignPtrScrollWin = managedForeignPtr managedPtrScrollWin + in foreignPtrFLTab == foreignPtrScrollWin + +updateFLTabPos :: TMState -> Int -> Int -> IO () +updateFLTabPos mvarTMState oldPos newPos = + modifyMVar_ mvarTMState $ \tmState -> do + let tabs = tmState ^. lensTMStateNotebook . lensTMNotebookTabs + maybeNewTabs = moveFromToFL oldPos newPos tabs + case maybeNewTabs of + Nothing -> do + putStrLn $ + "in updateFLTabPos, Strange error: couldn't move tabs.\n" <> + "old pos: " <> tshow oldPos <> "\n" <> + "new pos: " <> tshow newPos <> "\n" <> + "tabs: " <> tshow tabs <> "\n" <> + "maybeNewTabs: " <> tshow maybeNewTabs <> "\n" <> + "tmState: " <> tshow tmState + pure tmState + Just newTabs -> + pure $ + tmState & + lensTMStateNotebook . lensTMNotebookTabs .~ newTabs + +exitWithConfirmation :: TMState -> IO () +exitWithConfirmation mvarTMState = do + tmState <- readMVar mvarTMState + let app = tmState ^. lensTMStateApp + win <- applicationGetActiveWindow app + dialog <- dialogNew + box <- dialogGetContentArea dialog + label <- labelNew (Just "There are still terminals running. Are you sure you want to exit?") + containerAdd box label + widgetShow label + setWidgetMargin label 10 + void $ + dialogAddButton + dialog + "No, do NOT exit" + (fromIntegral (fromEnum ResponseTypeNo)) + void $ + dialogAddButton + dialog + "Yes, exit" + (fromIntegral (fromEnum ResponseTypeYes)) + windowSetTransientFor dialog win + res <- dialogRun dialog + widgetDestroy dialog + case toEnum (fromIntegral res) of + ResponseTypeYes -> quit mvarTMState + _ -> pure () + +quit :: TMState -> IO () +quit mvarTMState = do + tmState <- readMVar mvarTMState + let app = tmState ^. lensTMStateApp + maybeWin <- applicationGetActiveWindow app + case maybeWin of + Nothing -> applicationQuit app + Just win -> windowClose win + +setupTermonad :: TMConfig -> Application -> ApplicationWindow -> Gtk.Builder -> IO () +setupTermonad tmConfig app win builder = do + setupScreenStyle + box <- objFromBuildUnsafe builder "content_box" Box + fontDesc <- createFontDesc tmConfig + note <- notebookNew + widgetSetCanFocus note False + boxPackStart box note True True 0 + + mvarTMState <- newEmptyTMState tmConfig app win note fontDesc + terminal <- createTerm handleKeyPress mvarTMState + + void $ onNotebookPageRemoved note $ \_ _ -> do + pages <- notebookGetNPages note + when (pages == 0) $ quit mvarTMState + + void $ onNotebookSwitchPage note $ \_ pageNum -> do + maybeRes <- tryTakeMVar mvarTMState + case maybeRes of + Nothing -> pure () + Just val -> do + putMVar mvarTMState val + modifyMVar_ mvarTMState $ \tmState -> do + let notebook = tmStateNotebook tmState + tabs = tmNotebookTabs notebook + maybeNewTabs = updateFocusFL (fromIntegral pageNum) tabs + case maybeNewTabs of + Nothing -> pure tmState + Just (tab, newTabs) -> do + widgetGrabFocus $ tab ^. lensTMNotebookTabTerm . lensTerm + pure $ + tmState & + lensTMStateNotebook . lensTMNotebookTabs .~ newTabs + + void $ onNotebookPageReordered note $ \childWidg pageNum -> do + maybeScrollWin <- castTo ScrolledWindow childWidg + case maybeScrollWin of + Nothing -> + fail $ + "In setupTermonad, in callback for onNotebookPageReordered, " <> + "child widget is not a ScrolledWindow.\n" <> + "Don't know how to continue.\n" + Just scrollWin -> do + TMState{tmStateNotebook} <- readMVar mvarTMState + let fl = tmStateNotebook ^. lensTMNotebookTabs + let maybeOldPosition = findFL (compareScrolledWinAndTab scrollWin) fl + case maybeOldPosition of + Nothing -> + fail $ + "In setupTermonad, in callback for onNotebookPageReordered, " <> + "the ScrolledWindow is not already in the FocusList.\n" <> + "Don't know how to continue.\n" + Just (oldPos, _) -> do + updateFLTabPos mvarTMState oldPos (fromIntegral pageNum) + relabelTabs mvarTMState + + newTabAction <- simpleActionNew "newtab" Nothing + void $ onSimpleActionActivate newTabAction $ \_ -> void $ createTerm handleKeyPress mvarTMState + actionMapAddAction app newTabAction + applicationSetAccelsForAction app "app.newtab" ["T"] + + closeTabAction <- simpleActionNew "closetab" Nothing + void $ onSimpleActionActivate closeTabAction $ \_ -> + termExitFocused mvarTMState + actionMapAddAction app closeTabAction + applicationSetAccelsForAction app "app.closetab" ["W"] + + quitAction <- simpleActionNew "quit" Nothing + void $ onSimpleActionActivate quitAction $ \_ -> + exitWithConfirmation mvarTMState + actionMapAddAction app quitAction + applicationSetAccelsForAction app "app.quit" ["Q"] + + copyAction <- simpleActionNew "copy" Nothing + void $ onSimpleActionActivate copyAction $ \_ -> do + maybeTerm <- getFocusedTermFromState mvarTMState + maybe (pure ()) terminalCopyClipboard maybeTerm + actionMapAddAction app copyAction + applicationSetAccelsForAction app "app.copy" ["C"] + + pasteAction <- simpleActionNew "paste" Nothing + void $ onSimpleActionActivate pasteAction $ \_ -> do + maybeTerm <- getFocusedTermFromState mvarTMState + maybe (pure ()) terminalPasteClipboard maybeTerm + actionMapAddAction app pasteAction + applicationSetAccelsForAction app "app.paste" ["C"] + + aboutAction <- simpleActionNew "about" Nothing + void $ onSimpleActionActivate aboutAction (const $ showAboutDialog app) + actionMapAddAction app aboutAction + + menuBuilder <- builderNewFromString menuText $ fromIntegral (length menuText) + menuModel <- objFromBuildUnsafe menuBuilder "menubar" MenuModel + applicationSetMenubar app (Just menuModel) + + void $ onWidgetDestroy win $ quit mvarTMState + + widgetShowAll win + widgetGrabFocus $ terminal ^. lensTerm + +appActivate :: TMConfig -> Application -> IO () +appActivate tmConfig app = do + uiBuilder <- + builderNewFromString interfaceText $ fromIntegral (length interfaceText) + builderSetApplication uiBuilder app + appWin <- objFromBuildUnsafe uiBuilder "appWin" ApplicationWindow + applicationAddWindow app appWin + setupTermonad tmConfig app appWin uiBuilder + windowPresent appWin + +showAboutDialog :: Application -> IO () +showAboutDialog app = do + win <- applicationGetActiveWindow app + aboutDialog <- aboutDialogNew + windowSetTransientFor aboutDialog win + void $ dialogRun aboutDialog + widgetDestroy aboutDialog + +appStartup :: Application -> IO () +appStartup _app = pure () + +start :: TMConfig -> IO () +start tmConfig = do + -- app <- appNew (Just "haskell.termonad") [ApplicationFlagsFlagsNone] + -- Make sure the application is not unique, so we can open multiple copies of it. + app <- appNew Nothing [ApplicationFlagsFlagsNone] + void $ onApplicationStartup app (appStartup app) + void $ onApplicationActivate app (appActivate tmConfig app) + void $ applicationRun app Nothing + +defaultMain :: TMConfig -> IO () +defaultMain tmConfig = do + let params = + defaultParams + { projectName = "termonad" + , showError = \(cfg, oldErrs) newErr -> (cfg, oldErrs <> "\n" <> newErr) + , realMain = \(cfg, errs) -> putStrLn (pack errs) *> start cfg + } + wrapMain params (tmConfig, "") diff --git a/src/Termonad/Config.hs b/src/Termonad/Config.hs new file mode 100644 --- /dev/null +++ b/src/Termonad/Config.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Termonad.Config where + +import Termonad.Prelude + +import Control.Lens (makeLensesFor) +import Data.Colour (Colour) +import Data.Colour.Names -- (grey) + +data FontConfig = FontConfig + { fontFamily :: !Text + , fontSize :: !Int + } deriving (Eq, Show) + +$(makeLensesFor + [ ("fontFamily", "lensFontFamily") + , ("fontSize", "lensFontSize") + ] + ''FontConfig + ) + +defaultFontConfig :: FontConfig +defaultFontConfig = + FontConfig + { fontFamily = "Monospace" -- or "DejaVu Sans Mono" or "Bitstream Vera Sans Mono Roman" or "Source Code Pro" + , fontSize = 12 + } + +data ShowScrollbar + = ShowScrollbarNever + | ShowScrollbarAlways + | ShowScrollbarIfNeeded + deriving (Eq, Show) + +data TMConfig = TMConfig + { fontConfig :: !FontConfig + , showScrollbar :: !ShowScrollbar + , cursorColor :: !(Colour Double) + , scrollbackLen :: !Integer + } deriving (Eq, Show) + +$(makeLensesFor + [ ("fontConfig", "lensFontConfig") + , ("showScrollbar", "lensShowScrollbar") + , ("cursorColor", "lensCursorColor") + , ("scrollbackLen", "lensScrollbackLen") + ] + ''TMConfig + ) + +defaultTMConfig :: TMConfig +defaultTMConfig = + TMConfig + { fontConfig = defaultFontConfig + , showScrollbar = ShowScrollbarIfNeeded + , cursorColor = lightgrey + , scrollbackLen = 10000 + } diff --git a/src/Termonad/FocusList.hs b/src/Termonad/FocusList.hs new file mode 100644 --- /dev/null +++ b/src/Termonad/FocusList.hs @@ -0,0 +1,830 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Termonad.FocusList where + +import Termonad.Prelude + +import Control.Lens +import qualified Data.Foldable as Foldable +import Test.QuickCheck +import Text.Show (Show(showsPrec), ShowS, showParen, showString) + +-- $setup +-- >>> :set -XFlexibleContexts +-- >>> :set -XScopedTypeVariables + +data Focus = Focus {-# UNPACK #-} !Int | NoFocus deriving (Eq, Generic, Read, Show) + +-- | 'NoFocus' is always less than 'Focus'. +-- +-- prop> NoFocus < Focus a +instance Ord Focus where + compare :: Focus -> Focus -> Ordering + compare NoFocus NoFocus = EQ + compare NoFocus (Focus _) = LT + compare (Focus _) NoFocus = GT + compare (Focus a) (Focus b) = compare a b + +instance CoArbitrary Focus + +foldFocus :: b -> (Int -> b) -> Focus -> b +foldFocus b _ NoFocus = b +foldFocus _ f (Focus i) = f i + +_Focus :: Prism' Focus Int +_Focus = prism' Focus (foldFocus Nothing Just) + +_NoFocus :: Prism' Focus () +_NoFocus = prism' (const NoFocus) (foldFocus (Just ()) (const Nothing)) + +hasFocus :: Focus -> Bool +hasFocus NoFocus = False +hasFocus (Focus _) = True + +unsafeGetFocus :: Focus -> Int +unsafeGetFocus NoFocus = error "unsafeGetFocus: NoFocus" +unsafeGetFocus (Focus i) = i + +-- TODO: Probably be better +-- implemented as an Order statistic tree +-- (https://en.wikipedia.org/wiki/Order_statistic_tree). +data FocusList a = FocusList + { focusListFocus :: !Focus + , focusListLen :: {-# UNPACK #-} !Int + , focusList :: !(IntMap a) + } deriving (Eq, Generic) + +$(makeLensesFor + [ ("focusListFocus", "lensFocusListFocus") + , ("focusListLen", "lensFocusListLen") + , ("focusList", "lensFocusList") + ] + ''FocusList + ) + +instance Functor FocusList where + fmap :: (a -> b) -> FocusList a -> FocusList b + fmap f (FocusList focus len intmap) = FocusList focus len (fmap f intmap) + +instance Foldable FocusList where + foldr f b (FocusList _ _ intmap) = Foldable.foldr f b intmap + +instance Traversable FocusList where + traverse :: Applicative f => (a -> f b) -> FocusList a -> f (FocusList b) + traverse f (FocusList focus len intmap) = FocusList focus len <$> traverse f intmap + +type instance Element (FocusList a) = a + +instance MonoFunctor (FocusList a) + +instance MonoFoldable (FocusList a) + +instance MonoTraversable (FocusList a) + +instance Arbitrary1 FocusList where + liftArbitrary :: Gen a -> Gen (FocusList a) + liftArbitrary genA = do + arbList <- liftArbitrary genA + case arbList of + [] -> pure emptyFL + (_:_) -> do + let listLen = length arbList + len <- choose (0, listLen - 1) + pure $ unsafeFLFromList (Focus len) arbList + +instance Arbitrary a => Arbitrary (FocusList a) where + arbitrary = arbitrary1 + +instance CoArbitrary a => CoArbitrary (FocusList a) + +debugFL :: Show a => FocusList a -> String +debugFL FocusList{..} = + showString "FocusList {" . + showString "focusListFocus = " . + showsPrec 0 focusListFocus . + showString ", " . + showString "focusListLen = " . + showsPrec 0 focusListLen . + showString ", " . + showString "focusList = " . + showsPrec 0 focusList $ + showString "}" "" + +instance Show a => Show (FocusList a) where + showsPrec :: Int -> FocusList a -> ShowS + showsPrec d FocusList{..} = + let list = fmap snd $ sortOn fst $ mapToList focusList + in + showParen (d > 10) $ + showString "FocusList " . + showsPrec 11 focusListFocus . + showString " " . + showsPrec 11 list + +lensFocusListAt :: Int -> Lens' (FocusList a) (Maybe a) +lensFocusListAt i = lensFocusList . at i + +-- | This is an invariant that the 'FocusList' must always protect. +invariantFL :: FocusList a -> Bool +invariantFL fl = + invariantFocusNotNeg && + invariantFocusInMap && + invariantFocusIfLenGT0 && + invariantLenIsCorrect && + invariantNoSkippedNumsInMap + where + -- This makes sure that the 'Focus' in a 'FocusList' can never be negative. + invariantFocusNotNeg :: Bool + invariantFocusNotNeg = + case fl ^. lensFocusListFocus of + NoFocus -> True + Focus i -> i >= 0 + + -- | This makes sure that if there is a 'Focus', then it actually exists in + -- the 'FocusList'. + invariantFocusInMap :: Bool + invariantFocusInMap = + case fl ^. lensFocusListFocus of + NoFocus -> length (fl ^. lensFocusList) == 0 + Focus i -> + case lookup i (fl ^. lensFocusList) of + Nothing -> False + Just _ -> True + + -- | This makes sure that there needs to be a 'Focus' if the length of the + -- 'FocusList' is greater than 0. + invariantFocusIfLenGT0 :: Bool + invariantFocusIfLenGT0 = + let len = fl ^. lensFocusListLen + focus = fl ^. lensFocusListFocus + in + case focus of + Focus _ -> len /= 0 + NoFocus -> len == 0 + + -- | Make sure that the length of the 'FocusList' is actually the number of + -- elements in the inner 'IntMap'. + invariantLenIsCorrect :: Bool + invariantLenIsCorrect = + let len = fl ^. lensFocusListLen + intmap = fl ^. lensFocusList + in len == length intmap + + -- | Make sure that there are no numbers that have been skipped in the + -- inner 'IntMap'. + invariantNoSkippedNumsInMap :: Bool + invariantNoSkippedNumsInMap = + let len = fl ^. lensFocusListLen + intmap = fl ^. lensFocusList + indexes = sort $ fmap fst $ mapToList intmap + in indexes == [0..(len - 1)] + + +-- | Unsafely create a 'FocusList'. This does not check that the focus +-- actually exists in the list. +-- +-- >>> let fl = unsafeFLFromList (Focus 1) [0..2] +-- >>> debugFL fl +-- "FocusList {focusListFocus = Focus 1, focusListLen = 3, focusList = fromList [(0,0),(1,1),(2,2)]}" +-- +-- >>> let fl = unsafeFLFromList NoFocus [] +-- >>> debugFL fl +-- "FocusList {focusListFocus = NoFocus, focusListLen = 0, focusList = fromList []}" +unsafeFLFromList :: Focus -> [a] -> FocusList a +unsafeFLFromList focus list = + let len = length list + in + FocusList + { focusListFocus = focus + , focusListLen = len + , focusList = mapFromList $ zip [0..] list + } + +focusItemGetter :: Getter (FocusList a) (Maybe a) +focusItemGetter = to getFLFocusItem + +-- | Safely create a 'FocusList' from a list. +-- +-- >>> flFromList (Focus 1) ["cat","dog","goat"] +-- Just (FocusList (Focus 1) ["cat","dog","goat"]) +-- +-- >>> flFromList NoFocus [] +-- Just (FocusList NoFocus []) +-- +-- If the 'Focus' is out of range for the list, then 'Nothing' will be returned. +-- +-- >>> flFromList (Focus (-1)) ["cat","dog","goat"] +-- Nothing +-- +-- >>> flFromList (Focus 3) ["cat","dog","goat"] +-- Nothing +-- +-- >>> flFromList NoFocus ["cat","dog","goat"] +-- Nothing +flFromList :: Focus -> [a] -> Maybe (FocusList a) +flFromList NoFocus [] = Just emptyFL +flFromList _ [] = Nothing +flFromList NoFocus (_:_) = Nothing +flFromList (Focus i) list = + let len = length list + in + if i < 0 || i >= len + then Nothing + else + Just $ + FocusList + { focusListFocus = Focus i + , focusListLen = len + , focusList = mapFromList $ zip [0..] list + } + +-- | Create a 'FocusList' with a single element. +-- +-- >>> singletonFL "hello" +-- FocusList (Focus 0) ["hello"] +singletonFL :: a -> FocusList a +singletonFL a = + FocusList + { focusListFocus = Focus 0 + , focusListLen = 1 + , focusList = singletonMap 0 a + } + +-- | Create an empty 'FocusList' without a 'Focus'. +-- +-- >>> emptyFL +-- FocusList NoFocus [] +emptyFL :: FocusList a +emptyFL = + FocusList + { focusListFocus = NoFocus + , focusListLen = 0 + , focusList = mempty + } + +-- | Return 'True' if the 'FocusList' is empty. +-- +-- >>> isEmptyFL emptyFL +-- True +-- +-- >>> isEmptyFL $ singletonFL "hello" +-- False +-- +-- Any 'FocusList' with a 'Focus' should never be empty. +isEmptyFL :: FocusList a -> Bool +isEmptyFL fl = fl ^. lensFocusListLen == 0 + +-- | Append a value to the end of a 'FocusList'. +-- +-- This can be thought of as a \"snoc\" operation. +-- +-- >>> appendFL emptyFL "hello" +-- FocusList (Focus 0) ["hello"] +-- +-- >>> appendFL (singletonFL "hello") "bye" +-- FocusList (Focus 0) ["hello","bye"] +-- +-- Appending a value to an empty 'FocusList' is the same as using 'singletonFL'. +-- +-- prop> appendFL emptyFL a == singletonFL a +appendFL :: FocusList a -> a -> FocusList a +appendFL fl a = + if isEmptyFL fl + then singletonFL a + else unsafeInsertNewFL (fl ^. lensFocusListLen) a fl + +-- | A combination of 'appendFL' and 'setFocusFL'. +-- +-- >>> let Just fl = flFromList (Focus 1) ["hello", "bye", "tree"] +-- >>> appendSetFocusFL fl "pie" +-- FocusList (Focus 3) ["hello","bye","tree","pie"] +-- +-- prop> (appendSetFocusFL fl a) ^. lensFocusListFocus /= fl ^. lensFocusListFocus +appendSetFocusFL :: FocusList a -> a -> FocusList a +appendSetFocusFL fl a = + let oldLen = fl ^. lensFocusListLen + in + case setFocusFL oldLen (appendFL fl a) of + Nothing -> error "Internal error with setting the focus. This should never happen." + Just newFL -> newFL + +-- | Prepend a value to a 'FocusList'. +-- +-- This can be thought of as a \"cons\" operation. +-- +-- >>> prependFL "hello" emptyFL +-- FocusList (Focus 0) ["hello"] +-- +-- The focus will be updated when prepending: +-- +-- >>> prependFL "bye" (singletonFL "hello") +-- FocusList (Focus 1) ["bye","hello"] +-- +-- Prepending to a 'FocusList' will always update the 'Focus': +-- +-- prop> (fl ^. lensFocusListFocus) < (prependFL a fl ^. lensFocusListFocus) +prependFL :: a -> FocusList a -> FocusList a +prependFL a fl = + if isEmptyFL fl + then singletonFL a + else unsafeInsertNewFL 0 a $ unsafeShiftUpFrom 0 fl + +-- | Unsafely get the 'Focus' from a 'FocusList'. If the 'Focus' is +-- 'NoFocus', this function returns 'error'. +unsafeGetFLFocus :: FocusList a -> Int +unsafeGetFLFocus fl = + let focus = fl ^. lensFocusListFocus + in + case focus of + NoFocus -> error "unsafeGetFLFocus: the focus list doesn't have a focus" + Focus i -> i + +-- | Unsafely get the value of the 'Focus' from a 'FocusList'. If the 'Focus' is +-- 'NoFocus', this function returns 'error'. +unsafeGetFLFocusItem :: FocusList a -> a +unsafeGetFLFocusItem fl = + let focus = fl ^. lensFocusListFocus + in + case focus of + NoFocus -> error "unsafeGetFLFocusItem: the focus list doesn't have a focus" + Focus i -> + let intmap = fl ^. lensFocusList + in + case lookup i intmap of + Nothing -> + error $ + "unsafeGetFLFocusItem: internal error, i (" <> + show i <> + ") doesnt exist in intmap" + Just a -> a + +getFLFocusItem :: FocusList a -> Maybe a +getFLFocusItem fl = + let focus = fl ^. lensFocusListFocus + in + case focus of + NoFocus -> Nothing + Focus i -> + let intmap = fl ^. lensFocusList + in + case lookup i intmap of + Nothing -> + error $ + "getFLFocusItem: internal error, i (" <> + show i <> + ") doesnt exist in intmap" + Just a -> Just a + +-- | Unsafely insert a new @a@ in a 'FocusList'. This sets the 'Int' value to +-- @a@. The length of the 'FocusList' will be increased by 1. The +-- 'FocusList's 'Focus' is not changed. +-- +-- If there is some value in the 'FocusList' already at the 'Int', then it will +-- be overwritten. Also, the 'Int' is not checked to make sure it is above 0. +-- +-- This function is meant to be used after 'unsafeShiftUpFrom'. +-- +-- >>> let fl = unsafeShiftUpFrom 2 $ unsafeFLFromList (Focus 1) [0,1,200] +-- >>> debugFL $ unsafeInsertNewFL 2 100 fl +-- "FocusList {focusListFocus = Focus 1, focusListLen = 4, focusList = fromList [(0,0),(1,1),(2,100),(3,200)]}" +-- +-- >>> let fl = unsafeFLFromList NoFocus [] +-- >>> debugFL $ unsafeInsertNewFL 0 100 fl +-- "FocusList {focusListFocus = NoFocus, focusListLen = 1, focusList = fromList [(0,100)]}" +unsafeInsertNewFL :: Int -> a -> FocusList a -> FocusList a +unsafeInsertNewFL i a fl = + fl & + lensFocusListLen +~ 1 & + lensFocusListAt i ?~ a + +-- | This unsafely shifts all values up in a 'FocusList' starting at a given +-- index. It also updates the 'Focus' of the 'FocusList' if it has been +-- shifted. This does not change the length of the 'FocusList'. +-- +-- It does not check that the 'Int' is greater than 0. It also does not check +-- that there is a 'Focus'. +-- +-- ==== __EXAMPLES__ +-- +-- >>> let fl = unsafeShiftUpFrom 2 $ unsafeFLFromList (Focus 1) [0,1,200] +-- >>> debugFL fl +-- "FocusList {focusListFocus = Focus 1, focusListLen = 3, focusList = fromList [(0,0),(1,1),(3,200)]}" +-- +-- >>> let fl = unsafeShiftUpFrom 1 $ unsafeFLFromList (Focus 1) [0,1,200] +-- >>> debugFL fl +-- "FocusList {focusListFocus = Focus 2, focusListLen = 3, focusList = fromList [(0,0),(2,1),(3,200)]}" +-- +-- >>> let fl = unsafeShiftUpFrom 0 $ unsafeFLFromList (Focus 1) [0,1,200] +-- >>> debugFL fl +-- "FocusList {focusListFocus = Focus 2, focusListLen = 3, focusList = fromList [(1,0),(2,1),(3,200)]}" +-- +-- >>> let fl = unsafeShiftUpFrom 0 $ unsafeFLFromList (Focus 1) [0,1,200] +-- >>> debugFL fl +-- "FocusList {focusListFocus = Focus 2, focusListLen = 3, focusList = fromList [(1,0),(2,1),(3,200)]}" +unsafeShiftUpFrom :: forall a. Int -> FocusList a -> FocusList a +unsafeShiftUpFrom i fl = + let intMap = fl ^. lensFocusList + lastElemIdx = (fl ^. lensFocusListLen) - 1 + newIntMap = go i lastElemIdx intMap + oldFocus = unsafeGetFLFocus fl + newFocus = if i > oldFocus then oldFocus else oldFocus + 1 + in + fl & + lensFocusList .~ newIntMap & + lensFocusListFocus .~ Focus newFocus + where + go :: Int -> Int -> IntMap a -> IntMap a + go idxToInsert idxToShiftUp intMap + | idxToInsert <= idxToShiftUp = + let val = unsafeLookup idxToShiftUp intMap + newMap = + insertMap (idxToShiftUp + 1) val (deleteMap idxToShiftUp intMap) + in go idxToInsert (idxToShiftUp - 1) newMap + | otherwise = intMap + +-- | This is an unsafe lookup function. This assumes that the 'Int' exists in +-- the 'IntMap'. +unsafeLookup :: Int -> IntMap a -> a +unsafeLookup i intmap = + case lookup i intmap of + Nothing -> error $ "unsafeLookup: key " <> show i <> " not found in intmap" + Just a -> a + +lookupFL :: Int -> FocusList a -> Maybe a +lookupFL i fl = lookup i (fl ^. lensFocusList) + +-- | Insert a new value into the 'FocusList'. The 'Focus' of the list is +-- changed appropriately. +-- +-- >>> insertFL 0 "hello" emptyFL +-- Just (FocusList (Focus 0) ["hello"]) +-- +-- >>> insertFL 0 "hello" (singletonFL "bye") +-- Just (FocusList (Focus 1) ["hello","bye"]) +-- +-- >>> insertFL 1 "hello" (singletonFL "bye") +-- Just (FocusList (Focus 0) ["bye","hello"]) +-- +-- This returns 'Nothing' if the index at which to insert the new value is +-- either less than 0 or greater than the length of the list. +-- +-- >>> insertFL 100 "hello" emptyFL +-- Nothing +-- +-- >>> insertFL 100 "bye" (singletonFL "hello") +-- Nothing +-- +-- >>> insertFL (-1) "bye" (singletonFL "hello") +-- Nothing +insertFL + :: Int -- ^ The index at which to insert the value. + -> a + -> FocusList a + -> Maybe (FocusList a) +insertFL i a fl + | i < 0 || i > (fl ^. lensFocusListLen) = + -- Return Nothing if the insertion position is out of bounds. + Nothing + | i == 0 && isEmptyFL fl = + -- Return a 'FocusList' with one element if the insertion position is 0 + -- and the 'FocusList' is empty. + Just $ singletonFL a + | otherwise = + -- Shift all existing values up one and insert the new + -- value in the opened place. + let shiftedUpFL = unsafeShiftUpFrom i fl + in Just $ unsafeInsertNewFL i a shiftedUpFL + +-- | Unsafely remove a value from a 'FocusList'. It effectively leaves a hole +-- inside the 'FocusList'. It updates the length of the 'FocusList'. +-- +-- This function does not check that a value actually exists in the +-- 'FocusList'. It also does not update the 'Focus'. +-- +-- This function does update the length of the 'FocusList'. +-- +-- >>> debugFL $ unsafeRemove 1 $ unsafeFLFromList (Focus 0) [0..2] +-- "FocusList {focusListFocus = Focus 0, focusListLen = 2, focusList = fromList [(0,0),(2,2)]}" +-- +-- >>> debugFL $ unsafeRemove 0 $ unsafeFLFromList (Focus 0) [0..2] +-- "FocusList {focusListFocus = Focus 0, focusListLen = 2, focusList = fromList [(1,1),(2,2)]}" +-- +-- Trying to remove the last element is completely safe (unless, of course, it +-- is the 'Focus'): +-- +-- >>> debugFL $ unsafeRemove 2 $ unsafeFLFromList (Focus 2) [0..2] +-- "FocusList {focusListFocus = Focus 2, focusListLen = 2, focusList = fromList [(0,0),(1,1)]}" +-- +-- If this function is passed an empty 'FocusList', it will make the length -1. +-- +-- >>> debugFL $ unsafeRemove 0 emptyFL +-- "FocusList {focusListFocus = NoFocus, focusListLen = -1, focusList = fromList []}" +unsafeRemove + :: Int + -> FocusList a + -> FocusList a +unsafeRemove i fl = + fl & + lensFocusListLen -~ 1 & + lensFocusListAt i .~ Nothing + +-- | This shifts all the values down in a 'FocusList' starting at a given +-- index. It does not change the 'Focus' of the 'FocusList'. It does not change the +-- length of the 'FocusList'. +-- +-- It does not check that shifting elements down will not overwrite other elements. +-- This function is meant to be called after 'unsafeRemove'. +-- +-- >>> let fl = unsafeRemove 1 $ unsafeFLFromList (Focus 0) [0..2] +-- >>> debugFL $ unsafeShiftDownFrom 1 fl +-- "FocusList {focusListFocus = Focus 0, focusListLen = 2, focusList = fromList [(0,0),(1,2)]}" +-- +-- >>> let fl = unsafeRemove 0 $ unsafeFLFromList (Focus 0) [0..2] +-- >>> debugFL $ unsafeShiftDownFrom 0 fl +-- "FocusList {focusListFocus = Focus 0, focusListLen = 2, focusList = fromList [(0,1),(1,2)]}" +-- +-- Trying to shift down from the last element after it has been removed is a no-op: +-- +-- >>> let fl = unsafeRemove 2 $ unsafeFLFromList (Focus 0) [0..2] +-- >>> debugFL $ unsafeShiftDownFrom 2 fl +-- "FocusList {focusListFocus = Focus 0, focusListLen = 2, focusList = fromList [(0,0),(1,1)]}" +unsafeShiftDownFrom :: forall a. Int -> FocusList a -> FocusList a +unsafeShiftDownFrom i fl = + let intMap = fl ^. lensFocusList + len = fl ^. lensFocusListLen + newIntMap = go (i + 1) len intMap + in fl & lensFocusList .~ newIntMap + where + go :: Int -> Int -> IntMap a -> IntMap a + go idxToShiftDown len intMap + | idxToShiftDown < len + 1 = + let val = unsafeLookup idxToShiftDown intMap + newMap = + insertMap (idxToShiftDown - 1) val (deleteMap idxToShiftDown intMap) + in go (idxToShiftDown + 1) len newMap + | otherwise = intMap + +-- | Remove an element from a 'FocusList'. +-- +-- If the element to remove is not the 'Focus', then update the 'Focus' +-- accordingly. +-- +-- For example, if the 'Focus' is on index 1, and we have removed index 2, then +-- the focus is not affected, so it is not changed. +-- +-- >>> let focusList = unsafeFLFromList (Focus 1) ["cat","goat","dog","hello"] +-- >>> removeFL 2 focusList +-- Just (FocusList (Focus 1) ["cat","goat","hello"]) +-- +-- If the 'Focus' is on index 2 and we have removed index 1, then the 'Focus' +-- will be moved back one element to set to index 1. +-- +-- >>> let focusList = unsafeFLFromList (Focus 2) ["cat","goat","dog","hello"] +-- >>> removeFL 1 focusList +-- Just (FocusList (Focus 1) ["cat","dog","hello"]) +-- +-- If we remove the 'Focus', then the next item is set to have the 'Focus'. +-- +-- >>> let focusList = unsafeFLFromList (Focus 0) ["cat","goat","dog","hello"] +-- >>> removeFL 0 focusList +-- Just (FocusList (Focus 0) ["goat","dog","hello"]) +-- +-- If the element to remove is the only element in the list, then the 'Focus' +-- will be set to 'NoFocus'. +-- +-- >>> let focusList = unsafeFLFromList (Focus 0) ["hello"] +-- >>> removeFL 0 focusList +-- Just (FocusList NoFocus []) +-- +-- If the 'Int' for the index to remove is either less than 0 or greater then +-- the length of the list, then 'Nothing' is returned. +-- +-- >>> let focusList = unsafeFLFromList (Focus 0) ["hello"] +-- >>> removeFL (-1) focusList +-- Nothing +-- +-- >>> let focusList = unsafeFLFromList (Focus 1) ["hello","bye","cat"] +-- >>> removeFL 3 focusList +-- Nothing +-- +-- If the 'FocusList' passed in is 'Empty', then 'Nothing' is returned. +-- +-- >>> removeFL 0 emptyFL +-- Nothing +removeFL + :: Int -- ^ Index of the element to remove from the 'FocusList'. + -> FocusList a -- ^ The 'FocusList' to remove an element from. + -> Maybe (FocusList a) +removeFL i fl + | i < 0 || i >= (fl ^. lensFocusListLen) || isEmptyFL fl = + -- Return Nothing if the removal position is out of bounds. + Nothing + | fl ^. lensFocusListLen == 1 = + -- Return an empty focus list if there is currently only one element + Just emptyFL + | otherwise = + let newFLWithHole = unsafeRemove i fl + newFL = unsafeShiftDownFrom i newFLWithHole + focus = unsafeGetFLFocus fl + in + if focus >= i && focus /= 0 + then Just $ newFL & lensFocusListFocus . _Focus -~ 1 + else Just newFL + +-- | Find the index of the first element in the 'FocusList'. +-- +-- >>> let Just fl = flFromList (Focus 1) ["hello", "bye", "tree"] +-- >>> indexOfFL "hello" fl +-- Just 0 +-- +-- If more than one element exists, then return the index of the first one. +-- +-- >>> let Just fl = flFromList (Focus 1) ["dog", "cat", "cat"] +-- >>> indexOfFL "cat" fl +-- Just 1 +-- +-- If the element doesn't exist, then return 'Nothing' +-- +-- >>> let Just fl = flFromList (Focus 1) ["foo", "bar", "baz"] +-- >>> indexOfFL "hogehoge" fl +-- Nothing +indexOfFL :: Eq a => a -> FocusList a -> Maybe Int +indexOfFL a fl = + let intmap = focusList fl + keyVals = sortOn fst $ mapToList intmap + maybeKeyVal = find (\(_, val) -> val == a) keyVals + in fmap fst maybeKeyVal + +-- | Delete an element from a 'FocusList'. +-- +-- >>> let Just fl = flFromList (Focus 0) ["hello", "bye", "tree"] +-- >>> deleteFL "bye" fl +-- FocusList (Focus 0) ["hello","tree"] +-- +-- The focus will be updated if an item before it is deleted. +-- +-- >>> let Just fl = flFromList (Focus 1) ["hello", "bye", "tree"] +-- >>> deleteFL "hello" fl +-- FocusList (Focus 0) ["bye","tree"] +-- +-- If there are multiple matching elements in the 'FocusList', remove them all. +-- +-- >>> let Just fl = flFromList (Focus 0) ["hello", "bye", "bye"] +-- >>> deleteFL "bye" fl +-- FocusList (Focus 0) ["hello"] +-- +-- If there are no matching elements, return the original 'FocusList'. +-- +-- >>> let Just fl = flFromList (Focus 2) ["hello", "good", "bye"] +-- >>> deleteFL "frog" fl +-- FocusList (Focus 2) ["hello","good","bye"] +deleteFL + :: forall a. + (Eq a) + => a + -> FocusList a + -> FocusList a +deleteFL item = go + where + go :: FocusList a -> FocusList a + go fl = + let maybeIndex = indexOfFL item fl + in + case maybeIndex of + Nothing -> fl + Just i -> + let maybeNewFL = removeFL i fl + in + case maybeNewFL of + Nothing -> fl + Just newFL -> go newFL + +-- | Set the 'Focus' for a 'FocusList'. +-- +-- This is just like 'updateFocusFL', but doesn't return the new focused item. +-- +-- prop> setFocusFL i fl == fmap snd (updateFocusFL i fl) +setFocusFL :: Int -> FocusList a -> Maybe (FocusList a) +setFocusFL i fl + -- Can't set a 'Focus' for an empty 'FocusList'. + | isEmptyFL fl = Nothing + | otherwise = + let len = fl ^. lensFocusListLen + in + if i < 0 || i >= len + then Nothing + else Just $ fl & lensFocusListFocus . _Focus .~ i + +-- | Update the 'Focus' for a 'FocusList' and get the new focused element. +-- +-- >>> updateFocusFL 1 =<< flFromList (Focus 2) ["hello","bye","dog","cat"] +-- Just ("bye",FocusList (Focus 1) ["hello","bye","dog","cat"]) +-- +-- If the 'FocusList' is empty, then return 'Nothing'. +-- +-- >>> updateFocusFL 1 emptyFL +-- Nothing +-- +-- If the new focus is less than 0, or greater than or equal to the length of +-- the 'FocusList', then return 'Nothing'. +-- +-- >>> updateFocusFL (-1) =<< flFromList (Focus 2) ["hello","bye","dog","cat"] +-- Nothing +-- +-- >>> updateFocusFL 4 =<< flFromList (Focus 2) ["hello","bye","dog","cat"] +-- Nothing +updateFocusFL :: Int -> FocusList a -> Maybe (a, FocusList a) +updateFocusFL i fl + | isEmptyFL fl = Nothing + | otherwise = + let len = fl ^. lensFocusListLen + in + if i < 0 || i >= len + then Nothing + else + let newFL = fl & lensFocusListFocus . _Focus .~ i + in Just (unsafeGetFLFocusItem newFL, newFL) + +-- | Find a value in a 'FocusList'. Similar to @Data.List.'Data.List.find'@. +-- +-- >>> let Just fl = flFromList (Focus 1) ["hello", "bye", "tree"] +-- >>> findFL (\_ a -> a == "hello") fl +-- Just (0,"hello") +-- +-- This will only find the first value. +-- +-- >>> let Just fl = flFromList (Focus 0) ["hello", "bye", "bye"] +-- >>> findFL (\_ a -> a == "bye") fl +-- Just (1,"bye") +-- +-- If no values match the comparison, this will return 'Nothing'. +-- +-- >>> let Just fl = flFromList (Focus 1) ["hello", "bye", "parrot"] +-- >>> findFL (\_ a -> a == "ball") fl +-- Nothing +findFL :: (Int -> a -> Bool) -> FocusList a -> Maybe (Int, a) +findFL f fl = + let intmap = fl ^. lensFocusList + vals = sortOn fst $ mapToList intmap + in find (\(i, a) -> f i a) vals + + +-- | Move an existing item in a 'FocusList' to a new index. +-- +-- The 'Focus' gets updated appropriately when moving items. +-- +-- >>> let Just fl = flFromList (Focus 1) ["hello", "bye", "parrot"] +-- >>> moveFromToFL 0 1 fl +-- Just (FocusList (Focus 0) ["bye","hello","parrot"]) +-- +-- The 'Focus' may not get updated if it is not involved. +-- +-- >>> let Just fl = flFromList (Focus 0) ["hello", "bye", "parrot"] +-- >>> moveFromToFL 1 2 fl +-- Just (FocusList (Focus 0) ["hello","parrot","bye"]) +-- +-- If the element with the 'Focus' is moved, then the 'Focus' will be updated appropriately. +-- +-- >>> let Just fl = flFromList (Focus 2) ["hello", "bye", "parrot"] +-- >>> moveFromToFL 2 0 fl +-- Just (FocusList (Focus 0) ["parrot","hello","bye"]) +-- +-- If the index of the item to move is out bounds, then 'Nothing' will be returned. +-- +-- >>> let Just fl = flFromList (Focus 2) ["hello", "bye", "parrot"] +-- >>> moveFromToFL 3 0 fl +-- Nothing +-- +-- If the new index is out of bounds, then 'Nothing' wil be returned. +-- +-- >>> let Just fl = flFromList (Focus 2) ["hello", "bye", "parrot"] +-- >>> moveFromToFL 1 (-1) fl +-- Nothing +moveFromToFL + :: Show a => Int -- ^ Index of the item to move. + -> Int -- ^ New index for the item. + -> FocusList a + -> Maybe (FocusList a) +moveFromToFL oldPos newPos fl + | oldPos < 0 || oldPos >= length fl = Nothing + | newPos < 0 || newPos >= length fl = Nothing + | otherwise = + let oldFocus = fl ^. lensFocusListFocus + in + case lookupFL oldPos fl of + Nothing -> error "moveFromToFL should have been able to lookup the item" + Just item -> + case removeFL oldPos fl of + Nothing -> error "moveFromToFL should have been able to remove old position" + Just flAfterRemove -> + case insertFL newPos item flAfterRemove of + Nothing -> error "moveFromToFL should have been able to reinsert the item" + Just flAfterInsert -> + if Focus oldPos == oldFocus + then + case setFocusFL newPos flAfterInsert of + Nothing -> error "moveFromToFL should have been able to reset the focus" + Just flWithUpdatedFocus -> Just flWithUpdatedFocus + else Just flAfterInsert diff --git a/src/Termonad/Gtk.hs b/src/Termonad/Gtk.hs new file mode 100644 --- /dev/null +++ b/src/Termonad/Gtk.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE CPP #-} + +module Termonad.Gtk where + +import Termonad.Prelude + +import GHC.Stack (HasCallStack) +import GI.Gdk + ( GObject + , ManagedPtr + , castTo + ) +import GI.Gio (ApplicationFlags) +import GI.Gtk (Application, applicationNew, builderGetObject) +import qualified GI.Gtk as Gtk + + +objFromBuildUnsafe :: + GObject o => Gtk.Builder -> Text -> (ManagedPtr o -> o) -> IO o +objFromBuildUnsafe builder name constructor = do + maybePlainObj <- builderGetObject builder name + case maybePlainObj of + Nothing -> error $ "Couldn't get " <> unpack name <> " from builder!" + Just plainObj -> do + maybeNewObj <- castTo constructor plainObj + case maybeNewObj of + Nothing -> + error $ + "Got " <> + unpack name <> + " from builder, but couldn't convert to object!" + Just obj -> pure obj + +appNew :: (HasCallStack, MonadIO m) => Maybe Text -> [ApplicationFlags] -> m Application +appNew appName appFlags = do + maybeApp <- applicationNew appName appFlags + case maybeApp of + Nothing -> fail "Could not create application for some reason!" + Just app -> pure app diff --git a/src/Termonad/Keys.hs b/src/Termonad/Keys.hs new file mode 100644 --- /dev/null +++ b/src/Termonad/Keys.hs @@ -0,0 +1,96 @@ + +module Termonad.Keys where + +import Termonad.Prelude + +import Control.Lens (imap) +import GI.Gdk + ( EventKey + , 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(..) + , getEventKeyKeyval + , getEventKeyState + ) + +import Termonad.Term (altNumSwitchTerm) +import Termonad.Types (TMState) + + +-- showKeys :: EventKey -> IO Bool +-- showKeys eventKey = do +-- eventType <- get eventKey #type +-- maybeString <- get eventKey #string +-- modifiers <- get eventKey #state +-- len <- get eventKey #length +-- keyval <- get eventKey #keyval +-- isMod <- get eventKey #isModifier +-- keycode <- get eventKey #hardwareKeycode + +-- putStrLn "key press event:" +-- putStrLn $ " type = " <> tshow eventType +-- putStrLn $ " str = " <> tshow maybeString +-- putStrLn $ " mods = " <> tshow modifiers +-- putStrLn $ " isMod = " <> tshow isMod +-- putStrLn $ " len = " <> tshow len +-- putStrLn $ " keyval = " <> tshow keyval +-- putStrLn $ " keycode = " <> tshow keycode +-- putStrLn "" + +-- pure True + +data Key = Key + { keyVal :: Word32 + , keyMods :: Set ModifierType + } deriving (Eq, Ord, Show) + +toKey :: Word32 -> Set ModifierType -> Key +toKey = Key + +keyMap :: Map Key (TMState -> IO Bool) +keyMap = + let numKeys = + [ KEY_1 + , KEY_2 + , KEY_3 + , KEY_4 + , KEY_5 + , KEY_6 + , KEY_7 + , KEY_8 + , KEY_9 + ] + altNumKeys = + imap + (\i k -> + (toKey k [ModifierTypeMod1Mask], stopProp (altNumSwitchTerm i)) + ) + numKeys + in + mapFromList $ + -- [ ( toKey KEY_T [ModifierTypeControlMask, ModifierTypeShiftMask] + -- , stopProp createTerm + -- ) + -- ] <> + altNumKeys + +stopProp :: (TMState -> IO a) -> TMState -> IO Bool +stopProp callback terState = callback terState $> True + +handleKeyPress :: TMState -> EventKey -> IO Bool +handleKeyPress terState eventKey = do + -- keyval <- get eventKey #keyval + keyval <- getEventKeyKeyval eventKey + modifiers <- getEventKeyState eventKey + let key = toKey keyval (setFromList modifiers) + maybeAction = lookup key keyMap + case maybeAction of + Just action -> action terState + Nothing -> pure False diff --git a/src/Termonad/Prelude.hs b/src/Termonad/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Termonad/Prelude.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Termonad.Prelude + ( module X + ) where + +import ClassyPrelude as X +import Data.Proxy as X diff --git a/src/Termonad/Term.hs b/src/Termonad/Term.hs new file mode 100644 --- /dev/null +++ b/src/Termonad/Term.hs @@ -0,0 +1,284 @@ +{-# LANGUAGE CPP #-} + +module Termonad.Term where + +import Termonad.Prelude + +import Control.Lens ((^.), (&), (.~), set, to) +import Data.Colour.SRGB (RGB(RGB), toSRGB) +import GI.Gdk + ( EventKey + , RGBA + , newZeroRGBA + , setRGBABlue + , setRGBAGreen + , setRGBARed + ) +import GI.Gio + ( noCancellable + ) +import GI.GLib + ( SpawnFlags(SpawnFlagsDefault) + ) +import GI.Gtk + ( Align(AlignFill) + , Box + , Button + , IconSize(IconSizeMenu) + , Label + , Notebook + , Orientation(OrientationHorizontal) + , PolicyType(PolicyTypeAlways, PolicyTypeAutomatic, PolicyTypeNever) + , ReliefStyle(ReliefStyleNone) + , ResponseType(ResponseTypeNo, ResponseTypeYes) + , ScrolledWindow + , applicationGetActiveWindow + , boxNew + , buttonNewFromIconName + , buttonSetRelief + , containerAdd + , dialogAddButton + , dialogGetContentArea + , dialogNew + , dialogRun + , labelNew + , labelSetEllipsize + , labelSetLabel + , labelSetMaxWidthChars + , noAdjustment + , notebookAppendPage + , notebookDetachTab + , notebookPageNum + , notebookSetCurrentPage + , notebookSetTabReorderable + , onButtonClicked + , onWidgetKeyPressEvent + , scrolledWindowNew + , scrolledWindowSetPolicy + , setWidgetMargin + , widgetDestroy + , widgetGrabFocus + , widgetSetCanFocus + , widgetSetHalign + , widgetSetHexpand + , widgetShow + , windowSetTransientFor + ) +import GI.Pango (EllipsizeMode(EllipsizeModeMiddle)) +import GI.Vte + ( CursorBlinkMode(CursorBlinkModeOn) + , PtyFlags(PtyFlagsDefault) + , Terminal + , onTerminalChildExited + , onTerminalWindowTitleChanged + , terminalGetWindowTitle + , terminalNew + , terminalSetCursorBlinkMode + , terminalSetColorCursor + , terminalSetFont + , terminalSetScrollbackLines + , terminalSpawnSync + ) + +import Termonad.Config (ShowScrollbar(..), TMConfig(cursorColor, scrollbackLen), lensShowScrollbar) +import Termonad.FocusList (appendFL, deleteFL, getFLFocusItem) +import Termonad.Types + ( TMNotebookTab + , TMState + , TMState'(TMState, tmStateConfig, tmStateFontDesc, tmStateNotebook) + , TMTerm + , createTMNotebookTab + , lensTerm + , lensTMNotebookTabLabel + , lensTMNotebookTabs + , lensTMNotebookTabTerm + , lensTMNotebookTabTermContainer + , lensTMStateApp + , lensTMStateConfig + , lensTMStateNotebook + , newTMTerm + , tmNotebook + , tmNotebookTabs + , tmNotebookTabTermContainer + ) + +focusTerm :: Int -> TMState -> IO () +focusTerm i mvarTMState = do + note <- tmNotebook . tmStateNotebook <$> readMVar mvarTMState + notebookSetCurrentPage note (fromIntegral i) + +altNumSwitchTerm :: Int -> TMState -> IO () +altNumSwitchTerm = focusTerm + +termExitFocused :: TMState -> IO () +termExitFocused mvarTMState = do + tmState <- readMVar mvarTMState + let maybeTab = + tmState ^. lensTMStateNotebook . lensTMNotebookTabs . to getFLFocusItem + case maybeTab of + Nothing -> pure () + Just tab -> termExitWithConfirmation tab mvarTMState + +termExitWithConfirmation :: TMNotebookTab -> TMState -> IO () +termExitWithConfirmation tab mvarTMState = do + tmState <- readMVar mvarTMState + let app = tmState ^. lensTMStateApp + win <- applicationGetActiveWindow app + dialog <- dialogNew + box <- dialogGetContentArea dialog + label <- labelNew (Just "Close tab?") + containerAdd box label + widgetShow label + setWidgetMargin label 10 + void $ + dialogAddButton + dialog + "No, do NOT close tab" + (fromIntegral (fromEnum ResponseTypeNo)) + void $ + dialogAddButton + dialog + "Yes, close tab" + (fromIntegral (fromEnum ResponseTypeYes)) + windowSetTransientFor dialog win + res <- dialogRun dialog + widgetDestroy dialog + case toEnum (fromIntegral res) of + ResponseTypeYes -> termExit tab mvarTMState + _ -> pure () + +termExit :: TMNotebookTab -> TMState -> IO () +termExit tab mvarTMState = do + detachTabAction <- + modifyMVar mvarTMState $ \tmState -> do + let notebook = tmStateNotebook tmState + detachTabAction = + notebookDetachTab + (tmNotebook notebook) + (tmNotebookTabTermContainer tab) + let newTabs = deleteFL tab (tmNotebookTabs notebook) + let newTMState = + set (lensTMStateNotebook . lensTMNotebookTabs) newTabs tmState + pure (newTMState, detachTabAction) + detachTabAction + relabelTabs mvarTMState + +relabelTabs :: TMState -> IO () +relabelTabs mvarTMState = do + TMState{tmStateNotebook} <- readMVar mvarTMState + let notebook = tmNotebook tmStateNotebook + tabFocusList = tmNotebookTabs tmStateNotebook + foldMap (go notebook) tabFocusList + where + go :: Notebook -> TMNotebookTab -> IO () + go notebook tmNotebookTab = do + let label = tmNotebookTab ^. lensTMNotebookTabLabel + scrolledWin = tmNotebookTab ^. lensTMNotebookTabTermContainer + term = tmNotebookTab ^. lensTMNotebookTabTerm . lensTerm + relabelTab notebook label scrolledWin term + +relabelTab :: Notebook -> Label -> ScrolledWindow -> Terminal -> IO () +relabelTab notebook label scrolledWin term = do + pageNum <- notebookPageNum notebook scrolledWin + title <- terminalGetWindowTitle term + labelSetLabel label $ tshow (pageNum + 1) <> ". " <> title + +showScrollbarToPolicy :: ShowScrollbar -> PolicyType +showScrollbarToPolicy ShowScrollbarNever = PolicyTypeNever +showScrollbarToPolicy ShowScrollbarIfNeeded = PolicyTypeAutomatic +showScrollbarToPolicy ShowScrollbarAlways = PolicyTypeAlways + +createScrolledWin :: TMState -> IO ScrolledWindow +createScrolledWin mvarTMState = do + tmState <- readMVar mvarTMState + let showScrollbarVal = tmState ^. lensTMStateConfig . lensShowScrollbar + vScrollbarPolicy = showScrollbarToPolicy showScrollbarVal + scrolledWin <- scrolledWindowNew noAdjustment noAdjustment + widgetShow scrolledWin + scrolledWindowSetPolicy scrolledWin PolicyTypeAutomatic vScrollbarPolicy + pure scrolledWin + +createNotebookTabLabel :: IO (Box, Label, Button) +createNotebookTabLabel = do + box <- boxNew OrientationHorizontal 5 + label <- labelNew (Just "") + labelSetEllipsize label EllipsizeModeMiddle + labelSetMaxWidthChars label 10 + widgetSetHexpand label True + widgetSetHalign label AlignFill + button <- + buttonNewFromIconName + (Just "window-close") + (fromIntegral (fromEnum IconSizeMenu)) + buttonSetRelief button ReliefStyleNone + containerAdd box label + containerAdd box button + widgetSetCanFocus button False + widgetSetCanFocus label False + widgetSetCanFocus box False + widgetShow box + widgetShow label + widgetShow button + pure (box, label, button) + +getCursorColor :: TMConfig -> IO RGBA +getCursorColor tmConfig = do + let color = cursorColor tmConfig + RGB red green blue = toSRGB color + rgba <- newZeroRGBA + setRGBARed rgba red + setRGBAGreen rgba green + setRGBABlue rgba blue + pure rgba + +createTerm :: (TMState -> EventKey -> IO Bool) -> TMState -> IO TMTerm +createTerm handleKeyPress mvarTMState = do + scrolledWin <- createScrolledWin mvarTMState + TMState{tmStateFontDesc, tmStateConfig} <- readMVar mvarTMState + vteTerm <- terminalNew + terminalSetFont vteTerm (Just tmStateFontDesc) + terminalSetScrollbackLines vteTerm (fromIntegral (scrollbackLen tmStateConfig)) + cursorColor <- getCursorColor tmStateConfig + terminalSetColorCursor vteTerm (Just cursorColor) + terminalSetCursorBlinkMode vteTerm CursorBlinkModeOn + widgetShow vteTerm + widgetGrabFocus $ vteTerm + _termResVal <- + terminalSpawnSync + vteTerm + [PtyFlagsDefault] + Nothing + ["/usr/bin/env", "bash"] + Nothing + ([SpawnFlagsDefault] :: [SpawnFlags]) + Nothing + noCancellable + tmTerm <- newTMTerm vteTerm + containerAdd scrolledWin vteTerm + (tabLabelBox, tabLabel, tabCloseButton) <- createNotebookTabLabel + let notebookTab = createTMNotebookTab tabLabel scrolledWin tmTerm + void $ + onButtonClicked tabCloseButton $ + termExitWithConfirmation notebookTab mvarTMState + setCurrPageAction <- + modifyMVar mvarTMState $ \tmState -> do + let notebook = tmStateNotebook tmState + note = tmNotebook notebook + tabs = tmNotebookTabs notebook + pageIndex <- notebookAppendPage note scrolledWin (Just tabLabelBox) + notebookSetTabReorderable note scrolledWin True + let newTabs = appendFL tabs notebookTab + newTMState = + tmState & lensTMStateNotebook . lensTMNotebookTabs .~ newTabs + setCurrPageAction = do + notebookSetCurrentPage note pageIndex + pure (newTMState, setCurrPageAction) + setCurrPageAction + void $ onTerminalWindowTitleChanged vteTerm $ do + TMState{tmStateNotebook} <- readMVar mvarTMState + let notebook = tmNotebook tmStateNotebook + relabelTab notebook tabLabel scrolledWin vteTerm + void $ onWidgetKeyPressEvent vteTerm $ handleKeyPress mvarTMState + void $ onWidgetKeyPressEvent scrolledWin $ handleKeyPress mvarTMState + void $ onTerminalChildExited vteTerm $ \_ -> termExit notebookTab mvarTMState + pure tmTerm diff --git a/src/Termonad/Types.hs b/src/Termonad/Types.hs new file mode 100644 --- /dev/null +++ b/src/Termonad/Types.hs @@ -0,0 +1,242 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Termonad.Types where + +import Termonad.Prelude + +import Control.Lens (firstOf, makeLensesFor) +import Data.Unique (Unique, hashUnique, newUnique) +import GI.Gtk + ( Application + , ApplicationWindow + , Label + , Notebook + , ScrolledWindow + ) +import GI.Pango (FontDescription) +import GI.Vte (Terminal) +import Text.Pretty.Simple (pPrint) +import Text.Show (Show(showsPrec), ShowS, showParen, showString) + +import Termonad.Config (TMConfig) +import Termonad.FocusList (FocusList, emptyFL, focusItemGetter, singletonFL) + +data TMTerm = TMTerm + { term :: Terminal + , 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 "unique = " . + showsPrec (d + 1) (hashUnique unique) . + showString "}" + +$(makeLensesFor + [ ("term", "lensTerm") + , ("unique", "lensUnique") + ] + ''TMTerm + ) + +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 "}" + +$(makeLensesFor + [ ("tmNotebookTabTermContainer", "lensTMNotebookTabTermContainer") + , ("tmNotebookTabTerm", "lensTMNotebookTabTerm") + , ("tmNotebookTabLabel", "lensTMNotebookTabLabel") + ] + ''TMNotebookTab + ) + +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 "}" + +$(makeLensesFor + [ ("tmNotebook", "lensTMNotebook") + , ("tmNotebookTabs", "lensTMNotebookTabs") + ] + ''TMNotebook + ) + +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 "}" + +$(makeLensesFor + [ ("tmStateApp", "lensTMStateApp") + , ("tmStateAppWin", "lensTMStateAppWin") + , ("tmStateNotebook", "lensTMStateNotebook") + , ("tmStateFontDesc", "lensTMStateFontDesc") + , ("tmStateConfig", "lensTMStateConfig") + ] + ''TMState' + ) + +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 -> Unique -> TMTerm +createTMTerm trm unq = + TMTerm + { term = trm + , unique = unq + } + +newTMTerm :: Terminal -> IO TMTerm +newTMTerm trm = do + unq <- newUnique + pure $ createTMTerm trm unq + +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 + +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 + -> FontDescription + -> IO TMState +newTMStateSingleTerm tmConfig app appWin note label scrollWin trm fontDesc = do + tmTerm <- newTMTerm trm + 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 + +pTraceShowMTMState :: TMState -> IO () +pTraceShowMTMState mvarTMState = do + tmState <- readMVar mvarTMState + pPrint tmState + +getFocusedTermFromState :: TMState -> IO (Maybe Terminal) +getFocusedTermFromState mvarTMState = do + withMVar + mvarTMState + ( pure . + firstOf + ( lensTMStateNotebook . + lensTMNotebookTabs . + focusItemGetter . + traverse . + lensTMNotebookTabTerm . + lensTerm + ) + ) diff --git a/src/Termonad/XML.hs b/src/Termonad/XML.hs new file mode 100644 --- /dev/null +++ b/src/Termonad/XML.hs @@ -0,0 +1,229 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Termonad.XML where + +import Termonad.Prelude + +import Data.Default (def) +import Text.XML (renderText) +import Text.XML.QQ (Document, xmlRaw) + +-- TODO: A number of widgets have different places where a child can be added +-- (e.g. tabs vs. page content in notebooks). This can be reflected in a UI +-- definition by specifying the “type” attribute on a The possible +-- values for the “type” attribute are described in the sections describing the +-- widget-specific portions of UI definitions. + +interfaceDoc :: Document +interfaceDoc = + [xmlRaw| + + + + + Example Application + 600 + 400 + + + True + vertical + + + True + + + + + + + |] + +interfaceText :: Text +interfaceText = toStrict $ renderText def interfaceDoc + +menuDoc :: Document +menuDoc = + [xmlRaw| + + + + + + File +
+ + New _Tab + app.newtab + +
+
+ + _Close Tab + app.closetab + + + _Quit + app.quit + +
+ + + Edit + + _Copy + app.copy + + + _Paste + app.paste + + + + Help + + _About + app.about + + + + + |] + +menuText :: Text +menuText = toStrict $ renderText def menuDoc + +aboutDoc :: Document +aboutDoc = + [xmlRaw| + + + + + About + False + True + + + + + True + 6 + 12 + 6 + + + True + _Font: + True + font + 1 + + + 0 + 0 + + + + + True + + + 1 + 0 + + + + + True + _Transition: + True + transition + 1 + + + 0 + 1 + + + + + True + + None + Fade + Slide + + + + 1 + 1 + + + + + + + + + |] + +aboutText :: Text +aboutText = toStrict $ renderText def aboutDoc + +closeTabDoc :: Document +closeTabDoc = + [xmlRaw| + + + + + Close Tab + False + True + + + True + 10 + True + + + True + Close tab? + 10 + True + True + + + + + True + 10 + True + True + + + Yes, close tab + True + True + GTK_RELIEF_NORMAL + + + + + No, do NOT close tab + True + True + GTK_RELIEF_NORMAL + + + + + + + + + |] + +closeTabText :: Text +closeTabText = toStrict $ renderText def closeTabDoc diff --git a/termonad.cabal b/termonad.cabal new file mode 100644 --- /dev/null +++ b/termonad.cabal @@ -0,0 +1,137 @@ +name: termonad +version: 0.1.0.0 +synopsis: Terminal emulator configurable in Haskell +description: Please see . +homepage: https://github.com/cdepillabout/termonad +license: BSD3 +license-file: LICENSE +author: Dennis Gosnell +maintainer: cdep.illabout@gmail.com +copyright: 2017 Dennis Gosnell +category: Text +build-type: Custom +extra-source-files: README.md + , CHANGELOG.md +cabal-version: >=1.12 + +custom-setup + setup-depends: base + , Cabal + , cabal-doctest >=1.0.2 && <1.1 + +library + hs-source-dirs: src + exposed-modules: Termonad + , Termonad.App + , Termonad.Config + , Termonad.FocusList + , Termonad.Gtk + , Termonad.Keys + , Termonad.Prelude + , Termonad.Term + , Termonad.Types + , Termonad.XML + build-depends: base >= 4.7 && < 5 + , classy-prelude + , colour + , constraints + , data-default + , dyre + , gi-gdk + , gi-gio + , gi-glib + , gi-gtk + , gi-pango + , gi-vte + , haskell-gi-base + , lens + , pretty-simple + , QuickCheck + , xml-conduit + , xml-html-qq + default-language: Haskell2010 + ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates + default-extensions: DataKinds + , GADTs + , GeneralizedNewtypeDeriving + , InstanceSigs + , KindSignatures + , NamedFieldPuns + , NoImplicitPrelude + , OverloadedStrings + , OverloadedLabels + , OverloadedLists + , PatternSynonyms + , PolyKinds + , RankNTypes + , RecordWildCards + , ScopedTypeVariables + , TypeApplications + , TypeFamilies + , TypeOperators + other-extensions: TemplateHaskell + +executable termonad + main-is: Main.hs + hs-source-dirs: app + build-depends: base + , termonad + default-language: Haskell2010 + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + +test-suite doctests + type: exitcode-stdio-1.0 + main-is: DocTest.hs + hs-source-dirs: test + build-depends: base + , doctest + , QuickCheck + , template-haskell + default-language: Haskell2010 + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + +test-suite termonad-test + type: exitcode-stdio-1.0 + main-is: Test.hs + hs-source-dirs: test + build-depends: base + , hedgehog + , lens + , termonad + , tasty + , tasty-hedgehog + default-language: Haskell2010 + ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -threaded -rtsopts -with-rtsopts=-N + default-extensions: DataKinds + , GADTs + , GeneralizedNewtypeDeriving + , InstanceSigs + , KindSignatures + , NamedFieldPuns + , NoImplicitPrelude + , OverloadedStrings + , OverloadedLabels + , OverloadedLists + , PatternSynonyms + , PolyKinds + , RankNTypes + , RecordWildCards + , ScopedTypeVariables + , TypeApplications + , TypeFamilies + , TypeOperators + other-extensions: TemplateHaskell + +-- benchmark termonad-bench +-- type: exitcode-stdio-1.0 +-- main-is: Bench.hs +-- hs-source-dirs: bench +-- build-depends: base +-- , criterion +-- , termonad +-- default-language: Haskell2010 +-- ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + +source-repository head + type: git + location: git@github.com:cdepillabout/termonad.git diff --git a/test/DocTest.hs b/test/DocTest.hs new file mode 100644 --- /dev/null +++ b/test/DocTest.hs @@ -0,0 +1,12 @@ + +module Main where + +import Build_doctests (flags, pkgs, module_sources) +import Test.DocTest (doctest) + +main :: IO () +main = do + doctest args + where + args :: [String] + args = flags ++ pkgs ++ module_sources diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,147 @@ + +module Main where + +import Termonad.Prelude + +import Control.Lens ((^.)) +import Hedgehog + ( Gen + , Property + , PropertyT + , annotate + , annotateShow + , failure + , forAll + , property + , success + ) +import Hedgehog.Gen (alphaNum, choice, int, string) +import Hedgehog.Range (constant, linear) +import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.Hedgehog (testProperty) + +import Termonad.FocusList + ( FocusList + , debugFL + , deleteFL + , emptyFL + , insertFL + , invariantFL + , isEmptyFL + , lensFocusListLen + , lookupFL + , removeFL + ) + +main :: IO () +main = do + tests <- testsIO + defaultMain tests + +testsIO :: IO TestTree +testsIO = do + pure $ + testGroup + "tests" + [ testProperty "invariants in FocusList" testInvariantsInFocusList + ] + +testInvariantsInFocusList :: Property +testInvariantsInFocusList = + property $ do + numOfActions <- forAll $ int (linear 1 200) + let initialState = emptyFL + let strGen = string (constant 0 25) alphaNum + -- traceM "----------------------------------" + -- traceM $ "starting bar, numOfActions: " <> show numOfActions + runActions numOfActions strGen initialState + +data Action a + = InsertFL Int a + | RemoveFL Int + | DeleteFL a + deriving (Eq, Show) + +genInsertFL :: Gen a -> FocusList a -> Maybe (Gen (Action a)) +genInsertFL valGen fl + | isEmptyFL fl = Just $ do + val <- valGen + pure $ InsertFL 0 val + | otherwise = Just $ do + let len = fl ^. lensFocusListLen + key <- int $ constant 0 len + val <- valGen + pure $ InsertFL key val + +genRemoveFL :: FocusList a -> Maybe (Gen (Action a)) +genRemoveFL fl + | isEmptyFL fl = Nothing + | otherwise = Just $ do + let len = fl ^. lensFocusListLen + keyToRemove <- int $ constant 0 (len - 1) + pure $ RemoveFL keyToRemove + +genDeleteFL :: Show a => FocusList a -> Maybe (Gen (Action a)) +genDeleteFL fl + | isEmptyFL fl = Nothing + | otherwise = Just $ do + let len = fl ^. lensFocusListLen + keyForItemToDelete <- int $ constant 0 (len - 1) + let maybeItemToDelete = lookupFL keyForItemToDelete fl + case maybeItemToDelete of + Nothing -> + let msg = + "Could not find item in focuslist even though " <> + "it should be there." <> + "\nkey: " <> + show keyForItemToDelete <> + "\nfocus list: " <> + debugFL fl + in error msg + Just item -> pure $ DeleteFL item + +generateAction :: Show a => Gen a -> FocusList a -> Gen (Action a) +generateAction valGen fl = do + let generators = + catMaybes + [ genInsertFL valGen fl + , genRemoveFL fl + , genDeleteFL fl + ] + case generators of + [] -> + let msg = + "No generators available for fl:\n" <> + debugFL fl + in error msg + _ -> do + choice generators + +performAction :: Eq a => FocusList a -> Action a -> Maybe (FocusList a) +performAction fl (InsertFL key val) = insertFL key val fl +performAction fl (RemoveFL keyToRemove) = removeFL keyToRemove fl +performAction fl (DeleteFL valToDelete) = Just $ deleteFL valToDelete fl + +runActions :: (Eq a, Monad m, Show a) => Int -> Gen a -> FocusList a -> PropertyT m () +runActions i valGen startingFL + | i <= 0 = success + | otherwise = do + action <- forAll $ generateAction valGen startingFL + -- traceM $ "runActions, startingFL: " <> show startingFL + -- traceM $ "runActions, action: " <> show action + let maybeEndingFL = performAction startingFL action + case maybeEndingFL of + Nothing -> do + annotate "Failed to perform action." + annotateShow startingFL + annotateShow action + failure + Just endingFL -> + if invariantFL endingFL + then runActions (i - 1) valGen endingFL + else do + annotate "Ending FocusList failed invariants." + annotateShow startingFL + annotateShow action + annotateShow endingFL + failure