coin-1.1: src/Coin/UI/Options/OptionsTag.hs
{-
* Programmer: Piotr Borek
* E-mail: piotrborek@op.pl
* Copyright 2015 Piotr Borek
*
* Distributed under the terms of the GPL (GNU Public License)
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
module Coin.UI.Options.OptionsTag (
OptionsTagWidget,
optionsTagNew
) where
import qualified System.Glib.Types as Gtk
import qualified Graphics.UI.Gtk as Gtk
import Graphics.UI.Gtk ( AttrOp(..) )
import Data.Maybe
import Control.Monad
import Control.Monad.IO.Class
import Database.Persist
import Coin.DB.Tables
import Coin.DB.Functions
import Coin.Locale.Translate
import Coin.Utils.StringUtils
import Coin.UI.Widgets.MessageBox
import Coin.Utils.TableView
import Coin.UI.Builder.GtkUIBuilder
import Coin.UI.Utils.CssUtils
import Coin.UI.MainState
data OptionsTagWidget = OptionsTagWidget {
widgetContainer :: Gtk.VBox
}
instance Gtk.GObjectClass OptionsTagWidget where
toGObject = Gtk.toGObject . widgetContainer
unsafeCastGObject = undefined
instance Gtk.WidgetClass OptionsTagWidget
optionsTagNew :: MainState -> IO OptionsTagWidget
optionsTagNew mainState = do
let buttonCss =
[ "* {"
, " transition: 200ms ease-in-out;"
, "}"
, "button {"
, " border-width: 1px;"
, " padding: 5px;"
, "}"
, "button:hover {"
, " border-color: rgba(40, 40, 40, 0.5);"
, "}"
]
(treeView, store) <- optionsTagTableNew
(getObject, root) <- uiBuildGtk $ do
vbox Nothing False 0 $ do
pack Gtk.PackNatural 4 $ hbox Nothing False 4 $ do
label Nothing (__"Name")
pack Gtk.PackGrow 0 $ entry (Just "entryName") ""
hbox Nothing True 0 $ do
packing Gtk.PackGrow 0
buttonAttrs [ Gtk.buttonImagePosition := Gtk.PosTop, Gtk.buttonRelief := Gtk.ReliefNone, cssStyle := buttonCss ]
buttonFromStock (Just "buttonAdd") Gtk.stockAdd
buttonAttrs [ Gtk.buttonImagePosition := Gtk.PosTop, Gtk.buttonRelief := Gtk.ReliefNone, cssStyle:= buttonCss ]
buttonFromStock (Just "buttonUpdate") Gtk.stockRefresh
buttonAttrs [ Gtk.buttonImagePosition := Gtk.PosTop, Gtk.buttonRelief := Gtk.ReliefNone, cssStyle := buttonCss ]
buttonFromStock (Just "buttonRemove") Gtk.stockRemove
scrolledWindow Nothing $
putWidget treeView
let nameEntry = Gtk.castToEntry . fromJust $ getObject "entryName"
let buttonAdd = Gtk.castToButton . fromJust $ getObject "buttonAdd"
let buttonUpdate = Gtk.castToButton . fromJust $ getObject "buttonUpdate"
let buttonRemove = Gtk.castToButton . fromJust $ getObject "buttonRemove"
forM_ [buttonAdd, buttonUpdate, buttonRemove] $ flip Gtk.widgetSetSensitive False
observableRegister (mainStateSelectedAccountName mainState) $ \_ -> do
Gtk.widgetSetSensitive buttonAdd False
Gtk.widgetSetSensitive buttonUpdate False
Gtk.widgetSetSensitive buttonRemove False
Gtk.entrySetText nameEntry ""
selection <- Gtk.treeViewGetSelection treeView
Gtk.treeSelectionUnselectAll selection
void $ Gtk.on treeView Gtk.cursorChanged $ do
(_, (Entity tagID tag)) <- optionsTagGetCursor treeView store
let tagName = tagsTableName tag
Gtk.entrySetText nameEntry tagName
Gtk.widgetSetSensitive buttonAdd False
Gtk.widgetSetSensitive buttonUpdate False
if tagName == mainStateNoneName mainState
then Gtk.widgetSetSensitive buttonRemove False
else do
op <- runDB $ selectFirst [ OperationsTableTag ==. tagID ] []
case op of
Just _ -> Gtk.widgetSetSensitive buttonRemove False
Nothing -> Gtk.widgetSetSensitive buttonRemove True
void $ Gtk.on nameEntry Gtk.keyReleaseEvent $ do
liftIO $ do
name <- strip <$> Gtk.entryGetText nameEntry
if name == []
then do
Gtk.widgetSetSensitive buttonAdd False
Gtk.widgetSetSensitive buttonUpdate False
else do
list <- Gtk.listStoreToList store
let filtered = filter (\(Entity _ tag) -> name == tagsTableName tag) list
if length filtered == 0
then do
Gtk.widgetSetSensitive buttonAdd True
(is, _) <- Gtk.treeViewGetCursor treeView
case is of
[index] -> do
(Entity _ tag) <- Gtk.listStoreGetValue store index
if tagsTableName tag == mainStateNoneName mainState
then Gtk.widgetSetSensitive buttonUpdate False
else Gtk.widgetSetSensitive buttonUpdate True
_ ->
Gtk.widgetSetSensitive buttonUpdate False
else do
Gtk.widgetSetSensitive buttonAdd False
Gtk.widgetSetSensitive buttonUpdate False
return True
void $ Gtk.on buttonAdd Gtk.buttonActivated $ do
name <- strip <$> Gtk.entryGetText nameEntry
void $ runDB $ do
tagID <- insert $ TagsTable name
liftIO $ Gtk.listStoreAppend store $ Entity tagID (TagsTable name)
Gtk.entrySetText nameEntry ""
Gtk.widgetSetSensitive buttonAdd False
Gtk.widgetSetSensitive buttonUpdate False
optionsTagUpdate mainState store
void $ Gtk.on buttonUpdate Gtk.buttonActivated $ do
(index, Entity tagID tag) <- optionsTagGetCursor treeView store
messageBoxNew Gtk.MessageQuestion
Gtk.ButtonsYesNo
((__"Do you want to update") ++ " \'" ++ tagsTableName tag ++ "\' " ++ (__"tag name ?")) $
\case
Gtk.ResponseYes -> do
name <- strip <$> Gtk.entryGetText nameEntry
runDB $ do
update tagID [TagsTableName =. name]
Just updatedTag <- get tagID
liftIO $ Gtk.listStoreSetValue store index (Entity tagID updatedTag)
Gtk.widgetSetSensitive buttonAdd False
Gtk.widgetSetSensitive buttonUpdate False
optionsTagUpdate mainState store
_ -> return ()
void $ Gtk.on buttonRemove Gtk.buttonActivated $ do
(index, Entity tagID tag) <- optionsTagGetCursor treeView store
messageBoxNew Gtk.MessageQuestion
Gtk.ButtonsYesNo
((__"Do you want to remove") ++ " \'" ++ tagsTableName tag ++ "\' " ++ (__"tag ?")) $
\case
Gtk.ResponseYes -> do
Gtk.listStoreRemove store index
runDB $ delete tagID
optionsTagUpdate mainState store
_ -> return ()
observableRegister (mainStateTagsUpdated mainState) $ \entities -> do
listSize <- Gtk.listStoreGetSize store
when (listSize /= length entities) $ do
Gtk.listStoreClear store
forM_ entities $ Gtk.listStoreAppend store
Gtk.widgetShowAll root
return $ OptionsTagWidget $ Gtk.castToVBox root
where
optionsTagGetCursor treeView store = do
([index], _) <- Gtk.treeViewGetCursor treeView
entity <- Gtk.listStoreGetValue store index
return (index, entity)
optionsTagUpdate :: MainState -> Gtk.ListStore (Entity TagsTable) -> IO ()
optionsTagUpdate mainState store = do
list <- Gtk.listStoreToList store
observableSet (mainStateTagsUpdated mainState) list
optionsTagTableNew :: IO (Gtk.TreeView, Gtk.ListStore (Entity TagsTable))
optionsTagTableNew = do
treeView <- Gtk.treeViewNew
store <- Gtk.listStoreNew []
Gtk.treeViewSetModel treeView store
column1 <- tableTextColumnNew (__ "Name") store $ \(Entity _ tag) -> [ Gtk.cellText := tagsTableName tag ]
Gtk.treeViewSetHeadersVisible treeView False
_ <- Gtk.treeViewAppendColumn treeView column1
Gtk.widgetShowAll treeView
return (treeView, store)