coin-1.2: src/Coin/UI/Accounts/AccountsTransfer.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.AccountsTransfer (
accountsTransferNew
) 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.AccountsComboBox
import Coin.UI.Utils.CalendarUtils
import Coin.Locale.Translate
import Coin.Utils.ValueParser
import Coin.UI.HistoryView
accountsTransferNew :: MainState -> IO Gtk.Widget
accountsTransferNew mainState = do
cal <- calendarNew CalendarSizeNormal
operationsView <- historyViewNew False False True
tagsBox <- tagsComboBoxNew mainState
accountsBox <- accountsComboBoxNew 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 $ 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 $ do
widgetAttrs [ Gtk.widgetVExpand := False, Gtk.widgetHExpand := True ]
putWidget tagsBox
gridAttach 0 2 1 1 $ do
labelAttrs [ Gtk.miscXalign := 1.0, Gtk.widgetName := Just "Marked" ]
label Nothing (__"Transfer 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 (__"To account:")
gridAttach 1 4 1 1 $ hbox Nothing False 0 $ do
pack Gtk.PackGrow 0 $ putWidget accountsBox
pack Gtk.PackNatural 0 $ imageFromStock (Just "errorToAccount") Gtk.stockDialogError Gtk.IconSizeMenu
gridAttach 0 5 1 1 $ do
labelAttrs [ Gtk.miscXalign := 1.0, Gtk.widgetName := Just "Marked" ]
label Nothing (__"Description:")
gridAttach 1 5 1 1 $ entry (Just "entryDescription") ""
gridAttach 0 6 1 1 $ do
labelAttrs [ Gtk.miscXalign := 1.0, Gtk.widgetName := Just "Marked" ]
label Nothing (__"Current balance:")
gridAttach 1 6 1 1 $ do
labelAttrs [ Gtk.miscXalign := 0.0 ]
label (Just "balance") "0.00"
gridAttach 0 7 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 8 2 1 $ do
widgetAttrs [ Gtk.widgetVExpand := True, Gtk.widgetHExpand := True ]
scrolledWindow Nothing $ putWidget operationsView
gridAttach 0 9 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 errorToAccount = fromJust . getObject $ "errorToAccount"
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
accountsTransferViewUpdate mainState operationsView accountName cal
accountsTransferBalanceUpdate accountName balance
text <- Gtk.comboBoxGetActiveText accountsBox
if text == (Just $ T.pack name)
then do
Gtk.widgetShow errorToAccount
Gtk.widgetSetSensitive buttonAdd False
else do
Gtk.widgetHide errorToAccount
err <- checkError errorValue errorToAccount
Gtk.widgetSetSensitive buttonAdd err
void $ Gtk.on accountsBox Gtk.changed $ do
name <- Gtk.labelGetText accountName
text <- Gtk.comboBoxGetActiveText accountsBox
if text == (Just $ T.pack name)
then do
Gtk.widgetShow errorToAccount
Gtk.widgetSetSensitive buttonAdd False
else do
Gtk.widgetHide errorToAccount
err <- checkError errorValue errorToAccount
Gtk.widgetSetSensitive buttonAdd err
void $ Gtk.on entryValue Gtk.keyReleaseEvent $ do
value <- liftIO $ parseValue <$> Gtk.entryGetText entryValue
liftIO $ case value of
Just _ -> do
Gtk.widgetHide errorValue
err <- checkError errorValue errorToAccount
Gtk.widgetSetSensitive buttonAdd err
Nothing -> do
Gtk.widgetShow errorValue
Gtk.widgetSetSensitive buttonAdd False
return True
void $ Gtk.on buttonAdd Gtk.buttonActivated $ do
err <- Gtk.widgetGetVisible errorToAccount
when (err == False) $ do
value <- parseValue <$> Gtk.entryGetText entryValue
case value of
Just value' -> do
accountsTransferAppend cal tagsBox accountsBox accountName entryDescription value'
Gtk.entrySetText entryValue ""
Gtk.entrySetText entryDescription ""
Gtk.widgetShow errorValue
Gtk.widgetSetSensitive buttonAdd False
accountsTransferViewUpdate mainState operationsView accountName cal
accountsTransferBalanceUpdate 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
accountsTransferRemove accountsBox accountName entity'
accountsTransferViewUpdate mainState operationsView accountName cal
accountsTransferBalanceUpdate 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
accountsTransferViewUpdate mainState operationsView accountName cal
accountsTransferBalanceUpdate accountName balance
mainStateSavePropertiesAction mainState "Coin.UI.Accounts.AccountsTransfer" $ do
i <- liftIO $ Gtk.comboBoxGetActive tagsBox
propertyInsert "i" i
j <- liftIO $ Gtk.comboBoxGetActive accountsBox
propertyInsert "j" j
mainStateReadPropertiesAction mainState "Coin.UI.Accounts.AccountsTransfer" $ do
propertyRead "i" $ \i ->
liftIO $ Gtk.comboBoxSetActive tagsBox i
propertyRead "j" $ \j ->
liftIO $ Gtk.comboBoxSetActive accountsBox j
return root
where
checkError errorValue errorToAccount = do
error1 <- Gtk.widgetGetVisible errorValue
error2 <- Gtk.widgetGetVisible errorToAccount
return $ and [ not error1, not error2 ]
accountsTransferViewUpdate :: MainState -> HistoryViewWidget -> Gtk.Label -> CalendarWidget -> IO ()
accountsTransferViewUpdate mainState operationsView accountName cal = do
accountName' <- Gtk.labelGetText accountName
entities <- accountsTransferSelect mainState accountName' cal
historyViewUpdate mainState operationsView entities
accountsTransferSelect :: MainState -> String -> CalendarWidget -> IO [Entity OperationsTable]
accountsTransferSelect mainState accountName cal =
if (accountName == [])
then return []
else do
let outcomeID = mainStateOutcomeID mainState
let incomeID = mainStateIncomeID mainState
(year, _, _) <- calendarGetSelectedDate cal
accountID <- accountsTableSelectID accountName
runDB $
selectList ( [ OperationsTableFrom ==. accountID
, OperationsTableTo !=. outcomeID
, OperationsTableDate >=. calendarDateToInt (year, 1, 1)
, OperationsTableDate <=. calendarDateToInt (year, 12, 31)
]
||. [ OperationsTableTo ==. accountID
, OperationsTableFrom !=. incomeID
, OperationsTableDate >=. calendarDateToInt (year, 1, 1)
, OperationsTableDate <=. calendarDateToInt (year, 12, 31)
]
)
[ Desc OperationsTableDate ]
accountsTransferAppend :: CalendarWidget -> Gtk.ComboBox -> Gtk.ComboBox -> Gtk.Label -> Gtk.Entry -> Int -> IO ()
accountsTransferAppend cal tagsBox accountsBox accountName entryDescription value = do
date <- calendarDateToInt <$> calendarGetSelectedDate cal
(Just tag) <- Gtk.comboBoxGetActiveText tagsBox
tagID <- tagsTableSelectID $ T.unpack tag
(Just account) <- Gtk.comboBoxGetActiveText accountsBox
toID <- accountsTableSelectID $ T.unpack account
toName <- Gtk.labelGetText accountName
fromID <- accountsTableSelectID toName
desc <- Gtk.entryGetText entryDescription :: IO String
runDB $ do
void $ insert $ OperationsTable date fromID toID value tagID desc
update toID [AccountsTableBalance +=. (fromIntegral value)]
update fromID [AccountsTableBalance -=. (fromIntegral value)]
accountsTransferRemove :: Gtk.ComboBox -> Gtk.Label -> Entity OperationsTable -> IO ()
accountsTransferRemove accountsBox accountName entity = do
let (Entity entityID op) = entity
(Just toAccount) <- Gtk.comboBoxGetActiveText accountsBox
toID <- accountsTableSelectID $ T.unpack toAccount
fromName <- Gtk.labelGetText accountName
fromID <- accountsTableSelectID fromName
runDB $ do
delete entityID
update toID [AccountsTableBalance -=. (fromIntegral $ operationsTableValue op)]
update fromID [AccountsTableBalance +=. (fromIntegral $ operationsTableValue op)]
accountsTransferBalanceUpdate :: Gtk.Label -> Gtk.Label -> IO ()
accountsTransferBalanceUpdate accountName balanceLabel = do
name <- Gtk.labelGetText accountName
accountID <- accountsTableSelectID name
val <- accountsTableSelectBalance accountID
Gtk.labelSetText balanceLabel $ valueShow val