termonad-0.2.1.0/.nix-helpers/0000755000000000000000000000000013340133255014162 5ustar0000000000000000termonad-0.2.1.0/app/0000755000000000000000000000000013324104673012432 5ustar0000000000000000termonad-0.2.1.0/img/0000755000000000000000000000000013340133255012422 5ustar0000000000000000termonad-0.2.1.0/src/0000755000000000000000000000000013324372045012441 5ustar0000000000000000termonad-0.2.1.0/src/Termonad/0000755000000000000000000000000013336413765014222 5ustar0000000000000000termonad-0.2.1.0/test/0000755000000000000000000000000013324101362012621 5ustar0000000000000000termonad-0.2.1.0/src/Termonad.hs0000644000000000000000000000020013324372045014536 0ustar0000000000000000module Termonad ( defaultMain , module Config ) where import Termonad.App (defaultMain) import Termonad.Config as Config termonad-0.2.1.0/src/Termonad/App.hs0000644000000000000000000003227513336256507015306 0ustar0000000000000000 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 , onWidgetDeleteEvent , onWidgetDestroy , setWidgetMargin , styleContextAddProviderForScreen , widgetDestroy , widgetGrabFocus , widgetSetCanFocus , widgetShow , widgetShowAll , windowClose , windowPresent , windowSetDefaultIconFromFile , windowSetTitle , windowSetTransientFor ) import qualified GI.Gtk as Gtk import GI.Pango ( FontDescription , pattern SCALE , fontDescriptionNew , fontDescriptionSetFamily , fontDescriptionSetSize ) import GI.Vte ( terminalCopyClipboard , terminalPasteClipboard ) import Paths_termonad (getDataFileName) 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) , UserRequestedExit(UserRequestedExit, UserDidNotRequestExit) , getFocusedTermFromState , getUserRequestedExit , lensTMNotebookTabs , lensTMNotebookTabTerm , lensTMStateApp , lensTMStateNotebook , lensTerm , newEmptyTMState , setUserRequestedExit , 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 respType <- exitWithConfirmationDialog mvarTMState case respType of ResponseTypeYes -> do setUserRequestedExit mvarTMState quit mvarTMState _ -> pure () exitWithConfirmationDialog :: TMState -> IO ResponseType exitWithConfirmationDialog 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 pure $ toEnum (fromIntegral res) 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 termonadIconPath <- getDataFileName "img/termonad-lambda.png" windowSetDefaultIconFromFile termonadIconPath 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) $ do setUserRequestedExit mvarTMState 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) windowSetTitle win "Termonad" void $ onWidgetDeleteEvent win $ \_ -> do userRequestedExit <- getUserRequestedExit mvarTMState case userRequestedExit of UserRequestedExit -> pure False UserDidNotRequestExit -> do respType <- exitWithConfirmationDialog mvarTMState let stopOtherHandlers = case respType of ResponseTypeYes -> False _ -> True pure stopOtherHandlers 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 } eitherRes <- tryIOError $ wrapMain params (tmConfig, "") case eitherRes of Left ioErr | ioeGetErrorType ioErr == doesNotExistErrorType && ioeGetFileName ioErr == Just "ghc" -> do putStrLn $ "Could not find ghc on your PATH. Ignoring your termonad.hs " <> "configuration file and running termonad with default settings." start tmConfig | otherwise -> do putStrLn $ "IO error occurred when trying to run termonad:" print ioErr putStrLn "Don't know how to recover. Exiting." Right _ -> pure () termonad-0.2.1.0/src/Termonad/Config.hs0000644000000000000000000000245013330201365015745 0ustar0000000000000000{-# 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 } termonad-0.2.1.0/src/Termonad/FocusList.hs0000644000000000000000000006513013324651646016475 0ustar0000000000000000{-# 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 termonad-0.2.1.0/src/Termonad/Gtk.hs0000644000000000000000000000215113327250413015267 0ustar0000000000000000{-# 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 termonad-0.2.1.0/src/Termonad/Keys.hs0000644000000000000000000000607313327526742015477 0ustar0000000000000000 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(..) , getEventKeyHardwareKeycode , getEventKeyIsModifier , getEventKeyKeyval , getEventKeyLength , getEventKeyState , getEventKeyString , getEventKeyType ) import Termonad.Term (altNumSwitchTerm) import Termonad.Types (TMState) showKeys :: EventKey -> IO Bool showKeys eventKey = do eventType <- getEventKeyType eventKey maybeString <- getEventKeyString eventKey modifiers <- getEventKeyState eventKey len <- getEventKeyLength eventKey keyval <- getEventKeyKeyval eventKey isMod <- getEventKeyIsModifier eventKey keycode <- getEventKeyHardwareKeycode eventKey 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 altNumKeys stopProp :: (TMState -> IO a) -> TMState -> IO Bool stopProp callback terState = callback terState $> True removeStrangeModifiers :: Key -> Key removeStrangeModifiers Key{keyVal, keyMods} = let reservedModifiers = [ ModifierTypeModifierReserved13Mask , ModifierTypeModifierReserved14Mask , ModifierTypeModifierReserved15Mask , ModifierTypeModifierReserved16Mask , ModifierTypeModifierReserved17Mask , ModifierTypeModifierReserved18Mask , ModifierTypeModifierReserved19Mask , ModifierTypeModifierReserved20Mask , ModifierTypeModifierReserved21Mask , ModifierTypeModifierReserved22Mask , ModifierTypeModifierReserved23Mask , ModifierTypeModifierReserved24Mask , ModifierTypeModifierReserved25Mask , ModifierTypeModifierReserved29Mask ] in Key keyVal (difference keyMods reservedModifiers) handleKeyPress :: TMState -> EventKey -> IO Bool handleKeyPress terState eventKey = do -- void $ showKeys eventKey keyval <- getEventKeyKeyval eventKey modifiers <- getEventKeyState eventKey let oldKey = toKey keyval (setFromList modifiers) newKey = removeStrangeModifiers oldKey maybeAction = lookup newKey keyMap case maybeAction of Just action -> action terState Nothing -> pure False termonad-0.2.1.0/src/Termonad/Prelude.hs0000644000000000000000000000020513275155524016151 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} module Termonad.Prelude ( module X ) where import ClassyPrelude as X import Data.Proxy as X termonad-0.2.1.0/src/Termonad/Term.hs0000644000000000000000000002317613336413765015476 0ustar0000000000000000{-# 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 System.FilePath (()) import System.Directory (getSymbolicLinkTarget) 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 , pid , tmNotebook , tmNotebookTabs , tmNotebookTabTerm , 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 maybeTitle <- terminalGetWindowTitle term' let title = fromMaybe "bash" maybeTitle 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 -- | TODO: This should probably be implemented in an external package, -- since it is a generally useful utility. -- -- It should also be implemented for windows and osx. cwdOfPid :: Int -> IO (Maybe Text) cwdOfPid pd = do #ifdef mingw32_HOST_OS pure Nothing #else #ifdef darwin_HOST_OS pure Nothing #else let pidPath = "/proc" show pd "cwd" eitherLinkTarget <- try $ getSymbolicLinkTarget pidPath case eitherLinkTarget of Left (_ :: IOException) -> pure Nothing Right linkTarget -> pure $ Just $ pack linkTarget #endif #endif createTerm :: (TMState -> EventKey -> IO Bool) -> TMState -> IO TMTerm createTerm handleKeyPress mvarTMState = do scrolledWin <- createScrolledWin mvarTMState TMState{tmStateFontDesc, tmStateConfig, tmStateNotebook=currNote} <- readMVar mvarTMState let maybeCurrFocusedTabPid = pid . tmNotebookTabTerm <$> getFLFocusItem (tmNotebookTabs currNote) maybeCurrDir <- maybe (pure Nothing) cwdOfPid maybeCurrFocusedTabPid 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 terminalProcPid <- terminalSpawnSync vteTerm [PtyFlagsDefault] maybeCurrDir ["/usr/bin/env", "bash"] Nothing ([SpawnFlagsDefault] :: [SpawnFlags]) Nothing noCancellable tmTerm <- newTMTerm vteTerm (fromIntegral terminalProcPid) 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 relabelTab (tmNotebook currNote) tabLabel scrolledWin vteTerm 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 termonad-0.2.1.0/src/Termonad/Types.hs0000644000000000000000000001732113332057343015656 0ustar0000000000000000{-# 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 , pid :: !Int , unique :: !Unique } instance Show TMTerm where showsPrec :: Int -> TMTerm -> ShowS showsPrec d TMTerm{..} = showParen (d > 10) $ showString "TMTerm {" . showString "term = " . showString "(GI.GTK.Terminal)" . showString ", " . showString "pid = " . showsPrec (d + 1) pid . showString ", " . showString "unique = " . showsPrec (d + 1) (hashUnique unique) . showString "}" $(makeLensesFor [ ("term", "lensTerm") , ("pid", "lensPid") , ("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 UserRequestedExit = UserRequestedExit | UserDidNotRequestExit deriving (Eq, Show) data TMState' = TMState { tmStateApp :: !Application , tmStateAppWin :: !ApplicationWindow , tmStateNotebook :: !TMNotebook , tmStateFontDesc :: !FontDescription , tmStateConfig :: !TMConfig , tmStateUserReqExit :: !UserRequestedExit -- ^ This signifies whether or not the user has requested that Termonad -- exit by either closing all terminals or clicking the exit button. If so, -- 'tmStateUserReqExit' should have a value of 'UserRequestedExit'. However, -- if the window manager requested Termonad to exit (probably through the user -- trying to close Termonad through their window manager), then this will be -- set to 'UserDidNotRequestExit'. } 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 ", " . showString "tmStateUserReqExit = " . showsPrec (d + 1) tmStateUserReqExit . showString "}" $(makeLensesFor [ ("tmStateApp", "lensTMStateApp") , ("tmStateAppWin", "lensTMStateAppWin") , ("tmStateNotebook", "lensTMStateNotebook") , ("tmStateFontDesc", "lensTMStateFontDesc") , ("tmStateConfig", "lensTMStateConfig") , ("tmStateUserReqExit", "lensTMStateUserReqExit") ] ''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 -> Int -> Unique -> TMTerm createTMTerm trm pd unq = TMTerm { term = trm , pid = pd , unique = unq } newTMTerm :: Terminal -> Int -> IO TMTerm newTMTerm trm pd = do unq <- newUnique pure $ createTMTerm trm pd unq 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 , tmStateUserReqExit = UserDidNotRequestExit } 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 , tmStateUserReqExit = UserDidNotRequestExit } newTMStateSingleTerm :: TMConfig -> Application -> ApplicationWindow -> Notebook -> Label -> ScrolledWindow -> Terminal -> Int -> FontDescription -> IO TMState newTMStateSingleTerm tmConfig app appWin note label scrollWin trm pd fontDesc = do tmTerm <- newTMTerm trm pd let tmNoteTab = createTMNotebookTab label scrollWin tmTerm tabs = singletonFL tmNoteTab tmNote = createTMNotebook note tabs newTMState tmConfig app appWin tmNote fontDesc traceShowMTMState :: TMState -> IO () traceShowMTMState mvarTMState = do tmState <- readMVar mvarTMState print tmState 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 ) ) setUserRequestedExit :: TMState -> IO () setUserRequestedExit mvarTMState = do modifyMVar_ mvarTMState $ \tmState -> do pure $ tmState & lensTMStateUserReqExit .~ UserRequestedExit getUserRequestedExit :: TMState -> IO UserRequestedExit getUserRequestedExit mvarTMState = do tmState <- readMVar mvarTMState pure $ tmState ^. lensTMStateUserReqExit termonad-0.2.1.0/src/Termonad/XML.hs0000644000000000000000000002066513324372045015217 0ustar0000000000000000{-# 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 termonad-0.2.1.0/app/Main.hs0000644000000000000000000000021513324104673013650 0ustar0000000000000000 module Main where import Termonad (defaultMain) import Termonad.Config (defaultTMConfig) main :: IO () main = defaultMain defaultTMConfig termonad-0.2.1.0/test/Test.hs0000644000000000000000000000765113320602510014102 0ustar0000000000000000 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 termonad-0.2.1.0/test/DocTest.hs0000644000000000000000000000032613324101362014523 0ustar0000000000000000 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 termonad-0.2.1.0/img/termonad-lambda.png0000644000000000000000000005642513327266724016210 0ustar0000000000000000PNG  IHDR+bKGD pHYs  tIME;iTXtCommentCreated with GIMPd.e IDATxyu}{gؙ'@B C,ZnǎγfLʽȺ 㲥ς84$ ;]2W2sЏf -1?;+23{`my]b5'rwg^3yb8<~8 /և~1@!׼$so5=[ﳥ'ϝ84ƍbCG!i dOe΍f++:|m)Yrμa8ÿ93{gM߷;ɒ}g@NӍW8:E\N6g}=o\/dÏZ]`Ï~!}7:|b>cX>>ٌ[+vq+_ˢO}6#֭wz8tZ`?Ϥ.?oU'?ӱߺ8lb]`|蓟-CLmx!)LϦ͹?궰ӳi%Rޞl/~%#o-l 9_Ii6*^"펿3V 39[ @6pnFm?m'irscWw7hz?|#cWs/joR :Nj}ܝ; ֬b]ȺtYSỒu0X.d(f3S|ڊuO>l?mg_2|VY. c^[m0a Ŭ?@:XVj0UVY. #__oлybK`ju1%1V]N`f$Ŭ?@U{LZ]tKVY. oZ]tI*B_jTp ^o[x#X]^<`BqcX]RJ3ϪuKJ%t]N~'fnպ~mvҟUeWO!낳\]^T`<ԍFZ7u?C»umXf}$Iȍy@7iȧ:[O;CffIV2)2 _PJKb·.MJiɟUUէĝɺ;z)gV3m"a@xkK<9oa5؛#Gd'5\mp=Wq@ghuqg2)\qmC\qqֶEG B?;-*N;dOXO"G:\b}.cQҧ?^+z{O"Grĺ8dZ`G/dzfD <1_ӏw_X@hG?,9g^֏kB tѫV[n?gcʽ>-&3X>}o]3Qk?wyҌYY7a\YA @kLM~C׮k3j͚^&kץuaCmܔN]Jfӈay?ƌΆn¸7.Ə͆qT K]UN( oG    @1 P@@@@h[=?_*/3@]U/GF=2ORe驟Neٜ@ݕ٫^9F 94 NeD8I1 N(rAtx-տ 3 t3 @:[@W^'rR(@::1=NbrAtR2(@:}2/G қ?LI1 ｽKvAX-3AFzȦ ˄/3<3"#ӟQ1e|elgB&)-S{ IUh'yY\c%-X"]NRg0 f ɛY[}f435ٷ|4ӳ_/3r@i/ZM#U)4]KfD`-[rxrx`$KF@{Z _rr7ǕI. 4;seyUȸT6笲)ge$ KsO}Q \9eYF`=xisa7[V6sCL=hƎ۔ٳ ˬ+zmO-B;@#WaU K η9epF~oX7 [5h 9aesfj@͝Շ Z̃y{ o Y޾"UN2=)FΪ|ٗ{k66+en/ٜi^6]3 @=}#C eX)M_s\P@~RdLzOdJ(sH9 @J}FW S3_W0+9@{z'7WuK|9׼([ 'KYFQ@;ZZ{z IDATJ8:')@4 }2?-fxz Y2 تRaeA@{z3_k0@%Bvp,?0@`e匌3hG,qV26/V uyzea@=R?q CJsJ @=Y$J_.7'gOA@;ژ; [U>91hOy4(<6`e܌3hGYoG>yo ЮUM` ))F`gkRS~`:ru}@C@0-ͽm cŒHA @;Z;ssV25Gf تFfA @{ZR?6=2' @zAUɋ|@vum}D6 '^.JRѓ Y RS~>Q`rA @n`/ddz ѫ~V25 Ss%뫅mОnoNn`H3s\7\_klU)cb5 =m51bl=rQbЎΣn`H `vN+3 Q3+sM=;[ 7 u̼*rA X/͝`J#\@!W׿!0uŒ0hO6wkn`H3sBY41yoО64rGY׏i00; іl7C қ@vum}X6 !x\es/dJ\@vT'>E`Hۢ몋2 =' !moЎVܚAU |@fn/0;L}О n`H `v-I z(y\@tM}tCD9?ey$95hGͼk9$E(# uy&hy`nw CP<_eОxCH,@v攬tCJ2oЎȒܐA`rA @{z34/'KA @;ZZ?25G `!m.JA @{f}P6 !mL0hG?b0|@vTg WקK %rQ{eR8*hm-i[7i}n^A`,eXz <69oЎ9ߪ4u( ӵ*y:#'fA @;z~>B@y: @;bOJȝeaIО zZֻ !%2`ЎVO c`(fiY`Ў/Pc`~VK_ K +fw*q99 s6mfA @(YX,}6oI`z2&,K|۬y:kezfrWY}$huseu}LYٯ`ʦsOoyGz,*@VvEW9% wsT9 _=)>g;m.@V{ENm_SL4h%sV 2:UgJJUl# @kZN|o숍U9*ˁ^?v,- \ڈKcTyO3ؕέ^Ȟ>g*e*'7re˳᯴oW `8Y:-dA כ+kcγ;eNKaY}`.-?I37YW0Y!c'ҲvAǧOR `G+'wk^e.'h=3W Z߮ `Ǿ-ůsJ&(rbO إJs v2 wǶ  >_FklʑٯhQ|O}B/؞JzMt9/U 19RʬrA їZp 3xgn x$@wdaL? -l9 \QVNaY}m;LLꛯrD ޞ\Y}; 侲& ގʑ9yI #_G(e]N2sr..Omvu[V`[_-dvSsZd0LʕNwvJg9C1C32ea@EշGMn^f:C2[m'K˅^.+g.dA [sYy h{YIo:d;vCYYo߼̢_GOieA /],_G)eT)O}YT]@. 帜Nܔ34H<~#diYa0,'ѱ.0@U>GfW']|0YT덋ߚPz%вw?bsvZN- nԟ+(],+zgRf|oYtO {{ mU?6hWfݣ7,u94]'K= nrf.tyOftF,7{;_e̮N2:rlNt?]M\6:ݰ,*Xɩ9L2:Ʌy@ϲrA йVOfO,T[6:QOFwC @\Lדe iFCշA/XVޓ 3:njrDNs?/J#GW'+ʏ2ol7@grqy -3d@]P=I>?ϔs ,*w~urQ}@)m ~ƭ`@]ϕ?a=,HA Ў)ޒ`Hd0 vҌ?Rvd@I{I)9L6Mh,*$5stuA &)YTMv0 ]r\Nt?po>kP-P#b `E I<'m b'رaXc4 09aU\K ׽,͂r P/tfS&{(5 Crad `d*l*=9- F?]|A`tg\_?߼eP0rr0)W'*M;4rDi {߉,-Z1`oLsi9\({̅EyK/ 2=ok?󿋏5v{CW͍aoh+sb/yٙW|Н'1`O%5)WL cG *O]{JW~]4` rQ~Y^B%r ]Ӽ#=Yy\-`Vy,~ 1Y90oX @?TWnlnqzy@?Qeqqc;,4A(0`Yzr L\s,ƽsf9R &b?LuhF-AĨɑnL<7r0q*rj`"ʡm @Dpl9#}D=P0uL5&rv9R Ƴra~Y^LLe g+wr0+G*dY#]%m QY?` P0vMOossatǵ@Xux9'(Zx/WLeK0hIL ƚʯ3Z6UA([.oNʱCE9D M|Io];ԼVV9`8n_䩲&GP0LJosS& A(Y.A?Pwhd nh^Aoj0@]Լ\V @@[s\l?ٙUՈ5չ.Uya(h熲)SlR#~T{h[rJ9S sP#/d*gYWJ7Vx@p4oPO}|5Z W'A<vO-s{=7VJ9,i.\T)e:髋7v@.ks  d6wnj}=\3$Vr w\YKmgΩ}l U'璘.q 2%/PesG"sm빣s|>7 v@)kr}M Y(otrOڇ4ri[W"gUv|7oɺε*ZcMO@@dfn(zz^\-}+4 @yevp/GM'ԓ|hQs 6EF l v@)=9@ raVL3Nãh_׭yҁ.ȹhA(&LnvfUg(wWhW)y`bs]y?v_\r4?tfo^]g˚'DݗYXp_CӁ+g @0.G?/뗙;u5c`tcMO @0UfepI}w3_5Z0W/D1)76-v3vewlgH+4 @01Q. Ά:?@ w(DUy! u}6ߨZ*xAقPoWy?v_/3g g[r 2%/Po+s {׼ aIDAT]WЮȳeMI(\w/rہ9W`|_fe@oؘsu~ҕML`<^{@]35Z0+rQ`|94Kr]h_Iteg>0@Z)|\*0trO]{'x1)Ss}y `gV}XкXlA(Ƈ6ss 78^9.^i` 2%/ R8Mwz]hb_vG^Uٲ&N*rg[ Gۖs{=7v@ylA(Ʋɹl@'8znv6JWkz2M ,Κ p|mg]y@;fE.PE%=9GW/p|\&ӝl?-sV9/ ]{KO`=g*'['ğ@@ZWs~-X2=b@ܓv_;Y]PrWq|9+ k;&P}.z v@+3C} +/ǀj}3/}&ֹʜ/ Ȳ!Z笺>Pdg6Գ]ҕM1(Fks _ 2{yҁaVdy`4_lgP' 3oW5羚.UJ)2A(F^\r:^]{LU(Ffv5ͼT-ONҺ8?}fr-/ޜLIE:k&| ,ʔTV(Fe?˟3?Zׯrߦb**[z2UH|y%3 cΨy4cA˫,.ػ&er/Oyu|\ 29/UP]6sr r?Ȗv&ЪeU*`rNJo *.$Y_=Aq91P'sr ַ?&/ <ެdA()<)3zsI}08>YسyYS ̫X}rRGrA(?g`}6[@ Lj`OΌP6dM!ߤ;9ep~.(3..$ODoeK}X{̎\7vЦ(bY%_z;6`Q7+W{yʞ Uy WiuBY`uN5o皭KUʉ_ G1BteSӓ) fk~?-יg߈<V>Ί\(ByTz}b s_}_#n{:?NAB)rA YcP\bGeЮ}'SչuِnA0ZaA#;\6 yY\`w?)*J_紺!_[Q3VO6hS)RV P_W+g?l_崺Ah-m)3#])ٙe iF/WW8VJ9>"A וə?g7A t_@+] |dvz. wB}Hy4ǹ"@A ˬ?_7|znvJ986(/76}c <_MUL6PLleauyd φ:|uhY%XA |YhC,3Y1 / MPdKYe&;ח2냂R=-eUL DtY37{̯Q=\RH`;. ?G5ZcZ{DsJY mg  FoVO%9P`"]o(e z5has Dqp.ʚU 啺5OUhUғv amZՋkepnc(ƻ0bn9HLɖڍ1r Udc2o,siiKY(ƳŐ!trU] b *:SPq_N,gB[|g ƨꖼ5Zʦ@0>u9Slg 1| u h/"@A ,/ʛ`y|LvB) A qvU[9\:nu Ƹlr-?/=j?rhn,cqfgOUEXA bq9&K C, WO@LΖM2fͤgZg^ݐo 7hiKY-@0S. suf hrz9W`l'3?* UѦ@0MEUyU M373 Ory@A fk!7Ze]PAB`l^~rҼ!ASէ=r$`9jf߸e+|iY qcKWz c qk)PVacQeqtcH ƽ1A+/Uy`츮 cnͳMvCPq9+@0LͲ\W7Ɖ!ͫ fTh+5= `Ea!Ժ-7tIyOry. A Ѭb@SM8sa,) A 2+:!}7p>>{hWғI^&մ6뽷ɐ &zW?hY,ʅ8A hfY.s zK:MXt^MP&ڧ _s m9nNQLX@n'V^*2ݾ2@0LJW~]mM.P6w1[1B)r hhVP{ݹy,mgnf>ˁ@IP[dIVg Cy?v=}kBExA }imJ!ure]gyn;^MP&煲ʍ4Ws@/mdH: |POTVez(?8ޒo c@l .Z(؜^yw.j m9,V}4;VXV `)ge WArG|n -2; bA 6&;.İNc#<H+]m6 P oysRa?׹V@˛r~JI[tb AhYV{ A ZV'כloSsK=E`Y<2Qy?Fl .ZUgr @Y.A0${>vЦ(lY-@07 OFsV]/_uRLw/Ox[ 0ط9:y Je [ZN\OV'W>lH+]cj~ʼna }5)Zx_r @) Z[oM5Q`s}5{ J907W P$ eS0j&g(#_dC]eTXzE7&Y@&E?yn*YVN&͛9lQt3ILse 0quX)a}7^A0|z V^)2-(iI9.$7ޖ(tw|5Z(evłDt@z%Q79?F/)@@Zނ4A `9.G)h6շ(-}A&,Dҝ_2?u]535Z(׬&ra~Y^ê<ӹGj|u6@,=) `Xټ#<9jns]fY#@L -=`%U&gכ=UeLn~ZiSIy9(oQ9& G fS}Se]*A«L$A `<+Msh?ƞ;3hiXf̲Xf%YD ~1l^nhf 0>\WthaN-ǘI_] e  Pϴ,uECwϘr}7T^)f 0\|YӦȣy?ƨNO_]M9:Z-.10@Z}>cA `8"GBgf^A0}Mǁ)ʤ<[V[YVN|-Ƹos V^-צ;5eҤMcb_ڷߞ5iҦQP @(P @(@(P PP @(P @(@(P :i&-P @(@(P P @("P @(@(IENDB`termonad-0.2.1.0/LICENSE0000644000000000000000000000276713253434733012677 0ustar0000000000000000Copyright 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. termonad-0.2.1.0/Setup.hs0000644000000000000000000001027013327247724013316 0ustar0000000000000000-- 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 ] termonad-0.2.1.0/termonad.cabal0000644000000000000000000001236313340263476014461 0ustar0000000000000000name: termonad version: 0.2.1.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 cabal-version: >=1.12 extra-source-files: README.md , CHANGELOG.md , default.nix , img/termonad.png , .nix-helpers/nixops.nix , .nix-helpers/nixpkgs.nix , .nix-helpers/running-termonad.nix , .nix-helpers/stack-nix-shell.nix , .nix-helpers/termonad.nix , shell.nix data-files: img/termonad-lambda.png 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 other-modules: Paths_termonad build-depends: base >= 4.7 && < 5 , classy-prelude , colour , constraints , data-default , directory >= 1.3.1.0 , dyre , filepath , gi-gdk , gi-gio , gi-glib , gi-gtk >= 3.0.24 , gi-pango , gi-vte >= 2.91.19 , 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 pkgconfig-depends: gtk+-3.0 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 termonad-0.2.1.0/README.md0000644000000000000000000002603713340262243013135 0ustar0000000000000000 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) Termonad is a terminal emulator configurable in Haskell. It is extremely customizable and provides hooks to modify the default behavior. It can be thought of as the "XMonad" of terminal emulators. ![image of Termonad](./img/termonad.png) **Table of Contents** - [Termonad](#termonad) - [Installation](#installation) - [Arch Linux](#arch-linux) - [Ubuntu / Debian](#ubuntu--debian) - [NixOS](#nixos) - [Mac OS X](#mac-os-x) - [Windows](#windows) - [How to use Termonad](#how-to-use-termonad) - [Configuring Termonad](#configuring-termonad) - [Compiling Local Settings](#compiling-local-settings) - [Running with `stack`](#running-with-stack) - [Running with `nix`](#running-with-nix) - [Goals](#goals) - [Contributions](#contributions) - [Maintainers](#maintainers) ## Installation Termonad can be installed on any system as long as the necessary GTK libraries are available. The following are instructions for installing Termonad on a few different distributions and systems. If the given steps don't work for you, or you want to add instructions for an additional system, please send a pull request. The following steps use the [`stack`](https://docs.haskellstack.org/en/stable/README/) build tool to build Termonad, but [`cabal`](https://www.haskell.org/cabal/) can be used as well. Steps for installing `stack` can be found on [this page](https://docs.haskellstack.org/en/stable/install_and_upgrade/). ### Arch Linux First, you must install the required GTK system libraries: ```sh $ pacman -S vte3 ``` In order to install Termonad, clone this repository and run `stack install`. This will install the `termonad` binary to `~/.local/bin/`: ```sh $ git clone https://github.com/cdepillabout/termonad $ cd termonad/ $ stack install ``` ### Ubuntu / Debian First, you must install the required GTK system libraries: ```sh $ apt-get install gobject-introspection libgirepository1.0-dev libgtk-3-dev libvte-2.91-dev ``` In order to install Termonad, clone this repository and run `stack install`. This will install the `termonad` binary to `~/.local/bin/`: ```sh $ git clone https://github.com/cdepillabout/termonad $ cd termonad/ $ stack install ``` ### NixOS There are two methods to build Termonad on NixOS. The first is using `stack`. The following commands install `stack` for your user, clone this repository, and install the `termonad` binary to `~/.local/bin/`: ```sh $ nix-env -i stack $ git clone https://github.com/cdepillabout/termonad $ cd termonad/ $ stack --nix install ``` The second is using the normal `nix-build` machinery. The following commands clone this repository and build the `termonad` binary at `./result/bin/`: ```sh $ git clone https://github.com/cdepillabout/termonad $ cd termonad/ $ nix-build ``` ### Mac OS X (*currently no instructions available. please send a PR adding instructions if you get termonad to build.*) ### Windows (*currently no instructions available. please send a PR adding instructions if you get termonad to build.*) ## How to use Termonad Termonad is similar to XMonad. The above steps will install a `termonad` binary somewhere on your system. If you have installed Termonad using `stack`, the `termonad` binary will be in `~/.local/bin/`. This binary is a version of Termonad configured with default settings. You can try running it to get an idea of what Termonad is like: ```sh $ ~/.local/bin/termonad ``` If you would like to configure termonad with your own settings, first you will need to create a Haskell file called `~/.config/termonad/termonad.hs`. The next section gives an example configuration file. If this file exists, when the `~/.local/bin/termonad` binary launches, it will try to compile it. If it succeeds, it will create a separate binary file called something like `~/.cache/termonad/termonad-linux-x86_64`. This binary file can be thought of as your own personal Termonad, configured with all your own settings. When you run `~/.local/bin/termonad`, it will re-exec `~/.cache/termonad/termonad-linux-x86_64` if it exists. However, there is one difficulty with this setup. In order for the `~/.local/bin/termonad` binary to be able to compile your `~/.config/termonad/termonad.hs` file, it needs to know where GHC is, as well as where all your Haskell packages live. This presents some difficulties that will be discussed in a following section. ### Configuring Termonad The following is an example Termonad configuration file. You should save this to `~/.config/termonad/termonad.hs`. You can find more information on the available configuration options within the [`Termonad.Config`](https://hackage.haskell.org/package/termonad/docs/Termonad-Config.html) module. ```haskell {-# LANGUAGE OverloadedStrings #-} module Main where import Data.Colour.SRGB (Colour, sRGB24) import Termonad.App (defaultMain) import Termonad.Config ( FontConfig, ShowScrollbar(ShowScrollbarAlways), cursorColor , defaultFontConfig, defaultTMConfig, fontConfig, fontFamily , fontSize, showScrollbar ) -- | This sets the color of the cursor in the terminal. -- -- This uses the "Data.Colour" module to define a dark-red color. -- There are many default colors defined in "Data.Colour.Names". cursColor :: Colour Double cursColor = sRGB24 204 0 0 -- | This defines the font for the terminal. fontConf :: FontConfig fontConf = defaultFontConfig { fontFamily = "DejaVu Sans Mono" , fontSize = 13 } main :: IO () main = do let termonadConf = defaultTMConfig { cursorColor = cursColor , fontConfig = fontConf , showScrollbar = ShowScrollbarAlways } defaultMain termonadConf ``` ### Compiling Local Settings If you lauch Termonad by calling `~/.local/bin/termonad`, it will try to compile the `~/.config/termonad/termonad.hs` file if it exists. The problem is that `~/.local/bin/termonad` needs to be able to see GHC and the required Haskell libraries to be able to compile `~/.config/termonad/termonad.hs`. There are a couple solutions to this problem, listed in the sections below. (These steps are definitely confusing, and I would love to figure out a better way to do this. Please submit an issue or PR if you have a good idea about how to fix this.) #### Running with `stack` If you originally compiled Termonad with `stack`, you can use `stack` to execute Termonad. First, you must change to the directory with the Termonad source code. From there, you can run `stack exec`: ```sh $ cd termonad/ # change to the termonad source code directory $ stack exec -- termonad ``` `stack` will pick up the correct GHC version and libraries from the `stack.yaml` and `termonad.cabal` file. `termonad` will be run in an environment with GHC available. `termonad` will use this GHC and libraries to compile your `~/.config/termonad/termonad.hs` file. It if succeeds, it should create a `~/.cache/termonad/termonad-linux-x86_64` binary. If you need extra Haskell libraries available when compiling your `~/.config/termonad/termonad.hs` file, you can specify them to `stack exec`: ```sh $ stack exec --package lens --package conduit -- termonad ``` The problem with this is that `stack exec` changes quite a few of your environment variables. It is not recommended to actually run Termonad from within `stack exec`. After you run `stack exec -- termonad` and let it recompile your `~/.config/termonad/termonad.hs` file, exit Termonad. Re-run Termonad by calling it directly. Termonad will notice that `~/.config/termonad/termonad.hs` hasn't changed since `~/.cache/termonad/termonad-linux-x86_64` has been recompiled, so it will directly execute `~/.cache/termonad/termonad-linux-x86_64`. #### Running with `nix` If you originally compiled Termonad with `nix`, you can use `nix` to create an environment with GHC and specified Haskell libraries available. There is a `.nix` file available you can use to do this: [`.nix-helpers/running-termonad.nix`](./.nix-helpers/running-termonad.nix) This file will give us an environment with `termonad`, GHC, and a few Haskell libraries installed. You can enter this environment using `nix-shell`: ```sh $ cd termonad/ # change to the termonad source code directory $ nix-shell ./.nix-helpers/running-termonad.nix ``` From within this environment, you can run `termonad`. It will find the `~/.config/termonad/termonad.hs` file and compile it, outputting the `.cache/termonad/termonad-linux-x86_64` binary. Termonad will then re-exec this binary. The problem with this is that `nix-shell` may change your environment variables in ways you do not want. I recommend running `termonad` to get it to recompile your `~/.config/termonad/termonad.hs` file, then exit the nix-shell environment and rerun Termonad by calling it directly. Termonad will notice that `~/.config/termonad/termonad.hs` hasn't been changed since `~/.cache/termonad/termonad-linux-x86_64` has been recompiled, so it will directly execute `~/.cache/termonad/termonad-linux-x86_64`. ## Goals Termonad has the following goals: * fully configurable in Haskell There are already [many](https://gnometerminator.blogspot.com/p/introduction.html) [good](https://www.enlightenment.org/about-terminology.md) [terminal](http://software.schmorp.de/pkg/rxvt-unicode.html) [emulators](https://launchpad.net/sakura). However, there are no terminal emulators fully configurable in Haskell. Termonad fills this niche. * flexible Most people only need a terminal emulator that lets you change the font-size, cursor color, etc. They don't need tons of configuration options. Termonad should be for people that like lots of configuration options. Termonad should provide many hooks to allow the user to change it's behavior. * stable Termonad should be able to be used as everyday as your main terminal emulator. It should not crash for any reason. If you experience a crash, please file an issue or a pull request! * good documentation The [documentation](https://hackage.haskell.org/package/termonad) for Termonad on Hackage should be good. You shouldn't have to guess at what certain data types or functions do. If you have a hard time understanding anything in the documentation, please submit an issue or PR. ## Contributions Contributions are highly appreciated. Termonad is currently missing many helpful configuration options and behavior hooks. If there is something you would like to add, please submit an issue or PR. ## Maintainers - [Dennis Gosnell](https://github.com/cdepillabout) termonad-0.2.1.0/CHANGELOG.md0000644000000000000000000000071213340262747013470 0ustar0000000000000000 ## 0.2.1.0 * Make sure the window title is set to "Termonad". * Relabel tabs when termonad is started. ## 0.2.0.0 * Open dialog asking if you want to quit when you try to use your WM to quit. * Termonad will attempt to open up a new terminal in the working directory of the current terminal. * Make sure termonad won't crash if dyre can't find GHC. * Add a few more ways to compile on NixOS. * Add an icon for termonad. ## 0.1.0.0 * Initial release. termonad-0.2.1.0/default.nix0000644000000000000000000000200713340133255014011 0ustar0000000000000000# This is the main nix file for termonad. It will just build the termonad binary. # It can be built with the command `nix-build` in the main top directory. # # The termonad binary will be created at `result/bin/termonad`. { compiler ? "ghc843" }: let nixpkgs = import ./.nix-helpers/nixpkgs.nix; set-gi-vte-version = _: { version = "2.91.19"; sha256 = "1hnhidjr7jh7i826lj6kdn264i592sfl5kwvymnpiycmcb37dd4y"; }; set-gi-gtk-version = _: { version = "3.0.24"; sha256 = "14cyj1acxs39avciyzqqb1qa5dr4my8rv3mfwv1kv92wa9a5i97v"; }; allHaskellPackages = nixpkgs.pkgs.haskell.packages.${compiler}.override { overrides = self: super: let lib = nixpkgs.pkgs.haskell.lib; in { gi-gtk = lib.overrideCabal super.gi-gtk set-gi-gtk-version; gi-vte = lib.overrideCabal (lib.addPkgconfigDepend (super.gi-vte.override { vte = nixpkgs.gnome3.vte; }) nixpkgs.gnome3.gtk) set-gi-vte-version; }; }; in allHaskellPackages.callPackage .nix-helpers/termonad.nix { inherit (nixpkgs.gnome3) gtk3; } termonad-0.2.1.0/img/termonad.png0000644000000000000000000003553213340133255014751 0ustar0000000000000000PNG  IHDRU!bKGD3'| pHYs  tIME/m IDATxw|e}f8;mރY-Cč(Sp?WEDDE"Q Zҕi4{GA[$hfs]:>1,=kVѣGp80 9YE(ꫫV^gƮ0SOY^z)P41MS&l66 O\yU0SOY_|1@@ trUWܹss}ݚ`0ꈈ.c_=z*""""2”ax^n""""#L(p8T tb,K,¦2\ """" """"0("""" """"222"Wq˫|ԧ;&|'9բ[wBpYEDaPDF xB`6dsӘsrRDDv;fL< x;:wx/~KaPDv >ݽpW g"oT~>7l5ap-g[YyC~\A9^xQ}@WjnQ0/&`RjaƒtЭbΙ7QI ON610Uߧ*7ۺmW<z~ VV6ʠIo sMw\%l_^7އ0rޥ\V,0+K`A>)+hV6=swL&˃{3.Q[ ח2;u6fXD@Lx"pUDHe~!s5="VIt8Kj1|_Sݴw׶z\yMA *guYwggcl_˚uYohE3etuuY*ȤAAQAQAQA>OaGUaӫ*0믨 """"#Q__g """"#M,"""0("""" """"0("""" """"0("""" """"2àns}_BYxWS[ tsQN u8̿kr*c>ŵp+}ь/ y!҅77K89:K?-,$"{}\TCEDD~/X^/v:7Q m|p~22waw \xg䢯<=g&r]spK?@53Xv]u|9 kOȁ xe0i!_dtWe2QZK[w؀".DuR6_3Y邼h#W8G_')_e}S/SI' f,3/笉}]}-ŷ:N(S"""20 z9!QSb돯-8a\:XuTFqg_Ӭodᬙ= cye{=& """1a88{03$I  sȚ 7vfLT=cU|hZ6Fwٴx5?m>FhUPDDD>0傶Vafp6< On'loڲ ? 8$'oZV>]D:;2>5 Ds )~O<2sMTdN8kx廹7~! [rL.8|A@o̰Ş]OlGӿnyx̖37gG3ąk"ӈԆ&5۷7vdQzAc/ql."""d#@("""eAQE `ZQР*0X[]Ua ##S:;;S!DdDlvALaPDDDDaPDDDDEDDDDaPDDDDEDDDDaPDDDDEDDDDaPDDDDEDDDDaPd,½]tLBDFޖrs|*1 eGY9A2a\1b7:jhgd111xR3J¾oØn?SIR4t'Uv,@ .L;YsGp$M9ˆ`6-~I8CN1ILHĊиi Yt[Ĥd˄'`JƞƐO2p8݄ٴx\{י u(T?xֱs˟Yx ?b )w;~^0hhYIie#A >Hf4q&Cl`O-lk6҈+)e)D[FAL =Ope,l ٠ nYRl-eڔ̜1C?[j6g"ϛ$*[ÓoOaQ2e.}&13w[N\~Ʃ.j(ݸg?XWpsIwf'*Fq=7qQ~dD&GsdIOnmoc[kX8#uO;}& -ڎ%.m+@㖍lnqY4qi^l wnc;9{gf'1ڽX6qN})Wqi'~F2o<>X:N=u b_ʝEqd$0s',ei!mzYX.c8;/jbsaPb*w^4)\yd zATbvʑà;5BIJOclL4:ƐM3-]x2PMUN;@vA!uVRl6i.SEWVTI8ɱZQAgX Z15FOC۶7ĥ0j\.'XNvURօ/ ƓIAA6]LGMնˌiDVQh<ȯo!eP{5Nٚ{8wm5&|_>s 1idQw"v)ZCȖ -K]Wמē/gk5;pvm m'L ;1N ZԕQ酨HNʋY6+(;f*J*h HNNLOk˞@йaݖH"+)a׭gkC/ r]+Y޽;KYWь'Έ" PD :1bU|-Vְ|Y1.r҈ {ilL""HcLv"|v >vl(fCu+~g)J7Py8bѳ6좱b mCiۏ];Y6o$F0륾":9ʷP`Y97k,RSRYcOWO'- ddd1uԣ?a {25[O^)4\լxW|/RN&/=b^|:c,nz)- `=Y#^x/e/'̂əD9#4 |'7]tNi"\^-7/ш!:%d:Yj:p1I5?{y?XT˜Rȟ)IIL=s\tD<Co1zX`5(=t-_AL}X${+_\ CӬ/emm+[7>j(-Bٱ[-2FgյU/K k69`;\76ȿŝxl^̲\76UeJs{;]V"q6;Md!^fO&8bIJ''ņk48l @9 eeS8YQ}Il$:CaQSʶfH-K&lqk ErNZnrw_38v4 fN$0Z.jk5&"2ߞbwC(\{~&3m|4D2Hv35?4K}s7c?CXk׬cΜYzZ235cto&'3/q`U2O;w~ 7YI/i_o+eigPȺRvEw&{t&G}ū5cCgϊz7WUS."d%kpjLAr3۸nAFߩzJCd4,[7Lf|oX)DG8 6?$.]zɧc i2xW7p޼[W^ťw}:H<NΣ}m6Prv^Ғm`<[?g6M46L.fk)335;ju{&H„$XaB!0\ݿ pt Adm0ڎA8Cq'8ć~´wbb$8PwК `|Σq&+W}@O<˖4y"kV}ou?j3ӿ~%Xg3ÔX_BIiee]=)<)|w`J>(^5kY*:o g:$s57Wd؇g&7=^z|`Ĺw^,7iu[NWR2 oۃ8? e|]hEx4\ĥdQP4iy1 ⊍]#cѿӅ۰aذzZo:jhyHqZgcb;t>*aBw|mt[m|xL&7|C3@Gc;[{^Vm!xxCoC{ٕA_#e5,uY`hݾwr.#ذN+4Ni 6Zh$Nܽ,mHU5>~z3QNbrio2ǺgV֭ A3i>bǓoQʥn}%˩A\J&X!h iξuRex2Sj;r6ÓCnL3*V$)2@[sa¬X{otbodSs{qٝXKpt#9D?*K  N&'7pf$c1{!dʾIDATy,[su>coo1Ӧo"1bM;8RyGolG--/Qe&SOWӈN֮_)3&[1OwPZ6F [ٺ.t.>7rmǎ'vxgx!v7G\FۼO4 ZNwӻJ`wK=ĸ3KR\A3VgxR<-3MOv{:N$wl<6FQ^ښv2pDƓ=nl@S⪪mK4 Zd"57ul.gFA3hbv0 pDD9JOaoխM4-2SqCY7&$leUԶ"ʓ؂TwLˬF4Sfǽn~XfMٳi̯\BỏqXV>.`P5Yc#*t:tθ{Ŀ77ֿ6E~QnA9c<6}~,߻ n{&5;ؒD@Sqυ2>ÿ6a"Yd%C#fq ˼y3k[bIx:W\9fذHRƑV@Lܩv&eqCiLȶ"c :6mt1m|a;Dt G\F<_222NJގ3c[jk:0b3FblQNvwHQߦoaܼd#o:;;;lV/I+;#x.8{r2H3i6o<ǧ!{nDۈi7׏Y]N#Yt5l$&yۉ˟WSgЕ4H4o8al1EǓ2FP;Ĺ.Ad{,N]g͘sn䎬kKyK$~K%M;!y/9+k m#G\_hhő kg&J Jh\ O߯Y,w 'p2ڿfsh!v"PMUlKxmlD^˨H n` 'cYJew _':6O+q[_"+POl)igg-sV28ϣp&__Άǂ} laaK$^pLJlM,O imk4 KH8hm\#_ϤI=oкG85䳣quf*KEL{...z "Oɠ)>@*dqwvѱ.aOH=vTB}cۙf;Ha7zt~7޾G mԋwi= 'оqL{!غC""Io%9vUAX2%ǯ ("2LàaV^ Xj)9n+H"@wO _H&'|½4=FxM9>mMl:c-r=;DrNei*O\,w4:@;>n+fS<MCll*tF? ɎZJ+a0v]! )^: 0F+u: b1SHSRHkk K mXV 1#F+U=9( 0I? iD;쳓Qˎ{bV6r$'v[*B;d9#7<B4ry`ꄯjOՄ{;V"yp{i{,,]ͬgQuz 0Ň>s? bmn~i.'ƑzYxlES tJ)7b>7s3!w[xK 8q=D01v`W0߳;_ھAGbݿ?N6>W&v=\{$/Lc9.$vە-7t^> [F;aH޾9t% S!8h4_d[i*;M)x #*b zbGͯԮ ֯^CFHKXg*ў7ۚ3;EDg<îD/i%dbYHN 4<ճgmY}_?t~)yjn$x. q^7gZXa7HWKbvTpyU͙vtx-Y kiL"'}8}ھAGkbwN55o>˅IK6z[|&]t i8p=O1aj .l9 ğ!ΗGmmt4MGf-_B}Y]WyQ'4;ʵ|K 4I h>rB}{pgqD;,y6VSsm9V_?hmmqߒ۵k%N#v8Vz|1gkf5y!8`j3{kiE I`d'H ,|&:V~يrF7ohJ\$;P/MZZ;;{*xoy `bQ}g؈8=i=>2شV쑺레01 vR^R´=ѴO^'cL{>=sG3v7=T!'z:X=mli+I&pqD@ Ty25pdMk_(Y21cq+ g+|tmwLey>!6䰶o0ڟ4T"20\8"w]E,3#Hw4}&h]S /H҅Ә~8"B|wpТjjIdI<6 cgp^=Ń=̿%5r1kA+~ >2ɄE])`mu+zC1>}ˤ^&BVf|*.AtUC;whWHNPh_H緰b{dk/6'^vA,wA¨ga5|zBZz{JZne]}"lQi'о?[ʺWӴ3ʉgظ`+̓ o l^ld19$xؾZADSN'9w%pDh8Ϳh:QA?i Ď#xEkR1X͗eY'+i%ovlNrZDd0^_H,.vV~݄q1c'?NzI5Z;*1x>GLwX }ʂ1N%} ŵ*0 ᄞ+WǏ$fz:۶cVs@KH9 q]V`"oֻEDAIĹ-۽켵훎.4h2X_hu"" wT9oKl* (  (  (  (  (  (  (  (  (  (  (  (  (  (  (  (  (  ( (  (  (  (  (  (  (  (  (  (  (  (  (  (  (  (  (  (  ( (  (  (  (  (  (  (  (  (  (  (  (  (  (  (  (  (  (  ( (  (  (  (  (  (  (  (  (  (  (  (  (  (  (  (  (  (  ( (  (  (  (  (  (  (  (  (  (  (  (  (  (  (  (  (  (  ( (  (  (  (  (  (  (  (  (  (  (  (  (  (  (  (  ( oj@ eg8U̴ |+/d&bIENDB`termonad-0.2.1.0/.nix-helpers/nixops.nix0000644000000000000000000000655513337377153016252 0ustar0000000000000000# This file can be used with `nixops` to create a virtual machine that has # Termonad installed. # # I use this to test out Termonad in a desktop environment with a menubar. # # On my development machine, I use XMonad as a Window Manager, so there are # no Window decorations for any X application. This file creates a VM # with Termonad installed in Gnome 3. This lets you see what Termonad # looks like when it has Window decorations, a title bar, etc. # # A virtual machine can be created based on this file with the following # commands: # # $ nixops create --deployment termonad-test .nix-helpers/nixops.nix # $ nixops deploy --deployment termonad-test # # This should open up a VirtualBox machine and start installing Gnome 3, # Termonad, etc. # # You should be able to login with the username "myuser" and password "foobar". # # When you are done you can destroy the machine and delete the deployment: # # $ nixops destroy --deployment termonad-test # $ nixops delete --deployment termonad-test # { network.description = "Gnome With Termonad"; termonad-machine = { config, pkgs, ...}: { imports = [ ]; deployment = { targetEnv = "virtualbox"; virtualbox = { disks.disk1.size = 20480; headless = false; memorySize = 2024; vcpu = 1; }; }; environment = { systemPackages = let pkgList = with pkgs; [ acpi aspell aspellDicts.en autojump bash bash-completion bc chromium curl dmenu emacs evince file firefoxWrapper gcc geeqie gimp gitAndTools.gitFull gitAndTools.hub gnumake gnupg hexchat htop imagemagick jq k2pdfopt ltrace manpages ncurses nix-bash-completions nixops p7zip pkgconfig psmisc python3 redshift roxterm screen strace tree unzip usbutils vimHugeX wget wirelesstools xfce.terminal xorg.xbacklight xorg.xmodmap xscreensaver xterm zlib ]; termonad = import ../default.nix { }; in [ termonad ] ++ pkgList; variables.EDITOR = "vim"; }; fonts.fonts = with pkgs; [ dejavu_fonts ipafont source-code-pro ttf_bitstream_vera ]; i18n = { consoleFont = "Lat2-Terminus16"; consoleKeyMap = "us"; defaultLocale = "en_US.UTF-8"; inputMethod = { enabled = "fcitx"; fcitx.engines = with pkgs.fcitx-engines; [ mozc ]; }; }; programs.bash.enableCompletion = true; services = { xserver = { enable = true; layout = "us"; desktopManager.gnome3.enable = true; }; openssh = { enable = true; forwardX11 = true; challengeResponseAuthentication = true; passwordAuthentication = true; permitRootLogin = "yes"; }; }; security.sudo = { enable = true; extraConfig = '' %wheel ALL=(ALL:ALL) NOPASSWD: ${pkgs.systemd}/bin/poweroff %wheel ALL=(ALL:ALL) NOPASSWD: ${pkgs.systemd}/bin/reboot %wheel ALL=(ALL:ALL) NOPASSWD: ${pkgs.systemd}/bin/systemctl suspend ''; }; users.extraUsers.myuser = { extraGroups = [ "audio" "systemd-journal" "video" "wheel" ]; initialPassword = "foobar"; isNormalUser = true; }; }; } termonad-0.2.1.0/.nix-helpers/nixpkgs.nix0000644000000000000000000000063213336412356016375 0ustar0000000000000000# This file pins the version of nixpkgs to a known good version. # It is imported from various other files. let nixpkgsTarball = builtins.fetchTarball { # recent version of nixpkgs as of 2018-07-29 url = "https://github.com/NixOS/nixpkgs/archive/a2c6dbe370160ffea5537f64dda04489184c5ce1.tar.gz"; sha256 = "1x993g9343yv5wyp29i6vskdcc3rl42xipv79nwmmrj8ay2yhh3b"; }; in import nixpkgsTarball { } termonad-0.2.1.0/.nix-helpers/running-termonad.nix0000644000000000000000000000153413336412356020203 0ustar0000000000000000# Running `nix-shell .nix-helpers/running-termonad.nix` will put us in an environment # with termonad available, as well as GHC and a few other packages (lens and colour). # # If you run `termonad` while in this environment, `termonad` should be able to see # GHC and all the Haskell libraries listed below. This will let `termonad` be able to # recompile the `~/.config/termonad/termonad.hs` file. # # This file is really only used when you want to run termonad in an environment where it # has access to specific libraries. { compiler ? "ghc843" }: let nixpkgs = import ./nixpkgs.nix; termonad = nixpkgs.callPackage ../. { inherit compiler; }; ghcStuff = nixpkgs.pkgs.haskell.packages.${compiler}.ghcWithPackages (pkgs: [ pkgs.colour pkgs.lens termonad ]); in nixpkgs.runCommand "dummy" { buildInputs = [ ghcStuff termonad ]; } "" termonad-0.2.1.0/.nix-helpers/stack-nix-shell.nix0000644000000000000000000000215313340133255017711 0ustar0000000000000000# This is the shell file specified in the stack.yaml file. # This forces stack to use ghc-8.0.2 and stack-lts-9.yaml to compile termonad. let nixpkgsTarball = builtins.fetchTarball { # 17.09 (this works) #url = "https://github.com/NixOS/nixpkgs/archive/39cd40f7bea40116ecb756d46a687bfd0d2e550e.tar.gz"; #sha256 = "0kpx4h9p1lhjbn1gsil111swa62hmjs9g93xmsavfiki910s73sh"; # 18.03 url = "https://github.com/NixOS/nixpkgs/archive/120b013e0c082d58a5712cde0a7371ae8b25a601.tar.gz"; sha256 = "0hk4y2vkgm1qadpsm4b0q1vxq889jhxzjx3ragybrlwwg54mzp4f"; # recent version of nixpkgs as of 2018-07-25 (this only seems to sometimes work...?)) #url = "https://github.com/NixOS/nixpkgs/archive/4ccaa7de8eb34a0bb140f109a0e88095480118eb.tar.gz"; #sha256 = "0szbxfrzmlmxrgkqz5wnfgmsjp82vaddgz7mhdz7jj0jhd0hza4i"; }; nixpkgs = import nixpkgsTarball { }; in with nixpkgs; haskell.lib.buildStackProject { name = "termonad"; buildInputs = [ cairo gnome3.vte gobjectIntrospection gtk3 zlib ]; ghc = haskell.compiler.ghc802; extraArgs = [ "--stack-yaml stack-lts-9.yaml" ]; } termonad-0.2.1.0/.nix-helpers/termonad.nix0000644000000000000000000000237113336255165016530 0ustar0000000000000000{ mkDerivation, base, Cabal, cabal-doctest, classy-prelude, colour , constraints, data-default, doctest, dyre, gi-gdk, gi-gio, gi-glib , gi-gtk, gi-pango, gi-vte, gtk3, haskell-gi-base, hedgehog, lens , pretty-simple, QuickCheck, stdenv, tasty, tasty-hedgehog , template-haskell, xml-conduit, xml-html-qq }: mkDerivation { pname = "termonad"; version = "0.2.0.0"; src = builtins.filterSource (path: type: baseNameOf path != ".git" && baseNameOf path != "result" && baseNameOf path != ".stack-work" && baseNameOf path != "dist") ./..; isLibrary = true; isExecutable = true; doCheck = false; enableSeparateDataOutput = true; setupHaskellDepends = [ base Cabal cabal-doctest ]; libraryHaskellDepends = [ base 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 ]; libraryPkgconfigDepends = [ gtk3 ]; executableHaskellDepends = [ base ]; testHaskellDepends = [ base doctest hedgehog lens QuickCheck tasty tasty-hedgehog template-haskell ]; homepage = "https://github.com/cdepillabout/termonad"; description = "Terminal emulator configurable in Haskell"; license = stdenv.lib.licenses.bsd3; } termonad-0.2.1.0/shell.nix0000644000000000000000000000115413336412356013505 0ustar0000000000000000# This is a file that allows you to jump into an environment to be able to build termonad. # You can jump into this environment by running the command `nix-shell`. # # This also installs cabal, so you should be able to build termonad by running `cabal new-build`. # # In general, if you prefer to use `stack`, you probably won't use this file. { compiler ? "ghc843" }: let nixpkgs = import .nix-helpers/nixpkgs.nix; in (import ./default.nix { inherit compiler; }).env.overrideAttrs (oldAttrs: rec { nativeBuildInputs = oldAttrs.nativeBuildInputs ++ [ nixpkgs.pkgs.haskell.packages.${compiler}.cabal-install ]; })