Permalink
Browse files

URI prompts are now colored.

  • Loading branch information...
1 parent fc85aad commit 519f2cee5e5f1fc62b4eae1b18b6effdb3f2742a koral committed Apr 5, 2012
Showing with 59 additions and 43 deletions.
  1. +5 −8 Hbro/Hbro.hs
  2. +34 −27 Hbro/Prompt.hs
  3. +8 −8 Hbro/Socket.hs
  4. +12 −0 Hbro/Util.hs
View
@@ -10,7 +10,8 @@ module Hbro.Hbro (
import Hbro.Core
import Hbro.Gui
import Hbro.Keys
-import Hbro.Socket
+import qualified Hbro.Prompt as Prompt
+import qualified Hbro.Socket as Socket
import Hbro.Types
import Hbro.Util
@@ -162,7 +163,7 @@ realMain' environment@Environment{ mOptions = options, mConfig = config, mGUI =
_ -> return Nothing
runK environment $ do
- openIPCSocket
+ Socket.open
-- Custom start-up
mStartUp . mHooks $ config
@@ -171,7 +172,7 @@ realMain' environment@Environment{ mOptions = options, mConfig = config, mGUI =
-- Main loop
io mainGUI
- closeIPCSocket
+ Socket.close
interruptHandler :: IO ()
interruptHandler = whenLoud (putStrLn "Received SIGINT.") >> mainQuit
@@ -283,16 +284,12 @@ onPromptKeyPress env = do
when (key == "Return") . runK env $ io (entryGetText entry) >>= callback
when (key == "Return" || key == "Escape") $ do
- widgetHide box
- writeIORef callbackRef (const $ return ())
- writeIORef incrementalCallbackRef (const $ return ())
+ runK env Prompt.clean
widgetGrabFocus webView
return False
where
callbackRef = mCallbackRef . mPromptBar . mGUI $ env
- incrementalCallbackRef = mIncrementalCallbackRef . mPromptBar . mGUI $ env
entry = mEntry . mPromptBar . mGUI $ env
- box = mBox . mPromptBar . mGUI $ env
webView = mWebView . mGUI $ env
-- Incremental behavior
View
@@ -3,7 +3,7 @@ module Hbro.Prompt where
-- {{{ Imports
import Hbro.Core
import Hbro.Types
---import Hbro.Util
+import Hbro.Util
import Control.Monad hiding(forM_, mapM_)
--import Control.Monad.Trans
@@ -28,27 +28,34 @@ import System.Console.CmdArgs (whenLoud)
init :: Builder -> IO PromptBar
init builder = do
- label <- builderGetObject builder castToLabel "promptDescription"
- labelSetAttributes label [
- AttrStyle {paStart = 0, paEnd = -1, paStyle = StyleItalic},
- AttrWeight {paStart = 0, paEnd = -1, paWeight = WeightBold}]
-
+ label <- builderGetObject builder castToLabel "promptDescription"
+ labelSetAttributes label [allItalic, allBold]
+
entry <- builderGetObject builder castToEntry "promptEntry"
box <- builderGetObject builder castToHBox "promptBox"
callbackRef <- newIORef (const $ return () :: String -> K ())
incrementalCallbackRef <- newIORef (const $ return () :: String -> K ())
return $ PromptBar box label entry callbackRef incrementalCallbackRef
-open :: PromptBar -> String -> String -> IO ()
-open _promptBar@PromptBar {mBox = promptBox, mDescription = description, mEntry = entry} newDescription defaultText = do
- whenLoud $ putStrLn "Opening prompt."
+open :: String -> String -> K ()
+open newDescription defaultText = with (mPromptBar . mGUI) $ \(PromptBar promptBox description entry _ _) -> do
+ whenLoud . putStrLn $ "Opening prompt."
labelSetText description newDescription
entrySetText entry defaultText
widgetShow promptBox
widgetGrabFocus entry
editableSetPosition entry (-1)
+
+-- | Close prompt, clean its content and callbacks
+clean :: K ()
+clean = with (mPromptBar . mGUI) $ \(PromptBar box description entry cRef iRef) -> do
+ widgetRestoreText entry StateNormal
+ widgetHide box
+ writeIORef cRef (const $ return ())
+ writeIORef iRef (const $ return ())
+
-- | Open prompt bar with given description and default value,
-- and register a callback to trigger at validation.
@@ -61,28 +68,28 @@ read = read' False
-- | Same as 'prompt', but callback is triggered for each change in prompt's entry.
incrementalRead, iread :: String -> String -> (String -> K ()) -> K ()
incrementalRead = read' True
+-- | Alias for incrementalRead.
iread = incrementalRead
read' :: Bool -> String -> String -> (String -> K ()) -> K ()
-read' incremental description startValue callback = with (mPromptBar . mGUI) $ \promptBar -> do
- open promptBar description startValue
-
--- Register callback
- case incremental of
+read' incremental description startValue callback = do
+ open description startValue
+ with (mPromptBar . mGUI) $ \promptBar -> case incremental of
True -> writeIORef (mIncrementalCallbackRef promptBar) callback
_ -> writeIORef (mCallbackRef promptBar) callback
--- | "read"" for URI values
-readURI :: String
- -> String
- -> (URI -> K ())
- -> K ()
-readURI description startValue callback = with (mPromptBar . mGUI) $ \promptBar -> do
- open promptBar description startValue
-
--- writeIORef (mIncrementalCallbackRef promptBar) checkURI
- writeIORef (mCallbackRef promptBar) $ mapM_ callback . parseURIReference
+-- | Same as "read" for URI values
+readURI :: String -> String -> (URI -> K ()) -> K ()
+readURI description startValue callback = withK (mPromptBar . mGUI) $ \promptBar -> do
+ open description startValue
+ checkURI startValue
---checkURI :: String -> K ()
---checkURI value = case isURI value of
--- True ->
+ io . writeIORef (mIncrementalCallbackRef promptBar) $ checkURI
+ io . writeIORef (mCallbackRef promptBar) $ mapM_ callback . parseURIReference
+ where
+ checkURI value = with (mEntry . mPromptBar . mGUI) $ \entry -> do
+ widgetModifyText entry StateNormal color
+ where
+ color = case isURI value of
+ True -> Color 0 65535 0
+ _ -> Color 65535 0 0
View
@@ -1,7 +1,7 @@
module Hbro.Socket where
-- {{{ Imports
-import Hbro.Core
+import Hbro.Core hiding(getURI)
import Hbro.Util
import Hbro.Types
@@ -21,9 +21,9 @@ import System.Posix.Types
import System.ZMQ
-- }}}
--- | Open socket
-openIPCSocket :: K ()
-openIPCSocket = do
+-- | Open a response-socket at configured location, named hbro.<pid>, and start listening for commands
+open :: K ()
+open = do
-- Resolve socket URI
pid <- io getProcessID
socketURI <- with (mSocketDir . mConfig) $ resolve >=> (return . (socketFile pid))
@@ -37,8 +37,8 @@ openIPCSocket = do
-- | Close the response socket by sending it the command "QUIT".
-- Typically called when exiting application.
-closeIPCSocket :: K ()
-closeIPCSocket = getSocketURI >>= \uri -> do
+close :: K ()
+close = getURI >>= \uri -> do
(io . whenLoud . putStrLn . ("Closing socket " ++) . (++ " ...")) uri
(void . (`sendCommand` "QUIT")) uri
@@ -65,8 +65,8 @@ readCommands sock = do
readCommands sock
-getSocketURI :: K String
-getSocketURI = with (mSocketDir . mConfig) $ \dir -> do
+getURI :: K String
+getURI = with (mSocketDir . mConfig) $ \dir -> do
dir' <- resolve dir
(`socketFile` dir') `fmap` getProcessID
View
@@ -1,4 +1,5 @@
module Hbro.Util (
+-- * General purpose
io,
resolve,
-- * Process management
@@ -8,6 +9,9 @@ module Hbro.Util (
isCaseSensitive,
isForward,
isWrapped,
+-- * Common pango attributes
+ allItalic,
+ allBold,
-- * Misc
send'',
labelSetMarkupTemporary,
@@ -27,6 +31,7 @@ import Data.ByteString (ByteString)
--import Data.IORef
import Data.List
+import Graphics.Rendering.Pango.Enums
import Graphics.UI.Gtk.Display.Label
import Graphics.UI.Gtk.General.General
@@ -49,6 +54,7 @@ io = liftIO
send'' :: Socket a -> ByteString -> IO ()
send'' x y = send x y []
+-- |
resolve :: (RefDirs -> a) -> IO a
resolve f = do
homeDir <- getHomeDirectory
@@ -122,3 +128,9 @@ isForward _ = False
isWrapped :: Wrap -> Bool
isWrapped Wrap = True
isWrapped _ = False
+
+-- Common pango attributes
+allItalic, allBold :: PangoAttribute
+allItalic = AttrStyle {paStart = 0, paEnd = -1, paStyle = StyleItalic}
+allBold = AttrWeight {paStart = 0, paEnd = -1, paWeight = WeightBold}
+

0 comments on commit 519f2ce

Please sign in to comment.