{- * 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 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 :: Entity OperationsTable -> IO () accountsTransferRemove (Entity entityID op) = runDB $ do delete entityID update toID [AccountsTableBalance -=. (fromIntegral $ operationsTableValue op)] update fromID [AccountsTableBalance +=. (fromIntegral $ operationsTableValue op)] where toID = operationsTableTo op fromID = operationsTableFrom 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