module Hbro.Prompt where
import Hbro.Types
import Hbro.Util
import Hbro.Gtk.Entry
import Control.Conditional hiding(when)
import Control.Monad hiding(forM_, mapM_)
import Control.Monad.Error hiding(forM_, mapM_, when)
import Control.Monad.Reader hiding(forM_, mapM_, when)
import Control.Monad.Trans.Control
import Data.Foldable
import Data.IORef
import Graphics.Rendering.Pango.Enums
import Graphics.UI.Gtk.Abstract.Widget
import Graphics.UI.Gtk.Builder
import Graphics.UI.Gtk.Display.Label
import Graphics.UI.Gtk.Entry.Editable
import Graphics.UI.Gtk.Entry.Entry
import Graphics.UI.Gtk.Gdk.EventM
import Graphics.UI.Gtk.Layout.HBox
import Network.URI hiding(parseURIReference)
import Prelude hiding(mapM_)
import System.Glib.Signals
instance Buildable PromptBar where
build builder = io $ do
label <- builderGetObject builder castToLabel "promptDescription"
entry <- builderGetObject builder castToEntry "promptEntry"
box <- builderGetObject builder castToHBox "promptBox"
return $ PromptBar box label entry
setup :: (MonadIO m, MonadBaseControl IO m, MonadReader r m, HasPromptBar r, HasHooks r, HasWebView r, MonadError HError m) => m ()
setup = do
label <- asks _promptDescription
io $ labelSetAttributes label [allItalic, allBold]
io $ labelSetAttributes label [AttrForeground {paStart = 0, paEnd = 1, paColor = Color 32767 32767 32767}]
entry <- asks _promptEntry
io $ widgetModifyBase entry StateNormal $ Color 0 0 0
io $ widgetModifyText entry StateNormal $ Color 32767 32767 32767
webView <- asks _webview
io . void . on entry keyPressEvent $ do
key <- eventKeyName
when (key == "Return" || key == "Escape") $ io $ do
widgetGrabFocus webView
return ()
return False
return ()
open :: (MonadIO m, MonadReader r m, HasPromptBar r) => String -> String -> m ()
open newDescription defaultText = do
logVerbose "Opening prompt."
entry <- asks _promptEntry
io . (`labelSetText` newDescription) =<< asks _promptDescription
io $ entrySetText entry defaultText
io . widgetShow =<< asks _promptBox
io $ widgetGrabFocus entry
io $ editableSetPosition entry (1)
clean :: (MonadIO m, MonadReader r m, HasHooks r, HasPromptBar r, MonadBaseControl IO m) => m ()
clean = do
entry <- asks _promptEntry
io $ widgetRestoreText entry StateNormal
io $ widgetModifyText entry StateNormal $ Color 32767 32767 32767
io . widgetHide =<< asks _promptBox
asks _promptChanged >>= \ref -> io $ readIORef ref >>= mapM_ signalDisconnect >> writeIORef ref Nothing
asks _promptValidated >>= \ref -> io $ readIORef ref >>= mapM_ signalDisconnect >> writeIORef ref Nothing
read :: (MonadIO m, MonadBaseControl IO m, MonadReader r m, HasConfig r, HasOptions r, HasPromptBar r, HasGUI r, HasZMQContext r, HasHooks r, MonadError HError m)
=> String
-> String
-> EntryHook
-> m ()
read = read' False
incrementalRead, iread :: (MonadIO m, MonadBaseControl IO m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasPromptBar r, HasZMQContext r, HasHooks r, MonadError HError m) => String -> String -> EntryHook -> m ()
incrementalRead = read' True
iread = incrementalRead
read' :: (MonadIO m, MonadBaseControl IO m, MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasPromptBar r, HasZMQContext r, HasHooks r, MonadError HError m) => Bool -> String -> String -> EntryHook -> m ()
read' incremental description startValue f = do
clean
open description startValue
(PromptBar { _entry = entry }) <- asks _promptBar
when incremental $ onEntryChanged entry f >>= \i -> asks _promptChanged >>= io . (`writeIORef` Just i)
onEntryValidated entry (f >=> const clean) >>= \i -> asks _promptValidated >>= io . (`writeIORef` Just i)
return ()
readURI :: (MonadReader r m, HasConfig r, HasOptions r, HasGUI r, HasPromptBar r, HasZMQContext r, HasHooks r, MonadBaseControl IO m, MonadIO m, MonadError HError m)
=> String -> String -> EntryURIHook -> m ()
readURI description startValue callback = do
clean
open description startValue
checkURI startValue
(PromptBar { _entry = entry }) <- asks _promptBar
id1 <- onEntryChanged entry $ checkURI
id2 <- onEntryValidated entry $ parseURIReference >=> callback >=> const clean
asks _promptChanged >>= io . (`writeIORef` Just id1)
asks _promptValidated >>= io . (`writeIORef` Just id2)
return ()
where
checkURI :: EntryHook
checkURI value = do
(PromptBar { _entry = entry }) <- asks _promptBar
io $ widgetModifyText entry StateNormal color
where
color = (isURIReference value) ? green ?? red
green = Color 0 65535 0
red = Color 65535 0 0