Permalink
Browse files

add colour to configuration file

if running and stopped colours are not present just use
the standard defaults

Signed-off-by: Christopher Hall <hsw@ms2.hinet.net>
  • Loading branch information...
1 parent bc7531f commit d9c4c75df32e585f7fcd0ccacbc25e46a829bd74 @hxw committed Jul 1, 2012
Showing with 157 additions and 72 deletions.
  1. +124 −40 ConfigurationParser.hs
  2. +31 −32 TerminalUI.hs
  3. +2 −0 config.rc
View
164 ConfigurationParser.hs
@@ -10,6 +10,8 @@ import qualified Text.ParserCombinators.Parsec.Token as P
import qualified Text.Parsec.Prim as N
import Text.ParserCombinators.Parsec.Language
+import qualified Graphics.UI.Gtk as GTK
+
import System.IO
import qualified Data.HashTable as HT
import Control.Monad.Trans (liftIO, lift)
@@ -27,12 +29,17 @@ data CommandItem = Argument String
type CommandList = [CommandItem]
type SendList = [String]
+
+type Colour = GTK.Color
+
data PaneRecord =
- PaneRecord { paneTitle :: String
- , paneAuto :: Bool
- , paneDir :: Maybe String
- , paneRun :: String
- , paneSend :: SendList
+ PaneRecord { paneTitle :: String
+ , paneAuto :: Bool
+ , paneDir :: Maybe String
+ , paneRun :: String
+ , paneSend :: SendList
+ , paneRunning :: Maybe Colour
+ , paneStopped :: Maybe Colour
} deriving Show
data Orientation = LeftTabs | RightTabs | TopTabs | BottomTabs
@@ -57,12 +64,14 @@ data UserState =
, usSessions :: SessionHash
, usErrorCount :: Integer
, usWarningCount :: Integer
- , usCurrentPaneStart :: Maybe Bool
- , usCurrentPaneRun :: Maybe String
- , usCurrentPaneDir :: Maybe String
- , usCurrentPaneSend :: SendList
- , usCurrentSessionButtons :: [String]
- , usCurrentSessionTabs :: [String]
+ , usCurrentPaneStart :: Maybe Bool
+ , usCurrentPaneRun :: Maybe String
+ , usCurrentPaneDir :: Maybe String
+ , usCurrentPaneSend :: SendList
+ , usCurrentPaneRunning :: Maybe Colour
+ , usCurrentPaneStopped :: Maybe Colour
+ , usCurrentSessionButtons :: [String]
+ , usCurrentSessionTabs :: [String]
}
initUserState cmdHT paneHT sessionHT =
@@ -71,12 +80,14 @@ initUserState cmdHT paneHT sessionHT =
, usSessions = sessionHT
, usErrorCount = 0
, usWarningCount = 0
- , usCurrentPaneStart = Nothing
- , usCurrentPaneRun = Nothing
- , usCurrentPaneDir = Nothing
- , usCurrentPaneSend = []
- , usCurrentSessionButtons = []
- , usCurrentSessionTabs = []
+ , usCurrentPaneStart = Nothing
+ , usCurrentPaneRun = Nothing
+ , usCurrentPaneDir = Nothing
+ , usCurrentPaneSend = []
+ , usCurrentPaneRunning = Nothing
+ , usCurrentPaneStopped = Nothing
+ , usCurrentSessionButtons = []
+ , usCurrentSessionTabs = []
}
@@ -99,6 +110,8 @@ lexer = P.makeTokenParser
, reservedNames = [ "auto"
, "bottom"
, "button"
+ , "color"
+ , "colour"
, "command"
, "cwd"
, "default"
@@ -107,7 +120,9 @@ lexer = P.makeTokenParser
, "pane"
, "right"
, "run"
+ , "running"
, "start"
+ , "stopped"
, "send-line"
, "tab"
, "tab-name"
@@ -126,8 +141,10 @@ lexeme = P.lexeme lexer
symbol = P.symbol lexer
stringLiteral = P.stringLiteral lexer
natural = P.natural lexer
+hexadecimal = P.hexadecimal lexer
parens = P.parens lexer
braces = P.braces lexer
+comma = P.comma lexer
semi = P.semi lexer
identifier = P.identifier lexer
reserved = P.reserved lexer
@@ -265,6 +282,8 @@ paneSetup name = do
, usCurrentPaneDir = Nothing
, usCurrentPaneRun = Nothing
, usCurrentPaneSend = []
+ , usCurrentPaneRunning = Nothing
+ , usCurrentPaneStopped = Nothing
}
setState sNew
@@ -284,13 +303,17 @@ paneCompile pos name title = do
, usCurrentPaneDir = dir
, usCurrentPaneRun = run
, usCurrentPaneSend = send
- } = s
+ , usCurrentPaneRunning = running
+ , usCurrentPaneStopped = stopped
+ } = s
let pane = PaneRecord { paneTitle = title
, paneAuto = fromMaybe True start
, paneRun = fromJust run
, paneDir = dir
, paneSend = send
+ , paneRunning = running
+ , paneStopped = stopped
}
lift $ HT.insert hPane name pane
@@ -385,31 +408,90 @@ sendCompile pos str = do
setState sNew
+runningSetup :: MyParser SourcePos
+runningSetup = do
+ s <- getState
+ blockStartPos <- getPosition
+ let UserState { usCurrentPaneRunning = n } = s
+ if isNothing n then return ()
+ else warning "duplicate running option"
+ return blockStartPos
+
+
+runningCompile :: SourcePos -> Colour -> MyParser ()
+runningCompile pos colour = do
+ s <- getState
+ let sNew = s { usCurrentPaneRunning = Just colour }
+ setState sNew
+
+
+stoppedSetup :: MyParser SourcePos
+stoppedSetup = do
+ blockStartPos <- getPosition
+ s <- getState
+ let UserState { usCurrentPaneStopped = n } = s
+ if isNothing n then return ()
+ else warning "duplicate stopped option"
+ return blockStartPos
+
+
+stoppedCompile :: SourcePos -> Colour -> MyParser ()
+stoppedCompile pos colour = do
+ s <- getState
+ let sNew = s { usCurrentPaneStopped = Just colour }
+ setState sNew
+
+
+
paneItem :: MyParser ()
paneItem =
- do{ reserved "run"
- ; state <- runSetup
- ; r <- identifier
- ; runCompile state r
- }
- <|> do{ reserved "cwd"
- ; state <- cwdSetup
- ; r <- stringLiteral
- ; cwdCompile state r
- }
- <|> do{ reserved "start"
- ; state <- startSetup
- ; f <- ((reserved "auto" >> return True) <|> (reserved "manual" >> return False))
- ; startCompile state f
- }
- <|> do{ reserved "send-line"
- ; state <- sendSetup
- ; s <- stringLiteral
- ; sendCompile state s
- }
+ do
+ reserved "run"
+ state <- runSetup
+ r <- identifier
+ runCompile state r
+ <|> do
+ reserved "cwd"
+ state <- cwdSetup
+ r <- stringLiteral
+ cwdCompile state r
+ <|> do
+ reserved "start"
+ state <- startSetup
+ f <- ((reserved "auto" >> return True) <|> (reserved "manual" >> return False))
+ startCompile state f
+ <|> do
+ reserved "send-line"
+ state <- sendSetup
+ s <- stringLiteral
+ sendCompile state s
+ <|> do
+ reserved "running"
+ state <- runningSetup
+ c <- colourItem
+ runningCompile state c
+ <|> do
+ reserved "stopped"
+ state <- stoppedSetup
+ c <- colourItem
+ stoppedCompile state c
<?> "pane item"
+colourItem :: MyParser Colour
+colourItem = do
+ (reserved "colour" <|> reserved "color")
+ parens triplet
+ where
+ triplet = do
+ red <- natural
+ comma
+ green <- natural
+ comma
+ blue <- natural
+ return $ GTK.Color (fromIntegral red) (fromIntegral green) (fromIntegral blue)
+
+
-- session blocks
-- --------------
@@ -624,7 +706,7 @@ compile configFileName = do
-- simple tuple type for returning the expandex session
-type TabInfo = (String, Bool, Maybe String, CommandList, SendList)
+type TabInfo = (String, Bool, Maybe String, CommandList, SendList, Maybe Colour, Maybe Colour)
type TabInfoList = [TabInfo]
type ButtonInfoList = [TabInfo]
@@ -656,9 +738,11 @@ expandSession (hashCmd, hashPane, hashSession) name = do
, paneDir = dir
, paneRun = run
, paneSend = send
+ , paneRunning = running
+ , paneStopped = stopped
} = fromJust p
command <- HT.lookup hashCmd run
- return $ (title, start, dir, fromJust command, send)
+ return $ (title, start, dir, fromJust command, send, running, stopped)
-- take a command list and convert to a list of strings
-- expanding the integer value provided
View
63 TerminalUI.hs
@@ -48,13 +48,13 @@ run (orient, tabList, buttonList) = do
-- create all the initial table
mapM_ (\tab -> do
- let (title, start, dir, command, sendList) = tab
- addPane notebook title start dir command sendList) tabList
+ let (title, start, dir, command, sendList, running, stopped) = tab
+ addPane notebook title start dir command sendList running stopped) tabList
-- create buttons
foldlM (\(x, y) button -> do
- let (title, start, dir, command, sendList) = button
- addButton table x y notebook title start dir command sendList
+ let (title, start, dir, command, sendList, running, stopped) = button
+ addButton table x y notebook title start dir command sendList running stopped
let x1 = x + 1
if x > 4 then return (0, y + 1) else return (x1, y)
) (0, 0) buttonList
@@ -80,36 +80,35 @@ exitNotice = do
response <- GTK.dialogRun dialog
GTK.widgetDestroy dialog
-active :: GTK.Color
-active = GTK.Color 65535 50000 50000
-inactive :: GTK.Color
-inactive = GTK.Color 32767 32767 65535
-
-- add buttons to the button menu
-addButton :: GTK.Table -> Int -> Int -> GTK.Notebook -> String -> Bool -> Maybe String -> CP.CommandList -> [String] -> IO ()
-addButton table x y notebook title autoStart dir commandList sendList = do
+addButton :: GTK.Table -> Int -> Int -> GTK.Notebook -> String -> Bool -> Maybe String -> CP.CommandList -> [String] -> Maybe GTK.Color -> Maybe GTK.Color -> IO ()
+addButton table x y notebook title autoStart dir commandList sendList running stopped = do
label <- GTK.labelNew $ Just title
- GTK.widgetModifyFg label GTK.StateNormal active
- GTK.widgetModifyFg label GTK.StatePrelight active
- GTK.widgetModifyFg label GTK.StateActive active
+
+ case running of
+ Nothing -> return ()
+ Just colour -> do
+ GTK.widgetModifyFg label GTK.StateNormal colour
+ GTK.widgetModifyFg label GTK.StatePrelight colour
+ GTK.widgetModifyFg label GTK.StateActive colour
button <- GTK.buttonNew
--GTK.widgetModifyBg button GTK.StateNormal (GTK.Color 32767 32757 32767)
--GTK.widgetModifyBg button GTK.StatePrelight (GTK.Color 8191 8191 16383)
--GTK.widgetModifyBg button GTK.StateActive (GTK.Color 0 0 0)
GTK.containerAdd button label
- GTK.on button GTK.buttonActivated $ (addPane notebook title autoStart dir commandList sendList >> return ())
+ GTK.on button GTK.buttonActivated $ (addPane notebook title autoStart dir commandList sendList running stopped >> return ())
GTK.widgetShowAll button
GTK.tableAttachDefaults table button x (x + 1) y (y + 1)
return ()
-- add auto/manual stared panes
-addPane :: GTK.Notebook -> String -> Bool -> Maybe String -> CP.CommandList -> [String] -> IO Int
-addPane notebook title autoStart dir commandList sendList = do
+addPane :: GTK.Notebook -> String -> Bool -> Maybe String -> CP.CommandList -> [String] -> Maybe GTK.Color -> Maybe GTK.Color -> IO Int
+addPane notebook title autoStart dir commandList sendList running stopped = do
vbox <- GTK.vBoxNew False 0
GTK.widgetSetCanFocus vbox False
@@ -134,10 +133,10 @@ addPane notebook title autoStart dir commandList sendList = do
page <- GTK.notebookAppendPage notebook vbox title
tabLabel <- GTK.notebookGetTabLabel notebook vbox
- setTabTextColour tabLabel inactive
+ setTabTextColour tabLabel stopped
- GTK.on socket GTK.socketPlugRemoved $ unplug sb tabLabel socket refproc
- GTK.on socket GTK.socketPlugAdded $ plug tabLabel socket sendList
+ GTK.on socket GTK.socketPlugRemoved $ unplug sb tabLabel stopped socket refproc
+ GTK.on socket GTK.socketPlugAdded $ plug tabLabel running socket sendList
if autoStart
then do
@@ -170,41 +169,41 @@ press button socket title refproc dir commandList = do
-- detect the program creating its main window
-- delay in order to give it time to set itself up
-- send too quickly and the event queue locks up
-plug :: Maybe GTK.Widget -> GTK.Socket -> [String] -> IO ()
-plug tabLabel socket sendList = do
- h <- GTK.timeoutAdd (delayedSend tabLabel socket sendList) 1000
+plug :: Maybe GTK.Widget -> Maybe GTK.Color -> GTK.Socket -> [String] -> IO ()
+plug tabLabel colour socket sendList = do
+ h <- GTK.timeoutAdd (delayedSend tabLabel colour socket sendList) 1000
return ()
-- dummy routine to send a couple of test lines
-delayedSend :: Maybe GTK.Widget -> GTK.Socket -> [String] -> IO Bool
-delayedSend tabLabel socket sendList = do
+delayedSend :: Maybe GTK.Widget -> Maybe GTK.Color -> GTK.Socket -> [String] -> IO Bool
+delayedSend tabLabel colour socket sendList = do
mapM_ (SC.sendLine socket) sendList
- setTabTextColour tabLabel active
+ setTabTextColour tabLabel colour
return False
-- dialog to decide whether to restart the command
-unplug :: GTK.Button -> Maybe GTK.Widget -> GTK.Socket -> PR.ProcRef -> IO Bool
-unplug button tabLabel socket refproc = do
+unplug :: GTK.Button -> Maybe GTK.Widget -> Maybe GTK.Color -> GTK.Socket -> PR.ProcRef -> IO Bool
+unplug button tabLabel colour socket refproc = do
GTK.widgetHide socket
GTK.buttonSetLabel button "Restart"
PR.shutdown refproc
GTK.widgetShowAll button
- setTabTextColour tabLabel inactive
+ setTabTextColour tabLabel colour
return True
-- set the text colour of a tab label
-setTabTextColour :: Maybe GTK.Widget -> GTK.Color -> IO ()
-setTabTextColour Nothing _colour = return ()
-setTabTextColour (Just tabLabel) colour = do
+setTabTextColour :: Maybe GTK.Widget -> Maybe GTK.Color -> IO ()
+setTabTextColour (Just tabLabel) (Just colour) = do
GTK.widgetModifyFg tabLabel GTK.StateNormal colour
GTK.widgetModifyFg tabLabel GTK.StateActive colour
+setTabTextColour _ _ = return ()
-- change the main title to be the tab name
View
2 config.rc
@@ -44,6 +44,8 @@ command gvim {
pane p1 "Project 1" {
run urxvt
start manual
+ running colour(0x1fff,0xffff,0x1fff)
+ stopped colour(0xffff,0x1fff,0x1fff)
#cwd "/tmp"
send-line "export PROJECT=p1"
send-line "echo 'Hello World!'\" [aa]{BB}\""

0 comments on commit d9c4c75

Please sign in to comment.