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
|
{-# LANGUAGE OverloadedStrings #-}
-- | Notebook demo (include Spinner animation).
-- Author : Andy Stewart
-- Copyright : (c) 2010 Andy Stewart <lazycat.manatee@gmail.com>
module Main where
import Control.Monad
import Control.Monad.IO.Class
import Data.Maybe
import Data.Text (Text)
import Data.Monoid ((<>))
import Graphics.UI.Gtk
import qualified Data.Text as T (unpack)
data NotebookTab =
NotebookTab {ntBox :: HBox
,ntSpinner :: Spinner
,ntLabel :: Label
,ntCloseButton :: ToolButton
,ntSize :: Int}
-- | Main
main :: IO ()
main = do
-- Init.
initGUI
-- Create window and notebook.
window <- windowNew
notebook <- notebookNew
-- Set window.
windowSetDefaultSize window 800 600
windowSetPosition window WinPosCenter
set window [windowTitle := ("Press Ctrl + n to create new tab."::Text)]
-- Handle key press action.
window `on` keyPressEvent $ tryEvent $ do
-- Create new tab when user press Ctrl+n
[Control] <- eventModifier
"n" <- eventKeyName
liftIO $ do
-- Create text view.
textView <- textViewNew
widgetShowAll textView -- must show before add notebook,
-- otherwise notebook won't display child widget
-- even have add in notebook.
-- Create notebook tab.
tab <- notebookTabNew (Just "Cool tab") Nothing
menuLabel <- labelNew (Nothing :: Maybe Text)
-- Add widgets in notebook.
notebookAppendPageMenu notebook textView (ntBox tab) menuLabel
-- Start spinner animation when create tab.
notebookTabStart tab
-- Stop spinner animation after finish load.
timeoutAdd (notebookTabStop tab >> return False) 5000
-- Close tab when click button.
ntCloseButton tab `onToolButtonClicked` do
index <- notebookPageNum notebook textView
index ?>= \i -> notebookRemovePage notebook i
return ()
-- Show window.
window `containerAdd` notebook
widgetShowAll window
on window objectDestroy mainQuit
mainGUI
-- | Create notebook tab.
notebookTabNew :: Maybe Text -> Maybe Int -> IO NotebookTab
notebookTabNew name size = do
-- Init.
let iconSize = fromMaybe 12 size
box <- hBoxNew False 0
spinner <- spinnerNew
label <- labelNew name
image <- imageNewFromIcon "window-close" iconSize
closeButton <- toolButtonNew (Just image) (Nothing::Maybe Text)
-- Show.
boxPackStart box label PackNatural 0
boxPackStart box closeButton PackNatural 0
widgetShowAll box
return $ NotebookTab box spinner label closeButton iconSize
-- | Set tab name.
notebookTabSetName :: NotebookTab -> Text -> IO ()
notebookTabSetName tab =
labelSetText (ntLabel tab)
-- | Start spinner animation.
notebookTabStart :: NotebookTab -> IO ()
notebookTabStart NotebookTab {ntBox = box
,ntSpinner = spinner
,ntSize = size} = do
boxTryPack box spinner PackNatural (Just 0) (size `div` 2)
spinnerStart spinner
widgetShow spinner
-- | Stop spinner animation.
notebookTabStop :: NotebookTab -> IO ()
notebookTabStop NotebookTab {ntBox = box
,ntSpinner = spinner} = do
containerTryRemove box spinner
spinnerStop spinner
-- | Create image widget with given icon name and size.
imageNewFromIcon :: Text -> Int -> IO Image
imageNewFromIcon iconName size = do
iconTheme <- iconThemeGetDefault
pixbuf <- do
-- Function 'iconThemeLoadIcon' can scale icon with specified size.
pixbuf <- iconThemeLoadIcon iconTheme iconName size IconLookupUseBuiltin
case pixbuf of
Just p -> return p
Nothing -> error $ "imageNewFromIcon : search icon " <> T.unpack iconName <> " failed."
imageNewFromPixbuf pixbuf
-- | Try to packing widget in box.
-- If @child@ have exist parent, do nothing,
-- otherwise, add @child@ to @parent@.
boxTryPack :: (BoxClass parent, WidgetClass child) => parent -> child -> Packing -> Maybe Int -> Int -> IO ()
boxTryPack box widget packing order space = do
parent <- widgetGetParent widget
when (isNothing parent) $ do
boxPackStart box widget packing space
order ?>= boxReorderChild box widget
-- | Try to remove child from parent.
containerTryRemove :: (ContainerClass parent, WidgetClass child) => parent -> child -> IO ()
containerTryRemove parent widget = do
hasParent <- widgetGetParent widget
unless (isNothing hasParent) $ containerRemove parent widget
-- | Maybe.
(?>=) :: Monad m => Maybe a -> (a -> m ()) -> m ()
m ?>= f = maybe (return ()) f m
|
