coin-1.2: src/Coin/UI/Accounts/AccountsOutcome.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.AccountsOutcome (
accountsOutcomeNew
) 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
accountsOutcomeNew :: MainState -> IO Gtk.Widget
accountsOutcomeNew mainState = do
cal <- calendarNew CalendarSizeNormal
operationsView <- historyViewNew False True 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 (__"Subtract 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 (__"From 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
accountsOutcomeViewUpdate mainState operationsView accountName cal
accountsOutcomeBalanceUpdate 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
accountsOutcomeAppend mainState cal tagsBox accountName entryDescription value'
Gtk.entrySetText entryValue ""
Gtk.entrySetText entryDescription ""
Gtk.widgetShow errorValue
Gtk.widgetSetSensitive buttonAdd False
accountsOutcomeViewUpdate mainState operationsView accountName cal
accountsOutcomeBalanceUpdate 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
accountsOutcomeRemove accountName entity'
accountsOutcomeViewUpdate mainState operationsView accountName cal
accountsOutcomeBalanceUpdate 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
accountsOutcomeViewUpdate mainState operationsView accountName cal
accountsOutcomeBalanceUpdate accountName balance
mainStateSavePropertiesAction mainState "Coin.UI.Accounts.AccountsOutcome" $ do
i <- liftIO $ Gtk.comboBoxGetActive tagsBox
propertyInsert "i" i
mainStateReadPropertiesAction mainState "Coin.UI.Accounts.AccountsOutcome" $ do
propertyRead "i" $ \i ->
liftIO $ Gtk.comboBoxSetActive tagsBox i
return root
accountsOutcomeViewUpdate :: MainState -> HistoryViewWidget -> Gtk.Label -> CalendarWidget -> IO ()
accountsOutcomeViewUpdate mainState operationsView accountName cal = do
accountName' <- Gtk.labelGetText accountName
entities <- accountsOutcomeSelect mainState accountName' cal
historyViewUpdate mainState operationsView entities
accountsOutcomeSelect :: MainState -> String -> CalendarWidget -> IO [Entity OperationsTable]
accountsOutcomeSelect mainState accountName cal =
if (accountName == [])
then return []
else do
let outcomeID = mainStateOutcomeID mainState
(year, _, _) <- calendarGetSelectedDate cal
accountID <- accountsTableSelectID accountName
runDB $
selectList [ OperationsTableFrom ==. accountID
, OperationsTableTo ==. outcomeID
, OperationsTableDate >=. calendarDateToInt (year, 1, 1)
, OperationsTableDate <=. calendarDateToInt (year, 12, 31)
]
[ Desc OperationsTableDate ]
accountsOutcomeAppend :: MainState -> CalendarWidget -> Gtk.ComboBox -> Gtk.Label -> Gtk.Entry -> Int -> IO ()
accountsOutcomeAppend mainState cal tagsBox accountName entryDescription value = do
date <- calendarDateToInt <$> calendarGetSelectedDate cal
(Just tag) <- Gtk.comboBoxGetActiveText tagsBox
tagID <- tagsTableSelectID $ T.unpack tag
let toID = mainStateOutcomeID mainState
fromName <- Gtk.labelGetText accountName
fromID <- accountsTableSelectID fromName
desc <- Gtk.entryGetText entryDescription :: IO String
runDB $ do
void $ insert $ OperationsTable date fromID toID value tagID desc
update fromID [AccountsTableBalance -=. (fromIntegral value)]
accountsOutcomeRemove :: Gtk.Label -> Entity OperationsTable -> IO ()
accountsOutcomeRemove accountName entity = do
let (Entity entityID op) = entity
fromName <- Gtk.labelGetText accountName
fromID <- accountsTableSelectID fromName
runDB $ do
delete entityID
update fromID [AccountsTableBalance +=. (fromIntegral $ operationsTableValue op)]
accountsOutcomeBalanceUpdate :: Gtk.Label -> Gtk.Label -> IO ()
accountsOutcomeBalanceUpdate accountName balanceLabel = do
name <- Gtk.labelGetText accountName
accountID <- accountsTableSelectID name
val <- accountsTableSelectBalance accountID
Gtk.labelSetText balanceLabel $ valueShow val