{- * 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)