This repository has been archived by the owner on Jan 15, 2022. It is now read-only.
/
Gui.hs
158 lines (134 loc) · 5.1 KB
/
Gui.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}
module Hbro.Gui where
-- {{{ Imports
--import Hbro.Core
import Hbro.Util
import Hbro.Prompt()
import Hbro.Types
import Hbro.Webkit.WebView()
import Control.Conditional
import Control.Monad hiding(forM_, mapM_)
import Control.Monad.IO.Class
import Control.Monad.Reader
--import Data.Foldable
import Data.Functor
import Graphics.Rendering.Pango.Enums
import Graphics.UI.Gtk.Abstract.Container
import Graphics.UI.Gtk.Abstract.Box
import Graphics.UI.Gtk.Abstract.Widget
import Graphics.UI.Gtk.Builder
import Graphics.UI.Gtk.Display.Label
import qualified Graphics.UI.Gtk.General.General as GTK
import Graphics.UI.Gtk.Layout.HBox
import Graphics.UI.Gtk.Layout.VBox
import Graphics.UI.Gtk.Scrolling.ScrolledWindow
import Graphics.UI.Gtk.WebKit.WebInspector
import Graphics.UI.Gtk.WebKit.WebView hiding(webViewLoadUri)
import Graphics.UI.Gtk.Windows.Window
import Prelude hiding(mapM_)
import System.Glib.Attributes
import System.Glib.Signals
import System.Glib.Types
-- }}}
-- Util
-- | Return the casted GObject corresponding to the given name (set in the builder's XML file)
getObject :: (MonadIO m, MonadReader r m, HasGUI r, GObjectClass a) => (GObject -> a) -> String -> m a
getObject cast name = do
builder <- asks _builder
io $ builderGetObject builder cast name
-- | Toggle a widget's visibility (provided for convenience).
toggleVisibility :: (MonadIO m, WidgetClass a) => a -> m ()
toggleVisibility widget = io $ do
visibility <- get widget widgetVisible
visibility ? widgetHide widget ?? widgetShow widget
build' :: (MonadIO m, MonadReader r m, HasConfig r) => m GUI
build' = do
xmlPath <- asks _UIFile
io . void $ GTK.initGUI
-- Load XML
xmlPath' <- io xmlPath
--logNormal $ "Loading GUI from " ++ xmlPath' ++ "... "
builder <- io builderNew
io $ builderAddFromFile builder xmlPath'
-- Build components
(webView, sWindow) <- build builder
(window, wBox) <- build builder
promptBar <- build builder
statusBar <- build builder
notificationBar <- build builder
inspectorWindow <- initWebInspector webView wBox
-- Show window
io $ widgetShowAll window
io $ widgetHide (_box promptBar)
--logNormal "Done."
return $ GUI {
__mainWindow = window,
__inspectorWindow = inspectorWindow,
__scrollWindow = sWindow,
__webView = webView,
__promptBar = promptBar,
__statusBar = statusBar,
__notificationBar = notificationBar,
__builder = builder
}
setupScrollWindow :: (MonadIO m, MonadReader r m, HasGUI r) => m ()
setupScrollWindow = do
window <- asks _scrollWindow
io $ scrolledWindowSetPolicy window PolicyNever PolicyNever
instance Buildable (Window, VBox) where
build builder = io $ do
window <- builderGetObject builder castToWindow "mainWindow"
box <- builderGetObject builder castToVBox "windowBox"
return (window, box)
setupWindow :: (MonadIO m, MonadReader r m, HasGUI r) => m ()
setupWindow = do
window <- asks _mainWindow
io . windowSetDefault window . Just =<< asks _webView
io $ windowSetDefaultSize window 800 600
io $ widgetModifyBg window StateNormal (Color 0 0 10000)
io . void $ onDestroy window GTK.mainQuit
instance Buildable StatusBar where
build builder = io $ StatusBar <$> builderGetObject builder castToHBox "statusBox"
instance Buildable NotificationBar where
build builder = io $ NotificationBar <$> builderGetObject builder castToLabel "notificationLabel"
-- {{{ Web inspector
initWebInspector :: (MonadIO m) => WebView -> VBox -> m (Window)
initWebInspector webView windowBox = do
inspector <- io $ webViewGetInspector webView
inspectorWindow <- io windowNew
io $ set inspectorWindow [ windowTitle := "hbro | Web inspector" ]
_ <- io $ on inspector inspectWebView $ \_ -> do
view <- webViewNew
containerAdd inspectorWindow view
return view
_ <- io $ on inspector showWindow $ do
widgetShowAll inspectorWindow
return True
-- TODO: when does this signal happen ?!
--_ <- on inspector finished $ return ()
-- Attach inspector to browser's main window
_ <- io $ on inspector attachWindow $ do
webview <- webInspectorGetWebView inspector
case webview of
Just view -> do
widgetHide inspectorWindow
containerRemove inspectorWindow view
widgetSetSizeRequest view (-1) 250
boxPackEnd windowBox view PackNatural 0
widgetShow view
return True
_ -> return False
-- Detach inspector in a distinct window
_ <- io $ on inspector detachWindow $ do
webview <- webInspectorGetWebView inspector
_ <- case webview of
Just view -> do
containerRemove windowBox view
containerAdd inspectorWindow view
widgetShowAll inspectorWindow
return True
_ -> return False
widgetShowAll inspectorWindow
return True
return inspectorWindow
-- }}}