coin-1.1: src/Coin/UI/Raports/RaportQuery.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
*
-}
{-# LANGUAGE ScopedTypeVariables #-}
module Coin.UI.Raports.RaportQuery (
RaportQueryWidget,
raportQueryNew
) where
import Graphics.UI.Gtk (AttrOp (..))
import qualified Graphics.UI.Gtk as Gtk
import qualified System.Glib.GObject as Gtk
import qualified Data.Text as T
import Control.Monad
import Control.Monad.IO.Class
import Data.Maybe
import Data.List
import Database.Persist
import Coin.DB.Tables
import Coin.DB.Functions
import Coin.UI.Builder.GtkUIBuilder
import Coin.UI.MainState
import Coin.UI.Widgets.CheckList
import Coin.UI.Widgets.Calendar
import Coin.UI.HistoryView
import Coin.UI.Utils.CalendarUtils
import Coin.Locale.Translate
import Coin.Utils.ValueParser
data RaportQueryWidget = RaportQueryWidget {
raportQueryRoot :: Gtk.Widget,
raportQueryFromCal :: CalendarWidget,
raportQueryToCal :: CalendarWidget
}
instance Gtk.GObjectClass RaportQueryWidget where
toGObject = Gtk.toGObject . raportQueryRoot
unsafeCastGObject = undefined
instance Gtk.WidgetClass RaportQueryWidget
raportQueryNew :: MainState -> IO RaportQueryWidget
raportQueryNew mainState = do
accountsList <- checkListNew (__"Accounts") $ \(Entity _ account) -> T.pack $ accountsTableName account
tagsList <- checkListNew (__"Tags") $ \(Entity _ tags) -> T.pack $ tagsTableName tags
fromCalendar <- calendarNew CalendarSizeSmall
toCalendar <- calendarNew CalendarSizeSmall
historyView <- historyViewNew True True True
(getObject, root) <- uiBuildGtk $ do
globalCss [ "#Marked {"
, " font-weight: bold;"
, "}"
]
hPaned (Just "paned1")
(vPaned (Just "paned2")
(putWidget accountsList)
(putWidget tagsList))
(do
gridAttrs [ gridRowHomogeneous := False, gridColumnHomogeneous := False, gridColumnSpacing := 4, gridRowSpacing := 4 ]
grid Nothing $ do
gridAttach 0 0 1 1 $ do
gridAttrs [ gridColumnSpacing := 8, gridRowSpacing := 4, Gtk.containerBorderWidth := 4 ]
grid Nothing $ do
gridAttach 0 0 1 1 $ do
labelAttrs [ Gtk.miscXalign := 1.0, Gtk.widgetName := Just "Marked"]
label Nothing (__"Time from" ++ ":")
gridAttach 1 0 1 1 $ putWidget fromCalendar
gridAttach 0 1 1 1 $ do
labelAttrs [ Gtk.miscXalign := 1.0, Gtk.widgetName := Just "Marked"]
label Nothing (__"Time to" ++ ":")
gridAttach 1 1 1 1 $ putWidget toCalendar
gridAttach 1 0 1 2 $
vbox Nothing False 0 $ do
label Nothing ""
buttonAttrs [ Gtk.widgetWidthRequest := 150, Gtk.buttonImagePosition := Gtk.PosLeft ]
pack Gtk.PackNatural 0 $ buttonFromStock (Just "buttonExecute") Gtk.stockExecute
gridAttach 0 1 1 1 $
hbox Nothing False 0 $ do
packing Gtk.PackNatural 0
labelAttrs [ Gtk.miscXalign := 1.0, Gtk.widgetName := Just "Marked"]
label Nothing (" " ++ __"Actions" ++ ": ")
checkButton (Just "incomeCheckButton") $ __"Income"
checkButton (Just "outcomeCheckButton") $ __"Outcome"
checkButton (Just "transferCheckButton") $ __"Transfer"
gridAttach 0 2 2 1 $ do
widgetAttrs [ Gtk.widgetVExpand := True, Gtk.widgetHExpand := True ]
scrolledWindow Nothing $
putWidget historyView
gridAttach 0 3 2 1 $
hbox Nothing False 0 $ do
packing Gtk.PackNatural 2
labelAttrs [ Gtk.miscXalign := 1.0, Gtk.widgetName := Just "Marked"]
label Nothing $ __"Income" ++ ":"
label (Just "incomeLabel") "0"
label Nothing " | "
labelAttrs [ Gtk.miscXalign := 1.0, Gtk.widgetName := Just "Marked"]
label Nothing $ __"Outcome" ++ ":"
label (Just "outcomeLabel") "0"
label Nothing " | "
labelAttrs [ Gtk.miscXalign := 1.0, Gtk.widgetName := Just "Marked"]
label Nothing $ __"Transfer" ++ ":"
label (Just "transferLabel") "0"
packing Gtk.PackGrow 2
label Nothing ""
gridAttach 0 4 2 1 $
hbox Nothing False 0 $ do
packing Gtk.PackNatural 2
labelAttrs [ Gtk.miscXalign := 1.0, Gtk.widgetName := Just "Marked"]
label Nothing $ __"Income" ++ " - " ++ __"Outcome" ++ " = "
label (Just "differenceLabel") "0"
)
let paned1 = Gtk.castToPaned . fromJust . getObject $ "paned1"
let paned2 = Gtk.castToPaned . fromJust . getObject $ "paned2"
let buttonExecute = Gtk.castToButton . fromJust . getObject $ "buttonExecute"
let incomeCheckButton = Gtk.castToCheckButton . fromJust . getObject $ "incomeCheckButton"
let outcomeCheckButton = Gtk.castToCheckButton . fromJust . getObject $ "outcomeCheckButton"
let transferCheckButton = Gtk.castToCheckButton . fromJust . getObject $ "transferCheckButton"
let incomeLabel = Gtk.castToLabel . fromJust . getObject $ "incomeLabel"
let outcomeLabel = Gtk.castToLabel . fromJust . getObject $ "outcomeLabel"
let transferLabel = Gtk.castToLabel . fromJust . getObject $ "transferLabel"
let differenceLabel = Gtk.castToLabel . fromJust . getObject $ "differenceLabel"
let raportQuery = RaportQueryWidget
root
fromCalendar
toCalendar
Gtk.toggleButtonSetActive incomeCheckButton True
Gtk.toggleButtonSetActive outcomeCheckButton True
observableRegister (mainStateAccountsUpdated mainState) $ \entities -> do
checkListClear accountsList
forM_ entities $ checkListAppend accountsList False
observableRegister (mainStateTagsUpdated mainState) $ \entities -> do
checkListClear tagsList
let entities' = sortBy (\(Entity _ a) (Entity _ b) -> compare (tagsTableName a) (tagsTableName b)) entities
forM_ entities' $ checkListAppend tagsList False
void $ Gtk.on buttonExecute Gtk.buttonActivated $ do
(timeFrom, timeTo) <- raportQueryGetDates raportQuery
selectedAccounts <- fmap (\(Entity accountID _) -> accountID) <$> checkListGetSelected accountsList
selectedTags <- fmap (\(Entity tagID _) -> tagID) <$> checkListGetSelected tagsList
incomeSelected <- Gtk.toggleButtonGetActive incomeCheckButton
outcomeSelected <- Gtk.toggleButtonGetActive outcomeCheckButton
transferSelected <- Gtk.toggleButtonGetActive transferCheckButton
historyViewUpdate mainState historyView []
Gtk.labelSetText incomeLabel "0"
Gtk.labelSetText outcomeLabel "0"
Gtk.labelSetText transferLabel "0"
when (not (null selectedAccounts) && not (null selectedTags) && (incomeSelected || outcomeSelected || transferSelected)) $ do
entities <- runDB $ do
let incomeQuery = [ OperationsTableDate >=. timeFrom
, OperationsTableDate <=. timeTo
, OperationsTableTag <-. selectedTags
, OperationsTableFrom ==. mainStateIncomeID mainState
, OperationsTableTo <-. selectedAccounts
]
let outcomeQuery = [ OperationsTableDate >=. timeFrom
, OperationsTableDate <=. timeTo
, OperationsTableTag <-. selectedTags
, OperationsTableFrom <-. selectedAccounts
, OperationsTableTo ==. mainStateOutcomeID mainState
]
let transferQuery = ( [ OperationsTableDate >=. timeFrom
, OperationsTableDate <=. timeTo
, OperationsTableTag <-. selectedTags
, OperationsTableFrom !=. mainStateIncomeID mainState
, OperationsTableTo <-. selectedAccounts
]
||. [ OperationsTableDate >=. timeFrom
, OperationsTableDate <=. timeTo
, OperationsTableTag <-. selectedTags
, OperationsTableFrom <-. selectedAccounts
, OperationsTableTo !=. mainStateOutcomeID mainState
]
)
let incomeQuery' = if incomeSelected then incomeQuery else []
let outcomeQuery' = if outcomeSelected then outcomeQuery else []
let transferQuery' = if transferSelected then transferQuery else []
let query = foldr (\q acc ->
if null acc
then
if null q then acc else q
else
if null q then acc else acc ||. q
)
[]
[incomeQuery', outcomeQuery', transferQuery']
selectList query [Desc OperationsTableDate]
historyViewUpdate mainState historyView entities
let incomeSum = sum $
map (\(Entity _ op) -> operationsTableValue op) $
filter (\(Entity _ op) -> operationsTableFrom op == mainStateIncomeID mainState)
entities
let outcomeSum = sum $
map (\(Entity _ op) -> operationsTableValue op) $
filter (\(Entity _ op) -> operationsTableTo op == mainStateOutcomeID mainState)
entities
let transferSum = sum $
map (\(Entity _ op) -> operationsTableValue op) $
filter (\(Entity _ op) -> operationsTableFrom op /= mainStateIncomeID mainState && operationsTableTo op /= mainStateOutcomeID mainState)
entities
Gtk.labelSetText incomeLabel $ valueShow incomeSum
Gtk.labelSetText outcomeLabel $ valueShow outcomeSum
Gtk.labelSetText transferLabel $ valueShow transferSum
Gtk.labelSetText differenceLabel $ valueShow $ incomeSum - outcomeSum
mainStateSavePropertiesAction mainState "Coin.UI.Raports.RaportQuery" $ do
pos1 <- liftIO $ Gtk.panedGetPosition paned1
propertyInsert "pos1" pos1
pos2 <- liftIO $ Gtk.panedGetPosition paned2
propertyInsert "pos2" pos2
indexes1 <- liftIO $ checkListGetSelectionIndex accountsList
propertyInsert "indexes1" indexes1
indexes2 <- liftIO $ checkListGetSelectionIndex tagsList
propertyInsert "indexes2" indexes2
fromDate <- liftIO $ calendarGetSelectedDate fromCalendar
propertyInsert "fromDate" fromDate
toDate <- liftIO $ calendarGetSelectedDate toCalendar
propertyInsert "toDate" toDate
ib <- liftIO $ Gtk.toggleButtonGetActive incomeCheckButton
propertyInsert "ib" ib
ob <- liftIO $ Gtk.toggleButtonGetActive outcomeCheckButton
propertyInsert "ob" ob
tb <- liftIO $ Gtk.toggleButtonGetActive transferCheckButton
propertyInsert "tb" tb
mainStateReadPropertiesAction mainState "Coin.UI.Raports.RaportQuery" $ do
propertyRead2 "pos1" "pos2" $ \pos1 pos2 -> do
liftIO $ Gtk.panedSetPosition paned1 pos1
liftIO $ Gtk.panedSetPosition paned2 pos2
propertyRead2 "indexes1" "indexes2" $ \indexes1 indexes2 -> do
liftIO $ checkListSetSelectionIndex accountsList indexes1
liftIO $ checkListSetSelectionIndex tagsList indexes2
propertyRead2 "fromDate" "toDate" $ \fromDate toDate -> do
liftIO $ calendarSelectDate fromCalendar fromDate
liftIO $ calendarSelectDate toCalendar toDate
propertyRead3 "ib" "ob" "tb" $ \ib ob tb -> do
liftIO $ Gtk.toggleButtonSetActive incomeCheckButton ib
liftIO $ Gtk.toggleButtonSetActive outcomeCheckButton ob
liftIO $ Gtk.toggleButtonSetActive transferCheckButton tb
return raportQuery
raportQueryGetDates :: RaportQueryWidget -> IO (Int, Int)
raportQueryGetDates raportQuery = do
timeFrom <- calendarGetSelectedDate $ raportQueryFromCal raportQuery
timeTo <- calendarGetSelectedDate $ raportQueryToCal raportQuery
return (calendarDateToInt timeFrom, calendarDateToInt timeTo)