termonad (empty) → 0.1.0.0
raw patch · 18 files changed
+2610/−0 lines, 18 filesdep +QuickCheckdep +basedep +classy-preludebuild-type:Customsetup-changed
Dependencies added: QuickCheck, base, classy-prelude, colour, constraints, data-default, doctest, dyre, gi-gdk, gi-gio, gi-glib, gi-gtk, gi-pango, gi-vte, haskell-gi-base, hedgehog, lens, pretty-simple, tasty, tasty-hedgehog, template-haskell, termonad, xml-conduit, xml-html-qq
Files
- CHANGELOG.md +2/−0
- LICENSE +30/−0
- README.md +15/−0
- Setup.hs +111/−0
- app/Main.hs +8/−0
- src/Termonad.hs +7/−0
- src/Termonad/App.hs +354/−0
- src/Termonad/Config.hs +59/−0
- src/Termonad/FocusList.hs +830/−0
- src/Termonad/Gtk.hs +39/−0
- src/Termonad/Keys.hs +96/−0
- src/Termonad/Prelude.hs +8/−0
- src/Termonad/Term.hs +284/−0
- src/Termonad/Types.hs +242/−0
- src/Termonad/XML.hs +229/−0
- termonad.cabal +137/−0
- test/DocTest.hs +12/−0
- test/Test.hs +147/−0
+ CHANGELOG.md view
@@ -0,0 +1,2 @@++## 0.1.0.0
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,15 @@++Termonad+=========++[](http://travis-ci.org/cdepillabout/termonad)+[](https://hackage.haskell.org/package/termonad)+[](http://stackage.org/lts/package/termonad)+[](http://stackage.org/nightly/package/termonad)+++TODO++<!-- markdown-toc start - Run M-x markdown-toc-generate-toc again or edit manually. -->+**Table of Contents**+<!-- markdown-toc end -->
+ Setup.hs view
@@ -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+ ]
+ app/Main.hs view
@@ -0,0 +1,8 @@++module Main where++import Termonad (defaultMain)+import Termonad.Config (defaultTMConfig)++main :: IO ()+main = defaultMain defaultTMConfig
+ src/Termonad.hs view
@@ -0,0 +1,7 @@+module Termonad+ ( defaultMain+ , module Config+ ) where++import Termonad.App (defaultMain)+import Termonad.Config as Config
+ src/Termonad/App.hs view
@@ -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" ["<Shift><Ctrl>T"]++ closeTabAction <- simpleActionNew "closetab" Nothing+ void $ onSimpleActionActivate closeTabAction $ \_ ->+ termExitFocused mvarTMState+ actionMapAddAction app closeTabAction+ applicationSetAccelsForAction app "app.closetab" ["<Shift><Ctrl>W"]++ quitAction <- simpleActionNew "quit" Nothing+ void $ onSimpleActionActivate quitAction $ \_ ->+ exitWithConfirmation mvarTMState+ actionMapAddAction app quitAction+ applicationSetAccelsForAction app "app.quit" ["<Shift><Ctrl>Q"]++ copyAction <- simpleActionNew "copy" Nothing+ void $ onSimpleActionActivate copyAction $ \_ -> do+ maybeTerm <- getFocusedTermFromState mvarTMState+ maybe (pure ()) terminalCopyClipboard maybeTerm+ actionMapAddAction app copyAction+ applicationSetAccelsForAction app "app.copy" ["<Shift><Ctrl>C"]++ pasteAction <- simpleActionNew "paste" Nothing+ void $ onSimpleActionActivate pasteAction $ \_ -> do+ maybeTerm <- getFocusedTermFromState mvarTMState+ maybe (pure ()) terminalPasteClipboard maybeTerm+ actionMapAddAction app pasteAction+ applicationSetAccelsForAction app "app.paste" ["<Shift><Ctrl>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, "")
+ src/Termonad/Config.hs view
@@ -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+ }
+ src/Termonad/FocusList.hs view
@@ -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
+ src/Termonad/Gtk.hs view
@@ -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
+ src/Termonad/Keys.hs view
@@ -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
+ src/Termonad/Prelude.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Termonad.Prelude+ ( module X+ ) where++import ClassyPrelude as X+import Data.Proxy as X
+ src/Termonad/Term.hs view
@@ -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
+ src/Termonad/Types.hs view
@@ -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+ )+ )
+ src/Termonad/XML.hs view
@@ -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 <child> The possible+-- values for the “type” attribute are described in the sections describing the+-- widget-specific portions of UI definitions.++interfaceDoc :: Document+interfaceDoc =+ [xmlRaw|+ <?xml version="1.0" encoding="UTF-8"?>+ <interface>+ <!-- interface-requires gtk+ 3.8 -->+ <object id="appWin" class="GtkApplicationWindow">+ <property name="title" translatable="yes">Example Application</property>+ <property name="default-width">600</property>+ <property name="default-height">400</property>+ <child>+ <object class="GtkBox" id="content_box">+ <property name="visible">True</property>+ <property name="orientation">vertical</property>+ <child>+ <object class="GtkStack" id="stack">+ <property name="visible">True</property>+ </object>+ </child>+ </object>+ </child>+ </object>+ </interface>+ |]++interfaceText :: Text+interfaceText = toStrict $ renderText def interfaceDoc++menuDoc :: Document+menuDoc =+ [xmlRaw|+ <?xml version="1.0"?>+ <interface>+ <!-- interface-requires gtk+ 3.0 -->+ <menu id="menubar">+ <submenu>+ <attribute name="label" translatable="yes">File</attribute>+ <section>+ <item>+ <attribute name="label" translatable="yes">New _Tab</attribute>+ <attribute name="action">app.newtab</attribute>+ </item>+ </section>+ <section>+ <item>+ <attribute name="label" translatable="yes">_Close Tab</attribute>+ <attribute name="action">app.closetab</attribute>+ </item>+ <item>+ <attribute name="label" translatable="yes">_Quit</attribute>+ <attribute name="action">app.quit</attribute>+ </item>+ </section>+ </submenu>+ <submenu>+ <attribute name="label" translatable="yes">Edit</attribute>+ <item>+ <attribute name="label" translatable="yes">_Copy</attribute>+ <attribute name="action">app.copy</attribute>+ </item>+ <item>+ <attribute name="label" translatable="yes">_Paste</attribute>+ <attribute name="action">app.paste</attribute>+ </item>+ </submenu>+ <submenu>+ <attribute name="label" translatable="yes">Help</attribute>+ <item>+ <attribute name="label" translatable="yes">_About</attribute>+ <attribute name="action">app.about</attribute>+ </item>+ </submenu>+ </menu>+ </interface>+ |]++menuText :: Text+menuText = toStrict $ renderText def menuDoc++aboutDoc :: Document+aboutDoc =+ [xmlRaw|+ <?xml version="1.0"?>+ <interface>+ <!-- interface-requires gtk+ 3.8 -->+ <object id="aboutDialog" class="GtkDialog">+ <property name="title" translatable="yes">About</property>+ <property name="resizable">False</property>+ <property name="modal">True</property>+ <child internal-child="vbox">+ <object class="GtkBox" id="vbox">+ <child>+ <object class="GtkGrid" id="grid">+ <property name="visible">True</property>+ <property name="margin">6</property>+ <property name="row-spacing">12</property>+ <property name="column-spacing">6</property>+ <child>+ <object class="GtkLabel" id="fontlabel">+ <property name="visible">True</property>+ <property name="label">_Font:</property>+ <property name="use-underline">True</property>+ <property name="mnemonic-widget">font</property>+ <property name="xalign">1</property>+ </object>+ <packing>+ <property name="left-attach">0</property>+ <property name="top-attach">0</property>+ </packing>+ </child>+ <child>+ <object class="GtkFontButton" id="font">+ <property name="visible">True</property>+ </object>+ <packing>+ <property name="left-attach">1</property>+ <property name="top-attach">0</property>+ </packing>+ </child>+ <child>+ <object class="GtkLabel" id="transitionlabel">+ <property name="visible">True</property>+ <property name="label">_Transition:</property>+ <property name="use-underline">True</property>+ <property name="mnemonic-widget">transition</property>+ <property name="xalign">1</property>+ </object>+ <packing>+ <property name="left-attach">0</property>+ <property name="top-attach">1</property>+ </packing>+ </child>+ <child>+ <object class="GtkComboBoxText" id="transition">+ <property name="visible">True</property>+ <items>+ <item translatable="yes" id="none">None</item>+ <item translatable="yes" id="crossfade">Fade</item>+ <item translatable="yes" id="slide-left-right">Slide</item>+ </items>+ </object>+ <packing>+ <property name="left-attach">1</property>+ <property name="top-attach">1</property>+ </packing>+ </child>+ </object>+ </child>+ </object>+ </child>+ </object>+ </interface>+ |]++aboutText :: Text+aboutText = toStrict $ renderText def aboutDoc++closeTabDoc :: Document+closeTabDoc =+ [xmlRaw|+ <?xml version="1.0"?>+ <interface>+ <!-- interface-requires gtk+ 3.8 -->+ <object id="closeTabDialog" class="GtkDialog">+ <property name="title" translatable="yes">Close Tab</property>+ <property name="resizable">False</property>+ <property name="modal">True</property>+ <child internal-child="vbox">+ <object class="GtkBox" id="vbox">+ <property name="hexpand">True</property>+ <property name="margin">10</property>+ <property name="vexpand">True</property>+ <child>+ <object class="GtkLabel">+ <property name="hexpand">True</property>+ <property name="label">Close tab?</property>+ <property name="margin">10</property>+ <property name="vexpand">True</property>+ <property name="visible">True</property>+ </object>+ </child>+ <child>+ <object class="GtkButtonBox">+ <property name="hexpand">True</property>+ <property name="margin">10</property>+ <property name="vexpand">True</property>+ <property name="visible">True</property>+ <child>+ <object class="GtkButton">+ <property name="label">Yes, close tab</property>+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="relief">GTK_RELIEF_NORMAL</property>+ </object>+ </child>+ <child>+ <object class="GtkButton">+ <property name="label">No, do NOT close tab</property>+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="relief">GTK_RELIEF_NORMAL</property>+ </object>+ </child>+ </object>+ </child>+ </object>+ </child>+ </object>+ </interface>+ |]++closeTabText :: Text+closeTabText = toStrict $ renderText def closeTabDoc
+ termonad.cabal view
@@ -0,0 +1,137 @@+name: termonad+version: 0.1.0.0+synopsis: Terminal emulator configurable in Haskell+description: Please see <https://github.com/cdepillabout/termonad#readme README.md>.+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
+ test/DocTest.hs view
@@ -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
+ test/Test.hs view
@@ -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