coin-1.1: src/Coin/UI/Options/OptionsAccount.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.OptionsAccount (
OptionsAccountWidget,
optionsAccountNew,
optionsAccountToIDList
) 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 OptionsAccountWidget = OptionsAccountWidget {
optionsAccountRoot :: Gtk.VBox,
optionsAccountStore :: Gtk.ListStore (Entity AccountsTable)
}
instance Gtk.GObjectClass OptionsAccountWidget where
toGObject = Gtk.toGObject . optionsAccountRoot
unsafeCastGObject = undefined
instance Gtk.WidgetClass OptionsAccountWidget
optionsAccountNew :: MainState -> IO OptionsAccountWidget
optionsAccountNew 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) <- optionsAccountTableNew
(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
hbox Nothing False 4 $ do
pack Gtk.PackNatural 0 $ vbox Nothing False 4 $ do
buttonAttrs [ Gtk.buttonImagePosition := Gtk.PosTop ]
buttonFromStock (Just "buttonUp") Gtk.stockGoUp
buttonAttrs [ Gtk.buttonImagePosition := Gtk.PosTop ]
buttonFromStock (Just "buttonDown") Gtk.stockGoDown
pack Gtk.PackGrow 0 $ label Nothing ""
scrolledWindow (Just "scrolledWindow") $
putWidget treeView
let nameEntry = Gtk.castToEntry . fromJust $ getObject "entryName"
let buttonAdd = Gtk.castToButton . fromJust $ getObject "buttonAdd"
let buttonRemove = Gtk.castToButton . fromJust $ getObject "buttonRemove"
let buttonUpdate = Gtk.castToButton . fromJust $ getObject "buttonUpdate"
let buttonUp = Gtk.castToButton . fromJust $ getObject "buttonUp"
let buttonDown = Gtk.castToButton . fromJust $ getObject "buttonDown"
forM_ [buttonAdd, buttonUpdate, buttonRemove, buttonUp, buttonDown] $ flip Gtk.widgetSetSensitive False
observableRegister (mainStateSelectedAccountName mainState) $ \_ -> do
Gtk.widgetSetSensitive buttonAdd False
Gtk.widgetSetSensitive buttonUpdate False
Gtk.widgetSetSensitive buttonRemove False
Gtk.widgetSetSensitive buttonUp False
Gtk.widgetSetSensitive buttonDown False
Gtk.entrySetText nameEntry ""
selection <- Gtk.treeViewGetSelection treeView
Gtk.treeSelectionUnselectAll selection
void $ Gtk.on treeView Gtk.cursorChanged $ do
(index, Entity accountID account) <- optionsAccountGetCursor treeView store
listSize <- Gtk.listStoreGetSize store
let accountName = accountsTableName account
Gtk.entrySetText nameEntry accountName
Gtk.widgetSetSensitive buttonAdd False
Gtk.widgetSetSensitive buttonUpdate False
if or [ accountName == mainStateIncomeName mainState
, accountName == mainStateOutcomeName mainState
, accountName == mainStateCashName mainState ]
then Gtk.widgetSetSensitive buttonRemove False
else do
op <- runDB $ selectFirst ([ OperationsTableFrom ==. accountID ] ||. [ OperationsTableTo ==. accountID ]) []
case op of
Just _ -> Gtk.widgetSetSensitive buttonRemove False
Nothing -> Gtk.widgetSetSensitive buttonRemove True
if | index > 2 && index < listSize - 1 -> do
Gtk.widgetSetSensitive buttonUp True
Gtk.widgetSetSensitive buttonDown True
| index == 2 && listSize /= 3 -> do
Gtk.widgetSetSensitive buttonUp False
Gtk.widgetSetSensitive buttonDown True
| index == listSize - 1 && listSize /= 3 -> do
Gtk.widgetSetSensitive buttonUp True
Gtk.widgetSetSensitive buttonDown False
| otherwise -> do
Gtk.widgetSetSensitive buttonUp False
Gtk.widgetSetSensitive buttonDown False
void $ Gtk.on buttonUp Gtk.buttonActivated $ do
(index, entity) <- optionsAccountGetCursor treeView store
Gtk.listStoreRemove store index
Gtk.listStoreInsert store (index - 1) entity
Gtk.treeViewSetCursor treeView [index - 1] Nothing
optionsAccountUpdate mainState store
void $ Gtk.on buttonDown Gtk.buttonActivated $ do
(index, entity) <- optionsAccountGetCursor treeView store
Gtk.listStoreRemove store index
Gtk.listStoreInsert store (index + 1) entity
Gtk.treeViewSetCursor treeView [index + 1] Nothing
optionsAccountUpdate mainState store
void $ Gtk.on nameEntry Gtk.keyReleaseEvent $ do
liftIO $ do
name <- strip <$> Gtk.entryGetText nameEntry
if null name
then do
Gtk.widgetSetSensitive buttonAdd False
Gtk.widgetSetSensitive buttonUpdate False
else do
list <- Gtk.listStoreToList store
let filtered = filter (\(Entity _ account) -> name == accountsTableName account) list
if null filtered
then do
Gtk.widgetSetSensitive buttonAdd True
(is, _) <- Gtk.treeViewGetCursor treeView
case is of
[index] -> do
(Entity _ account) <- Gtk.listStoreGetValue store index
if or [ accountsTableName account == mainStateIncomeName mainState
, accountsTableName account == mainStateOutcomeName mainState
, accountsTableName account == mainStateCashName 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
let accountTable = AccountsTable name 0
accountID <- insert accountTable
liftIO $ Gtk.listStoreAppend store $ Entity accountID accountTable
Gtk.entrySetText nameEntry ""
Gtk.widgetSetSensitive buttonAdd False
Gtk.widgetSetSensitive buttonUpdate False
optionsAccountUpdate mainState store
void $ Gtk.on buttonRemove Gtk.buttonActivated $ do
(index, (Entity accountID account)) <- optionsAccountGetCursor treeView store
messageBoxNew Gtk.MessageQuestion
Gtk.ButtonsYesNo
(__"Do you want to remove" ++ " \'" ++ accountsTableName account ++ "\' " ++ __"account ?") $
\case
Gtk.ResponseYes -> do
Gtk.listStoreRemove store index
runDB $ delete accountID
optionsAccountUpdate mainState store
_ -> return ()
_ <- Gtk.on buttonUpdate Gtk.buttonActivated $ do
(index, (Entity accountID account)) <- optionsAccountGetCursor treeView store
messageBoxNew Gtk.MessageQuestion
Gtk.ButtonsYesNo
(__ "Do you want to update" ++ " \'" ++ accountsTableName account ++ "\' " ++ __"account name ?") $
\case
Gtk.ResponseYes -> do
name <- strip <$> Gtk.entryGetText nameEntry
runDB $ do
update accountID [AccountsTableName =. name]
Just updatedAccount <- get accountID
liftIO $ Gtk.listStoreSetValue store index (Entity accountID updatedAccount)
Gtk.widgetSetSensitive buttonAdd False
Gtk.widgetSetSensitive buttonUpdate False
optionsAccountUpdate mainState store
_ -> return ()
observableRegister (mainStateAccountsUpdated mainState) $ \entities -> do
listSize <- Gtk.listStoreGetSize store
when (listSize - 2 /= length entities) $ do
Gtk.listStoreClear store
(Just incomeEntity) <- runDB $ selectFirst [ AccountsTableId ==. mainStateIncomeID mainState ] []
(Just outcomeEntity) <- runDB $ selectFirst [ AccountsTableId ==. mainStateOutcomeID mainState ] []
forM_ [incomeEntity, outcomeEntity] $ Gtk.listStoreAppend store
forM_ entities $ Gtk.listStoreAppend store
Gtk.widgetShowAll root
return $ OptionsAccountWidget (Gtk.castToVBox root) store
where
optionsAccountGetCursor treeView store = do
([index], _) <- Gtk.treeViewGetCursor treeView
entity <- Gtk.listStoreGetValue store index
return (index, entity)
optionsAccountToIDList :: OptionsAccountWidget -> IO [AccountsTableId]
optionsAccountToIDList accountWidget = do
list <- Gtk.listStoreToList $ optionsAccountStore accountWidget
forM (drop 2 list) $ \(Entity accountID _) -> return accountID
optionsAccountUpdate :: MainState -> Gtk.ListStore (Entity AccountsTable) -> IO ()
optionsAccountUpdate mainState store = do
list <- Gtk.listStoreToList store
observableSet (mainStateAccountsUpdated mainState) $ drop 2 list
optionsAccountTableNew :: IO (Gtk.TreeView, Gtk.ListStore (Entity AccountsTable))
optionsAccountTableNew = do
treeView <- Gtk.treeViewNew
store <- Gtk.listStoreNew []
Gtk.treeViewSetModel treeView store
column1 <- tableTextColumnNew (__ "Name") store $ \(Entity _ account) -> [ Gtk.cellText := accountsTableName account ]
Gtk.treeViewSetHeadersVisible treeView False
_ <- Gtk.treeViewAppendColumn treeView column1
Gtk.widgetShowAll treeView
return (treeView, store)