coin-1.2: src/Coin/UI/Accounts/AccountsIncome.hs
{-
* Programmer: Piotr Borek
* E-mail: piotrborek@op.pl
* Copyright 2016 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.Accounts.AccountsIncome (
accountsIncomeNew
) where
import qualified Graphics.UI.Gtk as Gtk
import Graphics.UI.Gtk ( AttrOp(..) )
import qualified Data.Text as T
import qualified Data.List as List
import Database.Persist
import Data.Maybe
import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.IO.Class
import Coin.DB.Tables
import Coin.DB.Functions
import Coin.UI.MainState
import Coin.UI.Widgets.Calendar
import Coin.UI.Builder.GtkUIBuilder
import Coin.UI.TagsComboBox
import Coin.UI.Utils.CalendarUtils
import Coin.Locale.Translate
import Coin.Utils.ValueParser
import Coin.UI.HistoryView
accountsIncomeNew :: MainState -> IO Gtk.Widget
accountsIncomeNew mainState = do
cal <- calendarNew CalendarSizeNormal
operationsView <- historyViewNew True False False
tagsBox <- tagsComboBoxNew mainState
(getObject, root) <- uiBuildGtk $ do
globalCss [ "#Marked {"
, " font-weight: bold;"
, "}"
, "image {"
, " margin-left: 10px;"
, "}"
]
gridAttrs [ gridRowHomogeneous := False, gridColumnHomogeneous := False, gridColumnSpacing := 4, gridRowSpacing := 8, Gtk.containerBorderWidth := 4 ]
grid Nothing $ do
gridAttach 0 0 1 1 $ do
labelAttrs [ Gtk.miscXalign := 1.0, Gtk.widgetName := Just "Marked" ]
label Nothing (__"Date:")
gridAttach 1 0 1 1 $ do
widgetAttrs [ Gtk.widgetVExpand := False, Gtk.widgetHExpand := True ]
putWidget cal
gridAttach 0 1 1 1 $ do
labelAttrs [ Gtk.miscXalign := 1.0, Gtk.widgetName := Just "Marked" ]
label Nothing (__"Tag:")
gridAttach 1 1 1 1 $ putWidget tagsBox
gridAttach 0 2 1 1 $ do
labelAttrs [ Gtk.miscXalign := 1.0, Gtk.widgetName := Just "Marked" ]
label Nothing (__"Add value:")
gridAttach 1 2 1 1 $ hbox Nothing False 0 $ do
pack Gtk.PackNatural 0 $ entry (Just "entryValue") ""
pack Gtk.PackNatural 0 $ imageFromStock (Just "errorValue") Gtk.stockDialogError Gtk.IconSizeMenu
label Nothing ""
gridAttach 0 3 1 1 $ do
labelAttrs [ Gtk.miscXalign := 1.0, Gtk.widgetName := Just "Marked" ]
label Nothing (__"To account:")
gridAttach 1 3 1 1 $ do
labelAttrs [ Gtk.miscXalign := 0.0 ]
label (Just "accountName") ""
gridAttach 0 4 1 1 $ do
labelAttrs [ Gtk.miscXalign := 1.0, Gtk.widgetName := Just "Marked" ]
label Nothing (__"Description:")
gridAttach 1 4 1 1 $ entry (Just "entryDescription") ""
gridAttach 0 5 1 1 $ do
labelAttrs [ Gtk.miscXalign := 1.0, Gtk.widgetName := Just "Marked" ]
label Nothing (__"Current balance:")
gridAttach 1 5 1 1 $ do
labelAttrs [ Gtk.miscXalign := 0.0 ]
label (Just "balance") "0.00"
gridAttach 0 6 2 1 $ hbox Nothing False 0 $ do
label Nothing ""
buttonAttrs [ Gtk.widgetWidthRequest := 150, Gtk.buttonImagePosition := Gtk.PosLeft ]
pack Gtk.PackNatural 0 $ buttonFromStock (Just "buttonAdd") Gtk.stockAdd
gridAttach 0 7 2 1 $ do
widgetAttrs [ Gtk.widgetVExpand := True, Gtk.widgetHExpand := True ]
scrolledWindow Nothing $ putWidget operationsView
gridAttach 0 8 2 1 $ hbox Nothing False 0 $ do
label Nothing ""
buttonAttrs [ Gtk.widgetWidthRequest := 150, Gtk.buttonImagePosition := Gtk.PosLeft ]
pack Gtk.PackNatural 0 $ buttonFromStock (Just "buttonRemove") Gtk.stockRemove
let entryValue = Gtk.castToEntry . fromJust . getObject $ "entryValue"
let errorValue = fromJust . getObject $ "errorValue"
let entryDescription = Gtk.castToEntry . fromJust . getObject $ "entryDescription"
let buttonAdd = Gtk.castToButton . fromJust . getObject $ "buttonAdd"
let buttonRemove = Gtk.castToButton . fromJust . getObject $ "buttonRemove"
let accountName = Gtk.castToLabel . fromJust . getObject $ "accountName"
let balance = Gtk.castToLabel . fromJust . getObject $ "balance"
Gtk.widgetSetSensitive buttonAdd False
Gtk.widgetSetSensitive buttonRemove False
observableRegister (mainStateSelectedAccountName mainState) $ \name -> do
labelName <- Gtk.labelGetText accountName
when (labelName /= name) $ do
Gtk.labelSetText accountName name
accountsIncomeViewUpdate mainState operationsView accountName cal
accountsIncomeBalanceUpdate accountName balance
void $ Gtk.on entryValue Gtk.keyReleaseEvent $ do
value <- liftIO $ parseValue <$> Gtk.entryGetText entryValue
liftIO $ case value of
Just _ -> do
Gtk.widgetHide errorValue
Gtk.widgetSetSensitive buttonAdd True
Nothing -> do
Gtk.widgetShow errorValue
Gtk.widgetSetSensitive buttonAdd False
return True
void $ Gtk.on buttonAdd Gtk.buttonActivated $ do
value <- parseValue <$> Gtk.entryGetText entryValue
case value of
Just value' -> do
accountsIncomeAppend mainState cal tagsBox accountName entryDescription value'
Gtk.entrySetText entryValue ""
Gtk.entrySetText entryDescription ""
Gtk.widgetShow errorValue
Gtk.widgetSetSensitive buttonAdd False
accountsIncomeViewUpdate mainState operationsView accountName cal
accountsIncomeBalanceUpdate accountName balance
name <- Gtk.labelGetText accountName
observableSet (mainStateSelectedAccountName mainState) name
Nothing ->
return ()
void $ Gtk.on buttonRemove Gtk.buttonActivated $ do
entity <- historyViewGetSelected operationsView
case entity of
Just entity' -> do
accountsIncomeRemove accountName entity'
accountsIncomeViewUpdate mainState operationsView accountName cal
accountsIncomeBalanceUpdate accountName balance
name <- Gtk.labelGetText accountName
observableSet (mainStateSelectedAccountName mainState) name
Nothing -> return ()
void $ Gtk.on operationsView Gtk.cursorChanged $ do
(path, _) <- Gtk.treeViewGetCursor operationsView
if List.null path
then Gtk.widgetSetSensitive buttonRemove False
else Gtk.widgetSetSensitive buttonRemove True
(y, _, _) <- calendarGetSelectedDate cal
curYear <- newMVar y
calendarOnChange cal $ \year _ _ -> do
yy <- readMVar curYear
when (yy /= year) $ do
modifyMVar_ curYear $ const $ return year
accountsIncomeViewUpdate mainState operationsView accountName cal
accountsIncomeBalanceUpdate accountName balance
mainStateSavePropertiesAction mainState "Coin.UI.Accounts.AccountsIncome" $ do
i <- liftIO $ Gtk.comboBoxGetActive tagsBox
propertyInsert "i" i
mainStateReadPropertiesAction mainState "Coin.UI.Accounts.AccountsIncome" $ do
propertyRead "i" $ \i ->
liftIO $ Gtk.comboBoxSetActive tagsBox i
return root
accountsIncomeViewUpdate :: MainState -> HistoryViewWidget -> Gtk.Label -> CalendarWidget -> IO ()
accountsIncomeViewUpdate mainState operationsView accountName cal = do
accountName' <- Gtk.labelGetText accountName
entities <- accountsIncomeSelect mainState accountName' cal
historyViewUpdate mainState operationsView entities
accountsIncomeSelect :: MainState -> String -> CalendarWidget -> IO [Entity OperationsTable]
accountsIncomeSelect mainState accountName cal =
if (accountName == [])
then return []
else do
let incomeID = mainStateIncomeID mainState
(year, _, _) <- calendarGetSelectedDate cal
accountID <- accountsTableSelectID accountName
runDB $
selectList [ OperationsTableFrom ==. incomeID
, OperationsTableTo ==. accountID
, OperationsTableDate >=. calendarDateToInt (year, 1, 1)
, OperationsTableDate <=. calendarDateToInt (year, 12, 31)
]
[ Desc OperationsTableDate ]
accountsIncomeAppend :: MainState -> CalendarWidget -> Gtk.ComboBox -> Gtk.Label -> Gtk.Entry -> Int -> IO ()
accountsIncomeAppend mainState cal tagsBox accountName entryDescription value = do
date <- calendarDateToInt <$> calendarGetSelectedDate cal
(Just tag) <- Gtk.comboBoxGetActiveText tagsBox
tagID <- tagsTableSelectID $ T.unpack tag
let fromID = mainStateIncomeID mainState
toName <- Gtk.labelGetText accountName
toID <- accountsTableSelectID toName
desc <- Gtk.entryGetText entryDescription :: IO String
runDB $ do
void $ insert $ OperationsTable date fromID toID value tagID desc
update toID [AccountsTableBalance +=. (fromIntegral value)]
accountsIncomeRemove :: Gtk.Label -> Entity OperationsTable -> IO ()
accountsIncomeRemove accountName entity = do
let (Entity entityID op) = entity
toName <- Gtk.labelGetText accountName
toID <- accountsTableSelectID toName
runDB $ do
delete entityID
update toID [AccountsTableBalance -=. (fromIntegral $ operationsTableValue op)]
accountsIncomeBalanceUpdate :: Gtk.Label -> Gtk.Label -> IO ()
accountsIncomeBalanceUpdate accountName balanceLabel = do
name <- Gtk.labelGetText accountName
accountID <- accountsTableSelectID name
val <- accountsTableSelectBalance accountID
Gtk.labelSetText balanceLabel $ valueShow val