packages feed

coin (empty) → 1.0

raw patch · 54 files changed

+6388/−0 lines, 54 filesdep +aesondep +basedep +binarysetup-changedbinary-added

Dependencies added: aeson, base, binary, bytestring, containers, directory, filepath, glib, gtk3, hgettext, lens-simple, monad-control, monad-logger, mtl, persistent, persistent-sqlite, persistent-template, resourcet, setlocale, text, time, transformers

Files

+ LICENSE view
@@ -0,0 +1,1 @@+GPL
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ coin.cabal view
@@ -0,0 +1,98 @@+name:              coin+version:           1.0+Build-Type:        Simple+cabal-version:     >= 1.16+author:            Piotr Borek <piotrborek@op.pl>+maintainer:        Piotr Borek <piotrborek@op.pl>+license:           GPL+synopsis:          Simple account manager+description:       Simple account manager+category:          Application+homepage:          https://bitbucket.org/borekpiotr/coin++data-files:        stack.yaml+                   LICENSE+                   resources/i18n/pl/LC_MESSAGES/coin.mo+                   resources/i18n/pl/LC_MESSAGES/coin.po+                   resources/i18n/pl/LC_MESSAGES/convert++executable coin+    main-is:            Main.hs+    hs-source-dirs:     src+    default-language:   Haskell2010+    -- also enable profiling in ~/.cabal.config+    --ghc-options:        -Wall -prof -auto-all -osuf p_o+    ghc-options:        -Wall -O2+    default-extensions: LambdaCase+                        PackageImports+                        MultiWayIf+    build-depends:      base >= 4.8 && < 4.9,+                        glib,+                        gtk3 == 0.14.2,+                        directory,+                        setlocale,+                        hgettext,+                        filepath,+                        containers,+                        hgettext,+                        binary,+                        directory,+                        persistent,+                        persistent-template,+                        persistent-sqlite,+                        transformers,+                        text,+                        monad-control,+                        monad-logger,+                        resourcet,+                        time,+                        mtl,+                        lens-simple,+                        aeson,+                        bytestring+    other-modules:      Coin.UI.Raports.RaportSummary+                        Coin.UI.Raports.RaportHistory+                        Coin.UI.Raports.RaportQuery+                        Coin.UI.Options.OptionsTag+                        Coin.UI.Options.OptionsAccount+                        Coin.UI.Accounts.AccountsIncome+                        Coin.UI.Accounts.AccountsHistory+                        Coin.UI.Accounts.AccountsOutcome+                        Coin.UI.Accounts.AccountsTransfer+                        Coin.UI.Accounts.AccountsWidget+                        Coin.UI.MainInitialize+                        Coin.UI.Widgets.SimpleListView+                        Coin.UI.Widgets.InputBox+                        Coin.UI.Widgets.ResponseButtons+                        Coin.UI.Widgets.Calendar+                        Coin.UI.Widgets.MultiList+                        Coin.UI.Widgets.StackWidget+                        Coin.UI.Widgets.CheckList+                        Coin.UI.Widgets.MessageBox+                        Coin.UI.Widgets.MiniCalendar+                        Coin.UI.TagsComboBox+                        Coin.UI.HistoryView+                        Coin.UI.MainWindow+                        Coin.UI.Builder.GtkUIAttributes+                        Coin.UI.Builder.GtkUIBuilderState+                        Coin.UI.Builder.GtkUIBuilder+                        Coin.UI.Builder.GtkUIUtils+                        Coin.UI.Utils.CssUtils+                        Coin.UI.Utils.CalendarUtils+                        Coin.UI.Utils.Observable+                        Coin.UI.MainState+                        Coin.UI.AccountsComboBox+                        Coin.UI.MainMultiList+                        Coin.Config.Dirs+                        Coin.DB.Tables+                        Coin.DB.Functions+                        Coin.Utils.ValueParser+                        Coin.Utils.TableView+                        Coin.Utils.FileHelper+                        Coin.Utils.Exception+                        Coin.Utils.IORef+                        Coin.Utils.StringUtils+                        Coin.Utils.I18N+                        Coin.Utils.PropertyMap+                        Coin.Utils.ColorUtils+                        Coin.Utils.LocaleHelper
+ resources/i18n/pl/LC_MESSAGES/coin.mo view

binary file changed (absent → 3756 bytes)

+ resources/i18n/pl/LC_MESSAGES/coin.po view
@@ -0,0 +1,318 @@+# Translation file++msgid ""+msgstr ""++"Project-Id-Version: PACKAGE VERSION\n"+"Report-Msgid-Bugs-To: \n"+"POT-Creation-Date: 2009-01-13 06:05-0800\n"+"PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n"+"Last-Translator: FULL NAME <EMAIL@ADDRESS>\n"+"Language-Team: LANGUAGE <LL@li.org>\n"+"MIME-Version: 1.0\n"+"Content-Type: text/plain; charset=UTF-8\n"+"Content-Transfer-Encoding: 8bit\n"++#: src/Coin/UI/Accounts/OperationsView.hs:0+msgid "Date"+msgstr "Data"++#: src/Coin/UI/Accounts/OperationsView.hs:0+msgid "From"+msgstr "Z konta"++#: src/Coin/UI/Accounts/OperationsView.hs:0+msgid "To"+msgstr "Na konto"++#: src/Coin/UI/Accounts/OperationsView.hs:0+msgid "Value"+msgstr "Wartość"++#: src/Coin/UI/Accounts/OperationsView.hs:0+msgid "Tag"+msgstr "Tag"++#: src/Coin/UI/Accounts/OperationsView.hs:0+msgid "Description"+msgstr "Opis"++#: src/Coin/UI/Accounts/AccountsIncome.hs:0+msgid "Date:"+msgstr "Data:"++#: src/Coin/UI/Accounts/AccountsIncome.hs:0+msgid "Tag:"+msgstr "Tag:"++#: src/Coin/UI/Accounts/AccountsIncome.hs:0+msgid "Add value:"+msgstr "Dodaj wartość:"++#: src/Coin/UI/Accounts/AccountsIncome.hs:0+msgid "To account:"+msgstr "Na konto:"++#: src/Coin/UI/Accounts/AccountsIncome.hs:0+msgid "Description:"+msgstr "Opis:"++#: src/Coin/UI/Accounts/AccountsIncome.hs:0+msgid "Current balance:"+msgstr "Bieżące saldo:"++#: src/Coin/UI/Accounts/AccountsIncome.hs:0+msgid "Add"+msgstr "Dodaj"++#: src/Coin/UI/Accounts/AccountsIncome.hs:0+msgid "Remove"+msgstr "Usuń"++#: src/Coin/UI/Accounts/AccountsHistory.hs:0+msgid "Account name:"+msgstr "Nazwa konta:"++#: src/Coin/UI/Accounts/AccountsOutcome.hs:0+msgid "Subtract value:"+msgstr "Odejmij wartość:"++#: src/Coin/UI/Accounts/AccountsOutcome.hs:0+msgid "From account:"+msgstr "Z konta:"++#: src/Coin/UI/Accounts/AccountsTransfer.hs:0+msgid "Transfer value:"+msgstr "Przelej wartość:"++#: src/Coin/UI/Accounts/AccountsWidget.hs:0+msgid "Income"+msgstr "Wpłata"++#: src/Coin/UI/Accounts/AccountsWidget.hs:0+msgid "Outcome"+msgstr "Wypłata"++#: src/Coin/UI/Accounts/AccountsWidget.hs:0+msgid "Transfer"+msgstr "Przelew"++#: src/Coin/UI/Accounts/AccountsWidget.hs:0+msgid "History"+msgstr "Historia"++#: src/Coin/UI/Widgets/Calendar.hs:0+msgid "Today"+msgstr "Dziś"++#: src/Coin/UI/Widgets/MessageBox.hs:0+msgid "Info"+msgstr "Informacja"++#: src/Coin/UI/Widgets/MessageBox.hs:0+msgid "Warning"+msgstr "Ostrzeżenie"++#: src/Coin/UI/Widgets/MessageBox.hs:0+msgid "Question"+msgstr "Pytanie"++#: src/Coin/UI/Widgets/MessageBox.hs:0+msgid "Error"+msgstr "Błąd"++#: src/Coin/UI/Utils/CalendarUtils.hs:0+msgid "Mo"+msgstr "Pn"++#: src/Coin/UI/Utils/CalendarUtils.hs:0+msgid "Tu"+msgstr "Wt"++#: src/Coin/UI/Utils/CalendarUtils.hs:0+msgid "We"+msgstr "Śr"++#: src/Coin/UI/Utils/CalendarUtils.hs:0+msgid "Th"+msgstr "Czw"++#: src/Coin/UI/Utils/CalendarUtils.hs:0+msgid "Fr"+msgstr "Pt"++#: src/Coin/UI/Utils/CalendarUtils.hs:0+msgid "Sa"+msgstr "So"++#: src/Coin/UI/Utils/CalendarUtils.hs:0+msgid "Su"+msgstr "N"++#: src/Coin/UI/Utils/CalendarUtils.hs:0+msgid "January"+msgstr "Styczeń"++#: src/Coin/UI/Utils/CalendarUtils.hs:0+msgid "February"+msgstr "Luty"++#: src/Coin/UI/Utils/CalendarUtils.hs:0+msgid "March"+msgstr "Marzec"++#: src/Coin/UI/Utils/CalendarUtils.hs:0+msgid "April"+msgstr "Kwiecień"++#: src/Coin/UI/Utils/CalendarUtils.hs:0+msgid "May"+msgstr "Maj"++#: src/Coin/UI/Utils/CalendarUtils.hs:0+msgid "June"+msgstr "Czerwiec"++#: src/Coin/UI/Utils/CalendarUtils.hs:0+msgid "July"+msgstr "Lipiec"++#: src/Coin/UI/Utils/CalendarUtils.hs:0+msgid "August"+msgstr "Sierpień"++#: src/Coin/UI/Utils/CalendarUtils.hs:0+msgid "September"+msgstr "Wrzesień"++#: src/Coin/UI/Utils/CalendarUtils.hs:0+msgid "October"+msgstr "Październik"++#: src/Coin/UI/Utils/CalendarUtils.hs:0+msgid "November"+msgstr "Listopad"++#: src/Coin/UI/Utils/CalendarUtils.hs:0+msgid "December"+msgstr "Grudzień"++#: src/Coin/UI/MainMultiList.hs:0+msgid "Accounts"+msgstr "Konta"++#: src/Coin/UI/MainMultiList.hs:0+msgid "Raports"+msgstr "Raporty"++#: src/Coin/UI/MainMultiList.hs:0+msgid "Options"+msgstr "Opcje"++#: src/Coin/UI/MainMultiList.hs:0+msgid "Tags"+msgstr "Tagi"++#: src/Coin/DB/Tables.hs:0+msgid "None"+msgstr "Żaden"++#: src/Coin/DB/Tables.hs:0+msgid "Cash"+msgstr "Gotówka"++msgid "Do you want to update"+msgstr "Czy chcesz zmienić nazwę"++msgid "Do you want to remove"+msgstr "Czy chcesz usunąć"++msgid "account ?"+msgstr " "++msgid "account name ?"+msgstr " "++msgid "tag ?"+msgstr " "++msgid "tag name ?"+msgstr " "++msgid "Name"+msgstr "Nazwa"++msgid "Incomes:"+msgstr "Wpłaty:"++msgid "Outcomes:"+msgstr "Wypłaty:"++msgid "Account name"+msgstr "Nazwa konta"++msgid "Current balance"+msgstr "Bieżące saldo"++msgid "Sum"+msgstr "Suma"++msgid "Summary"+msgstr "Podsumowanie"++msgid "Queries"+msgstr "Zapytania"++msgid "All"+msgstr "Wszystkie"++msgid "Period of time"+msgstr "Okres czasu"++msgid "last 1 month"+msgstr "ostatni 1 miesiąc"++msgid "last 2 months"+msgstr "ostatnie 2 miesiące"++msgid "last 3 months"+msgstr "ostatnie 3 miesiące"++msgid "last 6 months"+msgstr "ostatnie 6 miesięcy"++msgid "last 1 year"+msgstr "ostatni 1 rok"++msgid "last 2 years"+msgstr "ostatnie 2 lata"++msgid "last 3 years"+msgstr "ostatnie 3 lata"++msgid "last 5 years"+msgstr "ostatnie 5 lat"++msgid "last 10 years"+msgstr "ostatnie 10 lat"++msgid "Time from"+msgstr "Czas od"++msgid "Time to"+msgstr "Czas do"++msgid "Time from ... to ..."+msgstr "Czas od ... do ..."++msgid "Last month/year"+msgstr "Ostatni miesiąc/rok"++msgid "Actions"+msgstr "Operacje"++msgid "Select all"+msgstr "Zaznacz wszystkie"++msgid "Deselect all"+msgstr "Odznacz wszystkie"
+ resources/i18n/pl/LC_MESSAGES/convert view
@@ -0,0 +1,3 @@+#!/bin/bash++msgfmt coin.po -o coin.mo
+ src/Coin/Config/Dirs.hs view
@@ -0,0 +1,33 @@+{-+ *  Programmer:	Piotr Borek+ *  E-mail:     piotrborek@op.pl+ *  Copyright 2015 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.Config.Dirs (+    configGetDirectory+) where++import System.Environment+import System.FilePath++configGetDirectory :: IO String+configGetDirectory = do+    home <- getEnv "HOME"+    return $ home </> ".coin"
+ src/Coin/DB/Functions.hs view
@@ -0,0 +1,79 @@+{-+ *  Programmer:	Piotr Borek+ *  E-mail:     piotrborek@op.pl+ *  Copyright 2015 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+-}++{-#LANGUAGE FlexibleContexts #-}+{-#LANGUAGE TypeFamilies #-}+{-#LANGUAGE GADTs #-}++module Coin.DB.Functions (+    EntityCache,+    runDB,+    rawSqlCached,+    rawSqlFirstCached,+    showSqlKey+) where++import qualified Data.Map as Map+import qualified Data.Text as T+import qualified Control.Monad.State.Strict as State+import qualified Data.Aeson as JSON++import Control.Monad.Reader+import Control.Monad.Trans.Control+import Control.Monad.Logger+import Control.Monad.Trans.Resource+import Database.Persist.Sqlite+import Data.Maybe++import Coin.Config.Dirs++type EntityCache = Map.Map T.Text JSON.Value++runDB :: (MonadBaseControl IO m, MonadIO m) => SqlPersistT (LoggingT (ResourceT (State.StateT EntityCache m))) a -> m a+runDB action = do+    dir <- liftIO configGetDirectory+    State.evalStateT (runResourceT $ runStdoutLoggingT $ withSqliteConn (T.pack $ dir ++ "/coin.db") . runSqlConn $ action) Map.empty++rawSqlFirstCached :: (MonadLogger m, MonadIO m, State.MonadState EntityCache m, JSON.ToJSON a, JSON.FromJSON a, RawSql a) => String -> ReaderT SqlBackend m (Maybe a)+rawSqlFirstCached stmt = listToMaybe <$> rawSqlCached stmt++rawSqlCached :: (MonadLogger m, MonadIO m, State.MonadState EntityCache m, JSON.ToJSON a, JSON.FromJSON a, RawSql a) => String -> ReaderT SqlBackend m [a]+rawSqlCached stmt = do+    let text = T.pack stmt+    cache <- State.get+    case Map.lookup text cache of+        Just val ->+            case JSON.fromJSON val of+                JSON.Success entities -> do+                    logDebugNS (T.pack "CACHED") $ T.append text $ T.pack ";"+                    return entities++                JSON.Error _  ->+                    rawSql text []++        Nothing -> do+            entities <- rawSql text []+            State.put $ Map.insert text (JSON.toJSON entities) cache+            return entities++showSqlKey :: ToBackendKey SqlBackend record => Key record -> String+showSqlKey = show . fromSqlKey
+ src/Coin/DB/Tables.hs view
@@ -0,0 +1,195 @@+{-+ *  Programmer:	Piotr Borek+ *  E-mail:     piotrborek@op.pl+ *  Copyright 2015 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+-}++{-# LANGUAGE EmptyDataDecls             #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE QuasiQuotes                #-}+{-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE FlexibleInstances          #-}++module Coin.DB.Tables where++import qualified Data.Text as T+import qualified Data.Binary as B+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Lazy as BL++import System.Directory+import Control.Monad+import Data.Int+import Data.ByteString (ByteString)+import Database.Persist.Sqlite+import Database.Persist.TH++import Coin.DB.Functions+import Coin.Utils.I18N+import Coin.Config.Dirs++share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|+TagsTable json+    name String+    deriving Show++AccountsTable json+    name String+    balance Int64+    deriving Show++OperationsTable json+    date Int+    from AccountsTableId+    to AccountsTableId+    value Int+    tag TagsTableId+    description String+    deriving Show++ReservedTable+    en String+    ref Int64++AccountsOptionsTable+    indexes ByteString+|]++instance B.Binary AccountsTableId where+    put accountsID =+        case toPersistValue accountsID of+            PersistInt64 val -> B.put val+            _                -> error "Tables.hs: Binary AccountsTableId: something went wrong."+    get = do+        val <- B.get :: B.Get Int64+        case fromPersistValue $ PersistInt64 val of+            Right val' -> return val'+            Left err   -> error $ "Tables.hs: Binary AccountsTableId: Error: " ++ T.unpack err++accountsOptionsTableUpdate :: [AccountsTableId] -> IO ()+accountsOptionsTableUpdate accountIDs = do+    let blob = BL.toStrict . B.encode $ accountIDs+    runDB $ do+        options <- selectList [] []+        case options of+            []                   -> void $ insert $ AccountsOptionsTable blob+            [Entity optionsID _] -> replace optionsID $ AccountsOptionsTable blob+            _                    -> error "Tables.hs: accountsOptionsTableUpdate: something went wrong."++accountsOptionsTableRead :: IO [AccountsTableId]+accountsOptionsTableRead =+    runDB $ do+        option <- selectFirst [] []+        case option of+            Just (Entity _ (AccountsOptionsTable blob)) -> return $ B.decode . BB.toLazyByteString . BB.byteString $ blob+            Nothing -> return []++checkReservedID :: PersistField a => String -> (String -> IO a) -> IO a+checkReservedID name insertAction = do+    reserved <- runDB $ selectFirst [ ReservedTableEn ==. name] []++    case reserved of+        Just (Entity _ entity) ->+            case fromPersistValue $ PersistInt64 $ reservedTableRef entity of+                Right val -> return val+                Left err -> error $ "Tables.hs: Error: " ++ T.unpack err++        Nothing -> do+            tableID <- insertAction $ __ name++            case toPersistValue tableID of+                PersistInt64 val -> void $ runDB $ insert $ ReservedTable name val+                _                -> error "Tables.hs: Something went wrong."++            return tableID++tagsTableNoneID :: IO TagsTableId+tagsTableNoneID = checkReservedID "None" $ \name -> runDB $ insert $ TagsTable name++accountsTableIncomeID :: IO AccountsTableId+accountsTableIncomeID = checkReservedID "Income" $ \name -> runDB $ insert $ AccountsTable name 0++accountsTableOutcomeID :: IO AccountsTableId+accountsTableOutcomeID = checkReservedID "Outcome" $ \name -> runDB $ insert $ AccountsTable name 0++accountsTableCashID :: IO AccountsTableId+accountsTableCashID = checkReservedID "Cash" $ \name -> runDB $ insert $ AccountsTable name 0++initializeDatabase :: IO ()+initializeDatabase = do+    dir <- configGetDirectory+    createDirectoryIfMissing True dir++    runDB $ runMigration migrateAll++    void tagsTableNoneID+    void accountsTableIncomeID+    void accountsTableOutcomeID+    void accountsTableCashID++tagsTableSelectAll :: IO [Entity TagsTable]+tagsTableSelectAll = runDB $ selectList [] []++tagsTableSelectAllNames :: IO [String]+tagsTableSelectAllNames = do+    list <- tagsTableSelectAll+    return $+        map (\(Entity _ tag) -> tagsTableName tag) list++tagsTableSelectID :: String -> IO TagsTableId+tagsTableSelectID tagName = do+    (Just (Entity tagID _)) <- runDB $ selectFirst [ TagsTableName ==. tagName ] []+    return tagID++tagsTableSelectName :: TagsTableId -> IO String+tagsTableSelectName tagID = do+    (Just (Entity _ tagEntity))  <- runDB $ selectFirst [ TagsTableId ==. tagID ] []+    return $ tagsTableName tagEntity++accountsTableSelectAll :: IO [Entity AccountsTable]+accountsTableSelectAll = runDB $ selectList [] []++accountsTableSelectAllNames :: IO [String]+accountsTableSelectAllNames = do+    list <- accountsTableSelectAll+    return $+        map (\(Entity _ account) -> accountsTableName account) list++accountsTableSelectID :: String -> IO AccountsTableId+accountsTableSelectID accountName = do+    (Just (Entity accountID _)) <- runDB $ selectFirst [ AccountsTableName ==. accountName ] []+    return accountID++accountsTableSelectName :: AccountsTableId -> IO String+accountsTableSelectName accountID = do+    (Just (Entity _ accountEntity))  <- runDB $ selectFirst [ AccountsTableId ==. accountID ] []+    return $ accountsTableName accountEntity++accountsTableSelectBalance :: AccountsTableId -> IO Int64+accountsTableSelectBalance accountID = do+    (Just (Entity _ account)) <- runDB $ selectFirst [AccountsTableId ==. accountID] []+    return $ accountsTableBalance account++operationsTableSelectList :: Int -> Int -> IO [Entity OperationsTable]+operationsTableSelectList from to = runDB $ selectList [OperationsTableDate >=. from, OperationsTableDate <=. to] []
+ src/Coin/UI/Accounts/AccountsHistory.hs view
@@ -0,0 +1,104 @@+{-+ *  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+ *+-}++module Coin.UI.Accounts.AccountsHistory (+    accountsHistoryNew+) where++import qualified Graphics.UI.Gtk as Gtk+import Graphics.UI.Gtk ( AttrOp(..) )++import Data.Maybe+import Database.Persist++import Coin.DB.Tables+import Coin.DB.Functions+import Coin.Utils.I18N+import Coin.Utils.ValueParser+import Coin.UI.MainState+import Coin.UI.Builder.GtkUIBuilder+import Coin.UI.HistoryView++accountsHistoryNew :: MainState -> IO Gtk.Widget+accountsHistoryNew mainState = do+    historyView <- historyViewNew True True True++    (getObject, root) <- uiBuildGtk $ do+        globalCss [ "#Marked {"+                  , "    font-weight: bold;"+                  , "}"+                  ]+        gridAttrs [ gridRowHomogeneous := False, gridColumnHomogeneous := False, gridColumnSpacing := 4, gridRowSpacing := 8, Gtk.containerBorderWidth := 4 ]+        grid Nothing $ do+            gridAttach 0 1 1 1 $ do+                labelAttrs [ Gtk.miscXalign := 1.0, Gtk.widgetName := Just "Marked" ]+                label Nothing (__"Account name:")+            gridAttach 1 1 1 1 $ do+                labelAttrs [ Gtk.miscXalign := 0.0, Gtk.widgetVExpand := False, Gtk.widgetHExpand := True ]+                label (Just "accountName") ""++            gridAttach 0 2 1 1 $ do+                labelAttrs [ Gtk.miscXalign := 1.0, Gtk.widgetName := Just "Marked" ]+                label Nothing (__"Current balance:")+            gridAttach 1 2 1 1 $ do+                labelAttrs [ Gtk.miscXalign := 0.0 ]+                label (Just "balance") "0.00"++            gridAttach 0 3 2 1 $ do+                widgetAttrs [ Gtk.widgetVExpand := True, Gtk.widgetHExpand := True ]+                scrolledWindow Nothing $ putWidget historyView++    let accountName = Gtk.castToLabel . fromJust . getObject $ "accountName"+    let balance = Gtk.castToLabel . fromJust . getObject $ "balance"++    observableRegister (mainStateSelectedAccountName mainState) $ \name -> do+        Gtk.labelSetText accountName name+        accountsHistoryViewUpdate mainState historyView accountName+        accountsHistoryBalanceUpdate accountName balance++    return root++accountsHistoryViewUpdate :: MainState -> HistoryViewWidget -> Gtk.Label -> IO ()+accountsHistoryViewUpdate mainState operationsView accountName = do+    accountName' <- Gtk.labelGetText accountName+    entities <- accountsHistorySelect accountName'+    historyViewUpdate mainState operationsView entities++accountsHistoryBalanceUpdate :: Gtk.Label -> Gtk.Label -> IO ()+accountsHistoryBalanceUpdate accountName balanceLabel = do+    name <- Gtk.labelGetText accountName+    accountID <- accountsTableSelectID name+    val <- accountsTableSelectBalance accountID+    Gtk.labelSetText balanceLabel $ valueShow val++accountsHistorySelect :: String -> IO [Entity OperationsTable]+accountsHistorySelect accountName =+    if (accountName == [])+        then return []+        else do+            accountID <- accountsTableSelectID accountName+            runDB $+                selectList (   [ OperationsTableFrom ==. accountID ]+                           ||. [ OperationsTableTo ==. accountID ]+                           )+                           [ LimitTo 100+                           , Desc OperationsTableDate ]
+ src/Coin/UI/Accounts/AccountsIncome.hs view
@@ -0,0 +1,238 @@+{-+ *  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.AccountsIncome (+    accountsIncomeNew+) 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.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.Utils.I18N+import Coin.Utils.ValueParser+import Coin.UI.HistoryView++accountsIncomeNew :: MainState -> IO Gtk.Widget+accountsIncomeNew mainState = do+    cal <- calendarNew CalendarSizeNormal++    operationsView <- historyViewNew True False 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 (__"Add 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 (__"To 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+            accountsIncomeViewUpdate mainState operationsView accountName+        accountsIncomeBalanceUpdate 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+                accountsIncomeAppend mainState cal tagsBox accountName entryDescription value'+                Gtk.entrySetText entryValue ""+                Gtk.entrySetText entryDescription ""+                Gtk.widgetShow errorValue+                Gtk.widgetSetSensitive buttonAdd False+                accountsIncomeViewUpdate mainState operationsView accountName+                accountsIncomeBalanceUpdate 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+                accountsIncomeRemove accountName entity'+                accountsIncomeViewUpdate mainState operationsView accountName+                accountsIncomeBalanceUpdate 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++    mainStateSavePropertiesAction mainState "Coin.UI.Accounts.AccountsIncome" $ do+        i <- liftIO $ Gtk.comboBoxGetActive tagsBox+        propertyInsert "i" i++    mainStateReadPropertiesAction mainState "Coin.UI.Accounts.AccountsIncome" $ do+        propertyRead "i" $ \i ->+            liftIO $ Gtk.comboBoxSetActive tagsBox i++    return root++accountsIncomeViewUpdate :: MainState -> HistoryViewWidget -> Gtk.Label -> IO ()+accountsIncomeViewUpdate mainState operationsView accountName = do+    accountName' <- Gtk.labelGetText accountName+    entities <- accountsIncomeSelect mainState accountName'+    historyViewUpdate mainState operationsView entities++accountsIncomeSelect :: MainState -> String -> IO [Entity OperationsTable]+accountsIncomeSelect mainState accountName =+    if (accountName == [])+        then return []+        else do+            let incomeID = mainStateIncomeID mainState+            accountID <- accountsTableSelectID accountName+            runDB $+                selectList [ OperationsTableFrom ==. incomeID+                           , OperationsTableTo   ==. accountID ]+                           [ LimitTo 100+                           , Desc OperationsTableDate ]++accountsIncomeAppend :: MainState -> CalendarWidget -> Gtk.ComboBox -> Gtk.Label -> Gtk.Entry -> Int -> IO ()+accountsIncomeAppend mainState cal tagsBox accountName entryDescription value = do+    date <- calendarDateToInt <$> calendarGetSelectedDate cal+    (Just tag) <- Gtk.comboBoxGetActiveText tagsBox+    tagID <- tagsTableSelectID $ T.unpack tag+    let fromID = mainStateIncomeID mainState+    toName <- Gtk.labelGetText accountName+    toID <- accountsTableSelectID toName+    desc <- Gtk.entryGetText entryDescription :: IO String++    runDB $ do+        void $ insert $ OperationsTable date fromID toID value tagID desc+        update toID [AccountsTableBalance +=. (fromIntegral value)]++accountsIncomeRemove :: Gtk.Label -> Entity OperationsTable -> IO ()+accountsIncomeRemove accountName entity = do+    let (Entity entityID op) = entity+    toName <- Gtk.labelGetText accountName+    toID <- accountsTableSelectID toName++    runDB $ do+        delete entityID+        update toID [AccountsTableBalance -=. (fromIntegral $ operationsTableValue op)]++accountsIncomeBalanceUpdate :: Gtk.Label -> Gtk.Label -> IO ()+accountsIncomeBalanceUpdate accountName balanceLabel = do+    name <- Gtk.labelGetText accountName+    accountID <- accountsTableSelectID name+    val <- accountsTableSelectBalance accountID+    Gtk.labelSetText balanceLabel $ valueShow val
+ src/Coin/UI/Accounts/AccountsOutcome.hs view
@@ -0,0 +1,238 @@+{-+ *  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.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.Utils.I18N+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+        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+                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+                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++    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 -> IO ()+accountsOutcomeViewUpdate mainState operationsView accountName = do+    accountName' <- Gtk.labelGetText accountName+    entities <- accountsOutcomeSelect mainState accountName'+    historyViewUpdate mainState operationsView entities++accountsOutcomeSelect :: MainState -> String -> IO [Entity OperationsTable]+accountsOutcomeSelect mainState accountName =+    if (accountName == [])+        then return []+        else do+            let outcomeID = mainStateOutcomeID mainState+            accountID <- accountsTableSelectID accountName+            runDB $+                selectList [ OperationsTableFrom ==. accountID+                           , OperationsTableTo   ==. outcomeID ]+                           [ LimitTo 100+                           , 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
+ src/Coin/UI/Accounts/AccountsTransfer.hs view
@@ -0,0 +1,291 @@+{-+ *  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.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.Utils.I18N+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+        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+                    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+                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++    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 -> IO ()+accountsTransferViewUpdate mainState operationsView accountName = do+    accountName' <- Gtk.labelGetText accountName+    entities <- accountsTransferSelect mainState accountName'+    historyViewUpdate mainState operationsView entities++accountsTransferSelect :: MainState -> String -> IO [Entity OperationsTable]+accountsTransferSelect mainState accountName =+    if (accountName == [])+        then return []+        else do+            let outcomeID = mainStateOutcomeID mainState+            let incomeID = mainStateIncomeID mainState+            accountID <- accountsTableSelectID accountName+            runDB $+                selectList (   [ OperationsTableFrom ==. accountID , OperationsTableTo !=. outcomeID ]+                           ||. [ OperationsTableTo ==. accountID, OperationsTableFrom !=. incomeID ]+                           )+                           [ LimitTo 100+                           , 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
+ src/Coin/UI/Accounts/AccountsWidget.hs view
@@ -0,0 +1,81 @@+{-+ *  Programmer:	Piotr Borek+ *  E-mail:     piotrborek@op.pl+ *  Copyright 2015 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.AccountsWidget (+    AccountsWidget,+    accountsWidgetNew+) where++import qualified System.Glib.Types as Gtk+import qualified Graphics.UI.Gtk as Gtk++import Control.Monad.IO.Class++import Coin.UI.MainState+import Coin.UI.Builder.GtkUIBuilder+import Coin.Utils.I18N+import Coin.UI.Accounts.AccountsIncome+import Coin.UI.Accounts.AccountsOutcome+import Coin.UI.Accounts.AccountsTransfer+import Coin.UI.Accounts.AccountsHistory++data AccountsWidget = AccountsWidget {+    accountsContainer :: Gtk.Notebook+}++instance Gtk.GObjectClass AccountsWidget where+    toGObject = Gtk.toGObject . accountsContainer+    unsafeCastGObject = undefined++instance Gtk.WidgetClass AccountsWidget++accountsWidgetNew :: MainState -> IO AccountsWidget+accountsWidgetNew mainState = do+    incomePageWidget <- accountsIncomeNew mainState+    outcomePageWidget <- accountsOutcomeNew mainState+    transferPageWidget <- accountsTransferNew mainState+    historyPageWidget <- accountsHistoryNew mainState++    (_, root) <- uiBuildGtk $ do+        notebook Nothing $ do+            simplePage (__"Income") $+                putWidget incomePageWidget+            simplePage (__"Outcome") $ do+                putWidget outcomePageWidget+            simplePage (__"Transfer") $ do+                putWidget transferPageWidget+            simplePage (__"History") $ do+                putWidget historyPageWidget++    Gtk.widgetShowAll root++    let nb = Gtk.castToNotebook root++    mainStateSavePropertiesAction mainState "Coin.UI.Accounts.AccountsWidget" $ do+        i <- liftIO $ Gtk.notebookGetCurrentPage nb+        propertyInsert "i" i++    mainStateReadPropertiesAction mainState "Coin.UI.Accounts.AccountsWidget" $ do+        propertyRead "i" $ \i ->+            liftIO $ Gtk.notebookSetCurrentPage nb i++    return $ AccountsWidget nb
+ src/Coin/UI/AccountsComboBox.hs view
@@ -0,0 +1,75 @@+{-+ *  Programmer:	Piotr Borek+ *  E-mail:     piotrborek@op.pl+ *  Copyright 2015 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.AccountsComboBox (+    accountsComboBoxNew,+    accountsComboBoxSelect+) where++import qualified Graphics.UI.Gtk as Gtk+import Graphics.UI.Gtk ( AttrOp(..) )++import qualified Data.Text as T+import Control.Monad++import Database.Persist++import Coin.DB.Tables+import Coin.UI.Utils.Observable+import Coin.UI.MainState++accountsComboBoxNew :: MainState -> IO Gtk.ComboBox+accountsComboBoxNew mainState = do+    c <- Gtk.comboBoxNewWithEntry++    void $ Gtk.comboBoxSetModelText c+    (Just entry) <- Gtk.binGetChild c+    Gtk.set (Gtk.castToEntry entry) [Gtk.entryEditable := False]++    observableRegister (mainStateAccountsUpdated mainState) $ accountsComboBoxUpdate' c++    Gtk.widgetSetSizeRequest c 240 28+    return c++accountsComboBoxSelect :: MainState -> IO [Entity AccountsTable]+accountsComboBoxSelect mainState = do+    accountIDs <- accountsOptionsTableRead+    entities <- filterEntities <$> accountsTableSelectAll++    let rs = filter (\(Entity entityID _) -> entityID `notElem` accountIDs) entities++    let hs' = [z | x <- accountIDs, z@(Entity y _) <- entities, x == y ]++    return $ hs' ++ rs+  where+    filterEntities = filter $ \(Entity _ item) ->+                         accountsTableName item /= mainStateIncomeName mainState && accountsTableName item /= mainStateOutcomeName mainState++accountsComboBoxUpdate' :: Gtk.ComboBox -> [Entity AccountsTable] -> IO ()+accountsComboBoxUpdate' combo entities = do+    boxModel <- Gtk.comboBoxGetModelText combo++    let accountsList = fmap (\(Entity _ account) -> T.pack $ accountsTableName account) entities++    Gtk.listStoreClear boxModel+    forM_ accountsList $ Gtk.listStoreAppend boxModel+    Gtk.comboBoxSetActive combo 0
+ src/Coin/UI/Builder/GtkUIAttributes.hs view
@@ -0,0 +1,48 @@+{-+ *  Programmer:	Piotr Borek+ *  E-mail:     piotrborek@op.pl+ *  Copyright 2015 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.Builder.GtkUIAttributes where++import qualified Graphics.UI.Gtk as Gtk++data Attrs = EmptyAttrs+           | WidgetAttrs    [Gtk.AttrOp Gtk.Widget]+           | WindowAttrs    [Gtk.AttrOp Gtk.Window]+           | ButtonAttrs    [Gtk.AttrOp Gtk.Button]+           | LabelAttrs     [Gtk.AttrOp Gtk.Label]+           | FrameAttrs     [Gtk.AttrOp Gtk.Frame]+           | ArrowAttrs     [Gtk.AttrOp Gtk.Arrow]+           | EntryAttrs     [Gtk.AttrOp Gtk.Entry]+           | GridAttrs      [Gtk.AttrOp Gtk.Grid]+           | ContainerAttrs [Gtk.AttrOp Gtk.Container]++gridColumnSpacing :: Gtk.GridClass self => Gtk.Attr self Int+gridColumnSpacing = Gtk.newAttr Gtk.gridGetColumnSpacing Gtk.gridSetColumnSpacing++gridRowSpacing :: Gtk.GridClass self => Gtk.Attr self Int+gridRowSpacing = Gtk.newAttr Gtk.gridGetRowSpacing Gtk.gridSetRowSpacing++gridColumnHomogeneous :: Gtk.GridClass self => Gtk.Attr self Bool+gridColumnHomogeneous = Gtk.newAttr Gtk.gridGetColumnHomogeneous Gtk.gridSetColumnHomogeneous++gridRowHomogeneous :: Gtk.GridClass self => Gtk.Attr self Bool+gridRowHomogeneous = Gtk.newAttr Gtk.gridGetRowHomogeneous Gtk.gridSetRowHomogeneous
+ src/Coin/UI/Builder/GtkUIBuilder.hs view
@@ -0,0 +1,330 @@+{-+ *  Programmer:	Piotr Borek+ *  E-mail:     piotrborek@op.pl+ *  Copyright 2015 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.Builder.GtkUIBuilder (+    -- attributes+    widgetAttrs,+    windowAttrs,+    buttonAttrs,+    labelAttrs,+    frameAttrs,+    arrowAttrs,+    entryAttrs,+    gridAttrs,+    containerAttrs,+    globalCss,+    -- containers+    window,+    scrolledWindow,+    frame,+    vbox,+    hbox,+    hPaned,+    vPaned,+    notebook,+    simplePage,+    grid,+    gridAttach,+    -- widgets+    label,+    button,+    buttonFromStock,+    checkButton,+    toggleButton,+    imageFromStock,+    hseparator,+    vseparator,+    entry,+    textview,+    arrow,+    -- some functions+    putWidget,+    packing,+    packingDefault,+    pack,+    packDefault,+    -- re-exports+    uiBuildGtk,+    UIBuilder,+    gridColumnSpacing,+    gridRowSpacing,+    gridColumnHomogeneous,+    gridRowHomogeneous+) where++import qualified Data.Map.Strict as Map+import qualified Graphics.UI.Gtk as Gtk+import Graphics.UI.Gtk ( AttrOp(..) )++import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.State.Strict+import Data.Maybe+import Lens.Simple++import Coin.UI.Builder.GtkUIAttributes+import Coin.UI.Builder.GtkUIBuilderState+import Coin.UI.Builder.GtkUIUtils++-- attributes++widgetAttrs :: [AttrOp Gtk.Widget] -> UIBuilder a+widgetAttrs attrs = uiStateAttrs .= WidgetAttrs attrs++windowAttrs :: [AttrOp Gtk.Window] -> UIBuilder a+windowAttrs attrs = uiStateAttrs .= WindowAttrs attrs++buttonAttrs :: [AttrOp Gtk.Button] -> UIBuilder a+buttonAttrs attrs = uiStateAttrs .= ButtonAttrs attrs++labelAttrs :: [AttrOp Gtk.Label] -> UIBuilder a+labelAttrs attrs = uiStateAttrs .= LabelAttrs attrs++frameAttrs :: [AttrOp Gtk.Frame] -> UIBuilder a+frameAttrs attrs = uiStateAttrs .= FrameAttrs attrs++arrowAttrs :: [AttrOp Gtk.Arrow] -> UIBuilder a+arrowAttrs attrs = uiStateAttrs .= ArrowAttrs attrs++entryAttrs :: [AttrOp Gtk.Entry] -> UIBuilder a+entryAttrs attrs = uiStateAttrs .= EntryAttrs attrs++gridAttrs :: [AttrOp Gtk.Grid] -> UIBuilder a+gridAttrs attrs = uiStateAttrs .= GridAttrs attrs++containerAttrs :: [AttrOp Gtk.Container] -> UIBuilder a+containerAttrs attrs = uiStateAttrs .= ContainerAttrs attrs++globalCss :: [String] -> UIBuilder a+globalCss cssText = uiStateCss .= cssText++-- containers++window :: Maybe String -> String -> UIBuilder a -> UIBuilder a+window name title builder = do+    win <- liftIO Gtk.windowNew+    liftIO $ Gtk.set win [ Gtk.windowTitle := title ]+    recordUI builder (Gtk.containerAdd win)+    record name win++scrolledWindow :: Maybe String -> UIBuilder a -> UIBuilder a+scrolledWindow name builder = do+    scrolled <- liftIO $ Gtk.scrolledWindowNew Nothing Nothing+    liftIO $ do+        Gtk.scrolledWindowSetMinContentWidth scrolled 100+        Gtk.scrolledWindowSetMinContentHeight scrolled 100+    recordUI builder (Gtk.containerAdd scrolled)+    record name scrolled++frame :: Maybe String -> Maybe String -> UIBuilder a -> UIBuilder a+frame name text builder = do+    fr <- liftIO Gtk.frameNew+    case text of+        Just text' -> liftIO $ Gtk.frameSetLabel fr text'+        Nothing    -> return ()+    recordUI builder (Gtk.containerAdd fr)+    record name fr++vbox :: Maybe String -> Bool -> Int -> UIBuilder a -> UIBuilder a+vbox name homogeneous spacing builder = do+    box <- liftIO $ Gtk.vBoxNew homogeneous spacing+    recordUI' builder (Gtk.boxPackStart box)+    record name box++hbox :: Maybe String -> Bool -> Int -> UIBuilder a -> UIBuilder a+hbox name homogeneous spacing builder = do+    box <- liftIO $ Gtk.hBoxNew homogeneous spacing+    recordUI' builder (Gtk.boxPackStart box)+    record name box++hPaned :: Maybe String -> UIBuilder a -> UIBuilder a -> UIBuilder a+hPaned name left right = do+    paned <- liftIO Gtk.hPanedNew+    recordUI left  (Gtk.panedAdd1 paned)+    recordUI right (Gtk.panedAdd2 paned)++    liftIO $ do+        child1 <- Gtk.panedGetChild1 paned+        case child1 of+            Just child1' -> do+                Gtk.widgetSetSizeRequest child1' 100 (-1)+                Gtk.set paned [ Gtk.panedChildShrink child1' := False ]+            Nothing ->+                return ()++    record name paned++vPaned :: Maybe String -> UIBuilder a -> UIBuilder a -> UIBuilder a+vPaned name left right = do+    paned <- liftIO Gtk.vPanedNew+    recordUI left  (Gtk.panedAdd1 paned)+    recordUI right (Gtk.panedAdd2 paned)++    liftIO $ do+        child1 <- Gtk.panedGetChild1 paned+        case child1 of+            Just child1' -> do+                Gtk.widgetSetSizeRequest child1' (-1) 100+                Gtk.set paned [ Gtk.panedChildShrink child1' := False ]+            Nothing ->+                return ()++    record name paned++notebook :: Maybe String -> UINotebookBuilder a -> UIBuilder a+notebook name builder = do+    nb <- liftIO Gtk.notebookNew++    builderState <- get+    ui <- liftIO $ execUINotebookBuilder $ do+        uiNSBuilderState .= builderState+        builder++    forM_ (ui^.uiNSList) $ \(textLabel, pageWidget) ->+        void $ liftIO $ Gtk.notebookAppendPageMenu nb pageWidget textLabel textLabel+    uiStateMap %= Map.union (ui^.uiNSMap)+    record name nb++simplePage :: String -> UIBuilder a -> UINotebookBuilder a+simplePage text builder = do+    textLabel <- liftIO $ Gtk.labelNew $ Just text++    builderState <- use uiNSBuilderState+    (hashMap, widgetList) <- liftIO $ uiBuildGtk' builderState builder+    uiNSMap %= Map.union hashMap+    uiNSList <>= [(Gtk.castToWidget textLabel, fromJust $ widgetList^?traverse.wdWidget)]++grid :: Maybe String -> UIGridBuilder a -> UIBuilder a+grid name builder = do+    t <- liftIO Gtk.gridNew++    builderState <- get+    ui <- liftIO $ execUIGridBuilder $ do+        uiGridBuilderState .= builderState+        builder++    uiStateMap %= Map.union (ui^.uiGridMap)+    forM_ (ui^.uiGridList) $ \dta ->+        liftIO $ Gtk.gridAttach+                 t+                 (dta^.uiGridDataWidget)+                 (dta^.uiGridDataLeft)+                 (dta^.uiGridDataRight)+                 (dta^.uiGridDataWidth)+                 (dta^.uiGridDataHeight)+    record name t++gridAttach :: Int -> Int -> Int -> Int -> UIBuilder a -> UIGridBuilder a+gridAttach left right width height builder = do+    builderState <- use uiGridBuilderState+    (hashMap, widgetList) <- liftIO $ uiBuildGtk' builderState builder+    uiGridMap %= Map.union hashMap+    uiGridList <>= [UIGridData+                        { _uiGridDataWidget = fromJust $ widgetList^?traverse.wdWidget+                        , _uiGridDataLeft = left+                        , _uiGridDataRight = right+                        , _uiGridDataWidth = width+                        , _uiGridDataHeight = height+                        }]++-- widgets++label :: Maybe String -> String -> UIBuilder a+label name text = do+    lab <- liftIO $ Gtk.labelNew $ Just text+    record name lab++button :: Maybe String -> String -> UIBuilder a+button name text = do+    b <- liftIO $ Gtk.buttonNewWithLabel text+    record name b++buttonFromStock :: Maybe String -> Gtk.StockId -> UIBuilder a+buttonFromStock name stockID = do+    b <- liftIO $ Gtk.buttonNewFromStock stockID+    record name b++checkButton :: Maybe String -> String -> UIBuilder a+checkButton name text = do+    b <- liftIO $ Gtk.checkButtonNewWithLabel text+    record name b++toggleButton :: Maybe String -> String -> UIBuilder a+toggleButton name text = do+    b <- liftIO $ Gtk.toggleButtonNewWithLabel text+    record name b++imageFromStock :: Maybe String -> Gtk.StockId -> Gtk.IconSize -> UIBuilder a+imageFromStock name stockID size = do+    image <- liftIO $ Gtk.imageNewFromStock stockID size+    record name image++hseparator :: Maybe String -> UIBuilder a+hseparator name = do+    sep <- liftIO Gtk.hSeparatorNew+    record name sep++vseparator :: Maybe String -> UIBuilder a+vseparator name = do+    sep <- liftIO Gtk.vSeparatorNew+    record name sep++entry :: Maybe String -> String -> UIBuilder a+entry name text = do+    e <- liftIO Gtk.entryNew+    liftIO $ Gtk.entrySetText e text+    record name e++textview :: Maybe String -> String -> UIBuilder a+textview name text = do+    t <- liftIO Gtk.textViewNew+    b <- liftIO $ Gtk.textViewGetBuffer t+    liftIO $ Gtk.textBufferSetText b text+    record name t++arrow :: Maybe String -> Gtk.ArrowType -> Gtk.ShadowType -> UIBuilder a+arrow name arrowType shadowType = do+    a <- liftIO $ Gtk.arrowNew arrowType shadowType+    record name a++-- functions++putWidget :: Gtk.WidgetClass cls => cls -> UIBuilder a+putWidget = record Nothing++packing :: Gtk.Packing -> Int -> UIBuilder a+packing packing' padding = uiStatePack .= (packing', padding)++packingDefault :: UIBuilder a+packingDefault = uiStatePack .= _uiStatePack builderStateEmpty++pack :: Gtk.Packing -> Int -> UIBuilder a -> UIBuilder a+pack packing' padding builder = do+    packTmp <- use uiStatePack+    packing packing' padding+    builder+    uiStatePack .= packTmp++packDefault :: UIBuilder a -> UIBuilder a+packDefault builder = do+    let (packing', padding) = _uiStatePack builderStateEmpty+    pack packing' padding builder
+ src/Coin/UI/Builder/GtkUIBuilderState.hs view
@@ -0,0 +1,109 @@+{-+ *  Programmer:	Piotr Borek+ *  E-mail:     piotrborek@op.pl+ *  Copyright 2015 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+-}++{-# LANGUAGE TemplateHaskell #-}++{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++module Coin.UI.Builder.GtkUIBuilderState where++import qualified Data.Map.Strict as Map+import qualified Graphics.UI.Gtk as Gtk++import Control.Monad.State.Strict+import Lens.Simple++import Coin.UI.Builder.GtkUIAttributes++data WidgetData = WidgetData {+    _wdWidget  :: Gtk.Widget,+    _wdPacking :: Gtk.Packing,+    _wdPadding :: Int+}++data UIBuilderState = UIBuilderState {+    _uiStateMap   :: Map.Map String Gtk.Widget,+    _uiStateList  :: [WidgetData],+    _uiStatePack  :: (Gtk.Packing, Int),+    _uiStateAttrs :: Attrs,+    _uiStateCss   :: [String]+}++data UINotebookState = UINotebookState {+    _uiNSBuilderState :: UIBuilderState,+    _uiNSMap          :: Map.Map String Gtk.Widget,+    _uiNSList         :: [(Gtk.Widget, Gtk.Widget)]+}++data UIGridData = UIGridData {+    _uiGridDataWidget :: Gtk.Widget,+    _uiGridDataLeft   :: Int,+    _uiGridDataRight  :: Int,+    _uiGridDataWidth  :: Int,+    _uiGridDataHeight :: Int+}++data UIGridState = UIGridState {+    _uiGridBuilderState :: UIBuilderState,+    _uiGridMap          :: Map.Map String Gtk.Widget,+    _uiGridList         :: [UIGridData]+}++makeLenses ''WidgetData+makeLenses ''UIBuilderState+makeLenses ''UINotebookState+makeLenses ''UIGridData+makeLenses ''UIGridState++builderStateEmpty :: UIBuilderState+builderStateEmpty = UIBuilderState {+                         _uiStateMap   = Map.empty,+                         _uiStateList  = [],+                         _uiStatePack  = (Gtk.PackGrow, 0),+                         _uiStateAttrs = EmptyAttrs,+                         _uiStateCss   = []+                     }++uiNotebookStateEmpty = UINotebookState {+                           _uiNSBuilderState = builderStateEmpty,+                           _uiNSMap          = Map.empty,+                           _uiNSList         = []+                       }++uiGridStateEmpty = UIGridState {+                        _uiGridBuilderState = builderStateEmpty,+                        _uiGridMap = Map.empty,+                        _uiGridList = []+                    }++type UIBuilder a = StateT UIBuilderState IO ()+type UINotebookBuilder a = StateT UINotebookState IO ()+type UIGridBuilder a = StateT UIGridState IO ()++execUIBuilder :: UIBuilder a -> IO UIBuilderState+execUIBuilder builder = execStateT builder builderStateEmpty++execUINotebookBuilder :: UINotebookBuilder a -> IO UINotebookState+execUINotebookBuilder builder = execStateT builder uiNotebookStateEmpty++execUIGridBuilder :: UIGridBuilder a -> IO UIGridState+execUIGridBuilder builder = execStateT builder uiGridStateEmpty
+ src/Coin/UI/Builder/GtkUIUtils.hs view
@@ -0,0 +1,111 @@+{-+ *  Programmer:	Piotr Borek+ *  E-mail:     piotrborek@op.pl+ *  Copyright 2015 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.Builder.GtkUIUtils (+    uiBuildGtk',+    uiBuildGtk,+    recordUI,+    recordUI',+    record+) where++import qualified Data.Map.Strict as Map+import qualified Graphics.UI.Gtk as Gtk+import Graphics.UI.Gtk ( AttrOp(..) )++import Control.Monad+import Control.Monad.State.Strict+import Data.Maybe+import Lens.Simple++import Coin.UI.Utils.CssUtils+import Coin.UI.Builder.GtkUIBuilderState+import Coin.UI.Builder.GtkUIAttributes++uiGetObject :: Map.Map String Gtk.Widget -> String -> Maybe Gtk.Widget+uiGetObject hashMap name = Map.lookup name hashMap++uiBuildGtk' :: UIBuilderState -> UIBuilder a -> IO (Map.Map String Gtk.Widget, [WidgetData])+uiBuildGtk' st builder = do+    bs <- execUIBuilder $ do+        uiStatePack .= st^.uiStatePack+        uiStateCss .= st^.uiStateCss+        builder+    return (bs^.uiStateMap, bs^.uiStateList)++uiBuildGtk :: UIBuilder a -> IO (String -> Maybe Gtk.Widget, Gtk.Widget)+uiBuildGtk builder = do+    (hashMap, widgetList) <- uiBuildGtk' builderStateEmpty builder+    return (uiGetObject hashMap, fromJust $  widgetList^?traverse.wdWidget)++recordUI :: UIBuilder a -> (Gtk.Widget -> IO ()) -> UIBuilder a+recordUI builder f = do+    st <- get+    (hashMap, widgetList) <- liftIO $ uiBuildGtk' st builder+    case widgetList^?traverse.wdWidget of+        Just root -> liftIO $ f root+        Nothing   -> return ()+    uiStateMap %= Map.union hashMap++recordUI' :: UIBuilder a -> (Gtk.Widget -> Gtk.Packing -> Int -> IO ()) -> UIBuilder a+recordUI' builder f = do+    st <- get+    (hashMap, widgetList) <- liftIO $ uiBuildGtk' st builder+    liftIO $ forM_ widgetList $ \(WidgetData widget packing padding) -> do+        f widget packing padding+    uiStateMap %= Map.union hashMap++record :: Gtk.WidgetClass cls => Maybe String -> cls -> UIBuilder a+record name widget = do+    packing <- use uiStatePack+    css     <- use uiStateCss++    when (css /= []) $ liftIO $ Gtk.set widget [cssStyle := css]++    let wd = WidgetData {+                 _wdWidget  = Gtk.castToWidget widget,+                 _wdPacking = packing^._1,+                 _wdPadding = packing^._2+             }++    uiStateList <>= [wd]+    when (isJust name) $ do+        uiStateMap %= Map.insert (fromJust name) (Gtk.castToWidget widget)+    setWidgetAttributes widget++setWidgetAttributes :: Gtk.WidgetClass cls => cls -> UIBuilder a+setWidgetAttributes widget = do+    attrs <- use uiStateAttrs++    liftIO $ case attrs of+        WidgetAttrs attrs'    -> Gtk.set (Gtk.castToWidget widget) attrs'+        WindowAttrs attrs'    -> Gtk.set (Gtk.castToWindow widget) attrs'+        ButtonAttrs attrs'    -> Gtk.set (Gtk.castToButton widget) attrs'+        LabelAttrs  attrs'    -> Gtk.set (Gtk.castToLabel widget) attrs'+        FrameAttrs  attrs'    -> Gtk.set (Gtk.castToFrame widget) attrs'+        ArrowAttrs  attrs'    -> Gtk.set (Gtk.castToArrow widget) attrs'+        EntryAttrs  attrs'    -> Gtk.set (Gtk.castToEntry widget) attrs'+        GridAttrs   attrs'    -> Gtk.set (Gtk.castToGrid widget) attrs'+        ContainerAttrs attrs' -> Gtk.set (Gtk.castToContainer widget) attrs'+        _                     -> return ()++    uiStateAttrs .= EmptyAttrs
+ src/Coin/UI/HistoryView.hs view
@@ -0,0 +1,121 @@+{-+ *  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+-}++{-#LANGUAGE FlexibleContexts #-}++module Coin.UI.HistoryView (+    HistoryViewWidget,+    historyViewNew,+    historyViewGetSelected,+    historyViewUpdate+) where++import qualified System.Glib.Types as Gtk+import qualified Graphics.UI.Gtk as Gtk+import Graphics.UI.Gtk ( AttrOp(..) )++import Database.Persist+import Control.Monad++import Coin.DB.Tables+import Coin.DB.Functions+import Coin.UI.MainState+import Coin.UI.Utils.CalendarUtils+import Coin.Utils.I18N+import Coin.Utils.ValueParser+import Coin.Utils.TableView++type HistoryData = (Entity OperationsTable, String, String, String, String, String, String, String, String)++data HistoryViewWidget = HistoryViewWidget {+    historyViewContainer :: Gtk.TreeView,+    historyViewStore     :: Gtk.ListStore HistoryData+}++instance Gtk.GObjectClass HistoryViewWidget where+    toGObject = Gtk.toGObject . historyViewContainer+    unsafeCastGObject = undefined++instance Gtk.WidgetClass HistoryViewWidget+instance Gtk.ContainerClass HistoryViewWidget+instance Gtk.TreeViewClass HistoryViewWidget++historyViewNew :: Bool -> Bool -> Bool -> IO HistoryViewWidget+historyViewNew incomeVisible outcomeVisible transferVisible = do+    store <- Gtk.listStoreNew []+    treeView <- Gtk.treeViewNewWithModel store++    col1 <- tableTextColumnNew (__"Date")        store $ \(_, x, _, _, _, _, _, _, _ ) -> [ Gtk.cellText := x ]+    col2 <- tableTextColumnNew (__"From")        store $ \(_, _, x, _, _, _, _, _, _ ) -> [ Gtk.cellText := x ]+    col3 <- tableTextColumnNew (__"To")          store $ \(_, _, _, x, _, _, _, _, _ ) -> [ Gtk.cellText := x ]+    col4 <- tableTextColumnNew (__"Income")      store $ \(_, _, _, _, x, _, _, _, _ ) -> [ Gtk.cellText := x ]+    col5 <- tableTextColumnNew (__"Outcome")     store $ \(_, _, _, _, _, x, _, _, _ ) -> [ Gtk.cellText := x ]+    col6 <- tableTextColumnNew (__"Transfer")    store $ \(_, _, _, _, _, _, x, _, _ ) -> [ Gtk.cellText := x ]+    col7 <- tableTextColumnNew (__"Tag")         store $ \(_, _, _, _, _, _, _, x, _ ) -> [ Gtk.cellText := x ]+    col8 <- tableTextColumnNew (__"Description") store $ \(_, _, _, _, _, _, _, _, x ) -> [ Gtk.cellText := x ]++    forM_ [col1, col2, col3, col4, col5, col6, col7, col8] $ Gtk.treeViewAppendColumn treeView++    Gtk.treeViewColumnSetVisible col4 incomeVisible+    Gtk.treeViewColumnSetVisible col5 outcomeVisible+    Gtk.treeViewColumnSetVisible col6 transferVisible+    Gtk.treeViewColumnSetVisible col2 transferVisible+    Gtk.treeViewColumnSetVisible col3 transferVisible++    Gtk.treeViewSetHeadersVisible treeView True++    return $ HistoryViewWidget treeView store++historyViewGetSelected :: HistoryViewWidget -> IO (Maybe (Entity OperationsTable))+historyViewGetSelected view = do+    (path, _) <- Gtk.treeViewGetCursor $ historyViewContainer view+    if path == []+        then return Nothing+        else do+            (entity, _, _, _, _, _, _, _, _ ) <- Gtk.listStoreGetValue (historyViewStore view) (head path)+            return $ Just entity++historyViewUpdate :: MainState -> HistoryViewWidget -> [Entity OperationsTable] -> IO ()+historyViewUpdate mainState view entities = do+    list <- historyViewUpdate' mainState entities++    Gtk.listStoreClear $ historyViewStore view+    forM_ list $ Gtk.listStoreAppend (historyViewStore view)++historyViewUpdate' :: MainState -> [Entity OperationsTable] -> IO [HistoryData]+historyViewUpdate' mainState entities = do+    let incomeID = mainStateIncomeID mainState+    let outcomeID = mainStateOutcomeID mainState++    list <- runDB $ forM entities $ \entity@(Entity _ op) -> do+                let date = calendarShow $ operationsTableDate op+                (Just (Entity fromID from)) <- rawSqlFirstCached $ "SELECT ?? FROM AccountsTable WHERE id = " ++ showSqlKey (operationsTableFrom op)+                (Just (Entity toID to)) <- rawSqlFirstCached $ "SELECT ?? FROM AccountsTable WHERE id = " ++ showSqlKey (operationsTableTo op)+                let value = valueShow $ operationsTableValue op+                (Just (Entity _ tag)) <- rawSqlFirstCached $ "SELECT ?? FROM TagsTable WHERE id = " ++ showSqlKey (operationsTableTag op)+                let desc = operationsTableDescription op++                if | fromID == incomeID -> return (entity, date, "", "", value, "", "", tagsTableName tag, desc)+                   | toID == outcomeID  -> return (entity, date, "", "", "", value, "", tagsTableName tag, desc)+                   | otherwise          -> return (entity, date, accountsTableName from, accountsTableName to, "", "", value, tagsTableName tag, desc)++    return list
+ src/Coin/UI/MainInitialize.hs view
@@ -0,0 +1,39 @@+{-+ *  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.MainInitialize (+    mainInitializeWidgets+) where++import Coin.UI.AccountsComboBox+import Coin.UI.TagsComboBox+import Coin.UI.MainState++mainInitializeWidgets :: MainState -> IO ()+mainInitializeWidgets mainState = do+    accounts <- accountsComboBoxSelect mainState+    observableSet (mainStateAccountsUpdated mainState) accounts++    tags <- tagsComboBoxSelect+    observableSet (mainStateTagsUpdated mainState) tags++    mainStateReadPropertiesFromDisk mainState
+ src/Coin/UI/MainMultiList.hs view
@@ -0,0 +1,77 @@+{-+ *  Programmer:	Piotr Borek+ *  E-mail:     piotrborek@op.pl+ *  Copyright 2015 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.MainMultiList (+    mainMultiListNew,+-- reexports+    MultiListWidget+) where++import Control.Monad+import Database.Persist++import Coin.DB.Tables+import Coin.Utils.I18N+import Coin.UI.MainState+import Coin.UI.Widgets.StackWidget+import Coin.UI.Widgets.MultiList+import Coin.UI.Raports.RaportHistory+import Coin.UI.Raports.RaportSummary++mainMultiListNew :: MainState -> StackWidget -> IO MultiListWidget+mainMultiListNew mainState stack = do+    multiList <- multiListNew++    accountsIndex <- multiListButtonNew multiList (__"Accounts")+    raportsIndex <- multiListButtonNew multiList (__"Raports")+    optionsIndex <- multiListButtonNew multiList (__"Options")++    multiListOptionAdd' multiList optionsIndex+        [ (__"Tags",     stackWidgetShow stack "tagsList")+        , (__"Accounts", stackWidgetShow stack "accountsList")+        ]++    observableRegister (mainStateAccountsUpdated mainState) $ multiListUpdateAccounts multiList accountsIndex++    multiListOptionAdd' multiList raportsIndex+        [ (__"Summary",+               do+                   stackWidgetGet stack "raportSummary" >>= raportSummaryUpdate' mainState+                   stackWidgetShow stack "raportSummary")+        , (__"History",+               do+                   stackWidgetGet stack "raportHistory" >>= raportHistoryUpdate' mainState+                   stackWidgetShow stack "raportHistory"+          )+        , (__"Queries", stackWidgetShow stack "raportQuery")+        ]++    return multiList++  where+    multiListUpdateAccounts multiList accountsIndex entities = do+        multiListOptionClear multiList accountsIndex+        forM_ entities $ \(Entity _ item) -> do+            let name = accountsTableName item+            multiListOptionAdd multiList accountsIndex name $ do+                observableSet (mainStateSelectedAccountName mainState) name+                stackWidgetShow stack "accounts"
+ src/Coin/UI/MainState.hs view
@@ -0,0 +1,173 @@+{-+ *  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.MainState (+    MainState (..),+    mainStateNew,+    mainStateReadPropertiesAction,+    mainStateReadPropertiesFromDisk,+    propertyRead,+    propertyRead2,+    propertyRead3,+    propertyRead4,+    mainStateSavePropertiesOnDisk,+    mainStateSavePropertiesAction,+    propertyInsert,+    propertyInsertMaybe,+--+    P.PropertyMap,+    module Coin.UI.Utils.Observable+) where++import qualified Data.Binary as Binary+import qualified Database.Persist as DB++import qualified Coin.Utils.PropertyMap as P++import Control.Monad.Reader+import Control.Monad.State.Strict+import Data.IORef+import Data.Foldable+import System.Directory++import Coin.DB.Tables+import Coin.UI.Utils.Observable+import Coin.Config.Dirs++data MainState = MainState {+    mainStateSelectedAccountName :: Observable String,+    mainStateTagsUpdated         :: Observable [DB.Entity TagsTable],+    mainStateAccountsUpdated     :: Observable [DB.Entity AccountsTable],+    mainStatePropertySaveActions :: IORef [(String, StateT P.PropertyMap IO ())],+    mainStatePropertyReadActions :: IORef [(String, ReaderT P.PropertyMap IO ())],+    mainStateIncomeID            :: AccountsTableId,+    mainStateOutcomeID           :: AccountsTableId,+    mainStateCashID              :: AccountsTableId,+    mainStateIncomeName          :: String,+    mainStateOutcomeName         :: String,+    mainStateCashName            :: String,+    mainStateNoneName            :: String+}++mainStateNew :: IO MainState+mainStateNew = do+    accountName <- observableNew+    tagsUpdated <- observableNew+    accountsUpdated <- observableNew+    propertySaveActions <- newIORef []+    propertyReadActions <- newIORef []++    incomeID <- accountsTableIncomeID+    outcomeID <- accountsTableOutcomeID+    cashID <- accountsTableCashID+    noneID <- tagsTableNoneID++    incomeName  <- accountsTableSelectName incomeID+    outcomeName <- accountsTableSelectName outcomeID+    cashName    <- accountsTableSelectName cashID+    noneName    <- tagsTableSelectName noneID++    return MainState {+        mainStateSelectedAccountName = accountName,+        mainStateTagsUpdated = tagsUpdated,+        mainStateAccountsUpdated = accountsUpdated,+        mainStatePropertySaveActions = propertySaveActions,+        mainStatePropertyReadActions = propertyReadActions,+        mainStateIncomeID = incomeID,+        mainStateOutcomeID = outcomeID,+        mainStateCashID = cashID,+        mainStateIncomeName = incomeName,+        mainStateOutcomeName = outcomeName,+        mainStateCashName = cashName,+        mainStateNoneName = noneName+    }++mainStateReadPropertiesAction :: MainState -> String -> ReaderT P.PropertyMap IO () -> IO ()+mainStateReadPropertiesAction mainState prefix action =+    modifyIORef' (mainStatePropertyReadActions mainState) $ \list ->+        (prefix, action):list++mainStateReadProperties :: P.PropertyMap -> (String, ReaderT P.PropertyMap IO ()) -> IO ()+mainStateReadProperties propertyMap (prefix, action) =+    case P.lookup prefix propertyMap of+        Just properties -> runReaderT action properties+        Nothing         -> return ()++mainStateReadPropertiesFromDisk :: MainState -> IO ()+mainStateReadPropertiesFromDisk mainState = do+    dir <- configGetDirectory+    exists <- doesFileExist $ dir ++ "/app_state.st"+    propertyMap <- if exists+                       then Binary.decodeFile (dir ++ "/app_state.st")+                       else return P.empty+    actions <- readIORef $ mainStatePropertyReadActions mainState++    forM_ actions $ mainStateReadProperties propertyMap++propertyRead :: P.IsProperty a => String -> (a -> ReaderT P.PropertyMap IO ()) -> ReaderT P.PropertyMap IO ()+propertyRead key action = do+    properties <- ask+    case P.lookup key properties of+        Just value -> action value+        Nothing    -> return ()++propertyRead2 :: P.IsProperty a => String -> String -> (a -> a -> ReaderT P.PropertyMap IO ()) -> ReaderT P.PropertyMap IO ()+propertyRead2 key1 key2 action = do+    propertyRead key1 $ \value1 ->+        propertyRead key2 $ \value2 -> action value1 value2++propertyRead3 :: P.IsProperty a => String -> String -> String -> (a -> a -> a -> ReaderT P.PropertyMap IO ()) -> ReaderT P.PropertyMap IO ()+propertyRead3 key1 key2 key3 action = do+    propertyRead key1 $ \value1 ->+        propertyRead2 key2 key3 $ \value2 value3 -> action value1 value2 value3++propertyRead4 :: P.IsProperty a => String -> String -> String -> String -> (a -> a -> a -> a -> ReaderT P.PropertyMap IO ()) -> ReaderT P.PropertyMap IO ()+propertyRead4 key1 key2 key3 key4 action = do+    propertyRead key1 $ \value1 ->+        propertyRead3 key2 key3 key4 $ \value2 value3 value4 -> action value1 value2 value3 value4++mainStateSavePropertiesOnDisk :: MainState -> IO ()+mainStateSavePropertiesOnDisk mainState = do+    actions <- readIORef $ mainStatePropertySaveActions mainState+    properties <- foldrM+        (\(prefix, action) m -> do+            m0 <- execStateT action P.empty+            return $+                case P.lookup prefix m of+                    Just m' -> P.insert prefix (P.union m' m0) m+                    Nothing -> P.insert prefix m0 m+        )+        P.empty+        actions+    dir <- configGetDirectory+    Binary.encodeFile (dir ++ "/app_state.st") properties++mainStateSavePropertiesAction :: MainState -> String -> StateT P.PropertyMap IO () -> IO ()+mainStateSavePropertiesAction mainState prefix action = do+    modifyIORef' (mainStatePropertySaveActions mainState) $ \list ->+        (prefix, action):list++propertyInsert :: P.IsProperty a => String -> a -> StateT P.PropertyMap IO ()+propertyInsert key value = get >>= \m -> put $ P.insert key value m++propertyInsertMaybe :: P.IsProperty a => String -> Maybe a -> StateT P.PropertyMap IO ()+propertyInsertMaybe key value = get >>= \m -> put $ P.insertMaybe key value m
+ src/Coin/UI/MainWindow.hs view
@@ -0,0 +1,129 @@+{-+ *  Programmer:	Piotr Borek+ *  E-mail:     piotrborek@op.pl+ *  Copyright 2015 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.MainWindow (+    mainWindowNew+) where++import Graphics.UI.Gtk+import Control.Monad+import Control.Monad.IO.Class+import Data.Maybe++import Coin.DB.Tables+import Coin.UI.MainMultiList+import Coin.UI.Accounts.AccountsWidget+import Coin.UI.Options.OptionsTag+import Coin.UI.Options.OptionsAccount+import Coin.UI.Widgets.StackWidget+import Coin.UI.Builder.GtkUIBuilder+import Coin.UI.Raports.RaportHistory+import Coin.UI.Raports.RaportSummary+import Coin.UI.Raports.RaportQuery+import Coin.UI.Widgets.MultiList++import Coin.UI.MainState++mainWindowNew :: MainState -> IO Window+mainWindowNew mainState = do+    stack <- stackWidgetNew+    multiList <- mainMultiListNew mainState stack++    emptyPage <- labelNew $ Just ""+    accounts <- accountsWidgetNew mainState+    tags <- optionsTagNew mainState+    accountsList <- optionsAccountNew mainState+    raportHistory <- raportHistoryNew mainState+    raportSummary <- raportSummaryNew mainState+    raportQuery <- raportQueryNew mainState++    stackWidgetAdd stack "empty" emptyPage+    stackWidgetAdd stack "accounts" accounts+    stackWidgetAdd stack "tagsList" tags+    stackWidgetAdd stack "accountsList" accountsList+    stackWidgetAdd stack "raportHistory" raportHistory+    stackWidgetAdd stack "raportSummary" raportSummary+    stackWidgetAdd stack "raportQuery" raportQuery++    (getObject, root) <- uiBuildGtk $+        window Nothing "" $+            scrolledWindow Nothing $+                hPaned (Just "paned")+                    (putWidget multiList)+                    (putWidget stack)++    let mainWindow = castToWindow root+    let paned = castToPaned . fromJust . getObject $ "paned"++    widgetShowAll mainWindow+    multiListButtonShow multiList 0+    stackWidgetShow stack "empty"++    void $ on mainWindow objectDestroy mainQuit+    void $ on mainWindow deleteEvent $ do+        liftIO $ do+            mainStateSavePropertiesOnDisk mainState+            accountIDs <- optionsAccountToIDList accountsList+            accountsOptionsTableUpdate accountIDs++        return False++    mainStateSavePropertiesAction mainState "Coin.UI.MainWindow" $ do+        (width, height) <- liftIO $ windowGetSize mainWindow+        propertyInsert "width" width+        propertyInsert "height" height++        (x, y) <- liftIO $ windowGetPosition mainWindow+        propertyInsert "x" x+        propertyInsert "y" y++        panedPos <- liftIO $ panedGetPosition paned+        propertyInsert "panedPos" panedPos++        cursor <- liftIO $ multiListOptionGetCursor multiList+        let (index, path) = case cursor of+                                Just (i, p) -> (Just i, Just p)+                                Nothing     -> (Nothing, Nothing)+        propertyInsertMaybe "multiListIndex" index+        propertyInsertMaybe "multiListPath" path++        stackIndex <- liftIO $ stackWidgetGetVisible stack+        propertyInsertMaybe "stackIndex" stackIndex++    windowResize mainWindow 800 600+    panedSetPosition paned 200++    mainStateReadPropertiesAction mainState "Coin.UI.MainWindow" $ do+        propertyRead2 "width" "height" $ \width height ->+            liftIO $ windowResize mainWindow width height+        propertyRead2 "x" "y" $ \x y ->+            liftIO $ windowMove mainWindow x y+        propertyRead "panedPos" $ \panedPos ->+            liftIO $ panedSetPosition paned panedPos++        propertyRead "multiListIndex" $ \index ->+            propertyRead "multiListPath" $ \path -> do+                liftIO $ multiListOptionSetCursor multiList index path+                propertyRead "stackIndex" $ \stackIndex ->+                    liftIO $ stackWidgetShow stack stackIndex++    return mainWindow
+ src/Coin/UI/Options/OptionsAccount.hs view
@@ -0,0 +1,271 @@+{-+ *  Programmer:	Piotr Borek+ *  E-mail:     piotrborek@op.pl+ *  Copyright 2015 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.Options.OptionsAccount (+    OptionsAccountWidget,+    optionsAccountNew,+    optionsAccountToIDList+) where++import qualified System.Glib.Types as Gtk+import qualified Graphics.UI.Gtk as Gtk+import Graphics.UI.Gtk ( AttrOp(..) )++import Data.Maybe+import Control.Monad+import Control.Monad.IO.Class+import Database.Persist++import Coin.DB.Tables+import Coin.DB.Functions+import Coin.Utils.I18N+import Coin.Utils.StringUtils+import Coin.UI.Widgets.MessageBox+import Coin.Utils.TableView+import Coin.UI.Builder.GtkUIBuilder+import Coin.UI.Utils.CssUtils+import Coin.UI.MainState++data OptionsAccountWidget = OptionsAccountWidget {+    optionsAccountRoot  :: Gtk.VBox,+    optionsAccountStore :: Gtk.ListStore (Entity AccountsTable)+}++instance Gtk.GObjectClass OptionsAccountWidget where+    toGObject = Gtk.toGObject . optionsAccountRoot+    unsafeCastGObject = undefined++instance Gtk.WidgetClass OptionsAccountWidget++optionsAccountNew :: MainState -> IO OptionsAccountWidget+optionsAccountNew mainState = do+    let buttonCss =+            [ "* {"+            , "    transition: 200ms ease-in-out;"+            , "}"+            , "button {"+            , "    border-width: 1px;"+            , "    padding: 5px;"+            , "}"+            , "button:hover {"+            , "    border-color: rgba(40, 40, 40, 0.5);"+            , "}"+            ]++    (treeView, store) <- optionsAccountTableNew++    (getObject, root) <- uiBuildGtk $ do+        vbox Nothing False 0 $ do+            pack Gtk.PackNatural 4 $ hbox Nothing False 4 $ do+                label Nothing (__"Name")+                pack Gtk.PackGrow 0 $ entry (Just "entryName") ""+                hbox Nothing True 0 $ do+                    packing Gtk.PackGrow 0+                    buttonAttrs [ Gtk.buttonImagePosition := Gtk.PosTop, Gtk.buttonRelief := Gtk.ReliefNone, cssStyle := buttonCss ]+                    buttonFromStock (Just "buttonAdd") Gtk.stockAdd+                    buttonAttrs [ Gtk.buttonImagePosition := Gtk.PosTop, Gtk.buttonRelief := Gtk.ReliefNone, cssStyle := buttonCss ]+                    buttonFromStock (Just "buttonUpdate") Gtk.stockRefresh+                    buttonAttrs [ Gtk.buttonImagePosition := Gtk.PosTop, Gtk.buttonRelief := Gtk.ReliefNone, cssStyle := buttonCss ]+                    buttonFromStock (Just "buttonRemove") Gtk.stockRemove+            hbox Nothing False 4 $ do+                pack Gtk.PackNatural 0 $ vbox Nothing False 4 $ do+                    buttonAttrs [ Gtk.buttonImagePosition := Gtk.PosTop ]+                    buttonFromStock (Just "buttonUp") Gtk.stockGoUp+                    buttonAttrs [ Gtk.buttonImagePosition := Gtk.PosTop ]+                    buttonFromStock (Just "buttonDown") Gtk.stockGoDown+                    pack Gtk.PackGrow 0 $ label Nothing ""+                scrolledWindow (Just "scrolledWindow") $+                    putWidget treeView++    let nameEntry    = Gtk.castToEntry . fromJust $ getObject "entryName"+    let buttonAdd    = Gtk.castToButton . fromJust $ getObject "buttonAdd"+    let buttonRemove = Gtk.castToButton . fromJust $ getObject "buttonRemove"+    let buttonUpdate = Gtk.castToButton . fromJust $ getObject "buttonUpdate"+    let buttonUp   = Gtk.castToButton . fromJust $ getObject "buttonUp"+    let buttonDown = Gtk.castToButton . fromJust $ getObject "buttonDown"++    forM_ [buttonAdd, buttonUpdate, buttonRemove, buttonUp, buttonDown] $ flip Gtk.widgetSetSensitive False++    observableRegister (mainStateSelectedAccountName mainState) $ \_ -> do+        Gtk.widgetSetSensitive buttonAdd False+        Gtk.widgetSetSensitive buttonUpdate False+        Gtk.widgetSetSensitive buttonRemove False+        Gtk.widgetSetSensitive buttonUp False+        Gtk.widgetSetSensitive buttonDown False+        Gtk.entrySetText nameEntry ""+        selection <- Gtk.treeViewGetSelection treeView+        Gtk.treeSelectionUnselectAll selection++    void $ Gtk.on treeView Gtk.cursorChanged $ do+        (index, Entity accountID account) <- optionsAccountGetCursor treeView store+        listSize <- Gtk.listStoreGetSize store+        let accountName = accountsTableName account+        Gtk.entrySetText nameEntry accountName+        Gtk.widgetSetSensitive buttonAdd False+        Gtk.widgetSetSensitive buttonUpdate False+        if or [ accountName == mainStateIncomeName mainState+              , accountName == mainStateOutcomeName mainState+              , accountName == mainStateCashName mainState ]+            then Gtk.widgetSetSensitive buttonRemove False+            else do+                op <- runDB $ selectFirst ([ OperationsTableFrom ==. accountID ] ||. [ OperationsTableTo ==. accountID ]) []+                case op of+                    Just _  -> Gtk.widgetSetSensitive buttonRemove False+                    Nothing -> Gtk.widgetSetSensitive buttonRemove True+        if | index > 2 && index < listSize - 1 -> do+                Gtk.widgetSetSensitive buttonUp True+                Gtk.widgetSetSensitive buttonDown True+           | index == 2 && listSize /= 3 -> do+                Gtk.widgetSetSensitive buttonUp False+                Gtk.widgetSetSensitive buttonDown True+           | index == listSize - 1 && listSize /= 3 -> do+                Gtk.widgetSetSensitive buttonUp True+                Gtk.widgetSetSensitive buttonDown False+           | otherwise -> do+                Gtk.widgetSetSensitive buttonUp False+                Gtk.widgetSetSensitive buttonDown False++    void $ Gtk.on buttonUp Gtk.buttonActivated $ do+        (index, entity) <- optionsAccountGetCursor treeView store+        Gtk.listStoreRemove store index+        Gtk.listStoreInsert store (index - 1) entity+        Gtk.treeViewSetCursor treeView [index - 1] Nothing+        optionsAccountUpdate mainState store++    void $ Gtk.on buttonDown Gtk.buttonActivated $ do+        (index, entity) <- optionsAccountGetCursor treeView store+        Gtk.listStoreRemove store index+        Gtk.listStoreInsert store (index + 1) entity+        Gtk.treeViewSetCursor treeView [index + 1] Nothing+        optionsAccountUpdate mainState store++    void $ Gtk.on nameEntry Gtk.keyReleaseEvent $ do+        liftIO $ do+            name <- strip <$> Gtk.entryGetText nameEntry+            if null name+                then do+                    Gtk.widgetSetSensitive buttonAdd False+                    Gtk.widgetSetSensitive buttonUpdate False+                else do+                    list <- Gtk.listStoreToList store+                    let filtered = filter (\(Entity _ account) -> name == accountsTableName account) list+                    if null filtered+                        then do+                            Gtk.widgetSetSensitive buttonAdd True+                            (is, _) <- Gtk.treeViewGetCursor treeView+                            case is of+                                [index] -> do+                                    (Entity _ account) <- Gtk.listStoreGetValue store index+                                    if or [ accountsTableName account == mainStateIncomeName mainState+                                          , accountsTableName account == mainStateOutcomeName mainState+                                          , accountsTableName account == mainStateCashName mainState ]+                                        then Gtk.widgetSetSensitive buttonUpdate False+                                        else Gtk.widgetSetSensitive buttonUpdate True+                                _       ->+                                    Gtk.widgetSetSensitive buttonUpdate False+                        else do+                            Gtk.widgetSetSensitive buttonAdd False+                            Gtk.widgetSetSensitive buttonUpdate False+        return True++    void $ Gtk.on buttonAdd Gtk.buttonActivated $ do+        name <- strip <$> Gtk.entryGetText nameEntry+        void $ runDB $ do+            let accountTable = AccountsTable name 0+            accountID <- insert accountTable+            liftIO $ Gtk.listStoreAppend store $ Entity accountID accountTable+        Gtk.entrySetText nameEntry ""+        Gtk.widgetSetSensitive buttonAdd False+        Gtk.widgetSetSensitive buttonUpdate False+        optionsAccountUpdate mainState store++    void $ Gtk.on buttonRemove Gtk.buttonActivated $ do+        (index, (Entity accountID account)) <- optionsAccountGetCursor treeView store+        messageBoxNew Gtk.MessageQuestion+                      Gtk.ButtonsYesNo+                      (__"Do you want to remove" ++ " \'" ++ accountsTableName account ++ "\' " ++  __"account ?") $+                      \case+                          Gtk.ResponseYes -> do+                              Gtk.listStoreRemove store index+                              runDB $ delete accountID+                              optionsAccountUpdate mainState store++                          _               -> return ()++    _ <- Gtk.on buttonUpdate Gtk.buttonActivated $ do+        (index, (Entity accountID account)) <- optionsAccountGetCursor treeView store+        messageBoxNew Gtk.MessageQuestion+                      Gtk.ButtonsYesNo+                      (__ "Do you want to update" ++ " \'" ++ accountsTableName account ++ "\' " ++ __"account name ?") $+                      \case+                          Gtk.ResponseYes -> do+                              name <- strip <$> Gtk.entryGetText nameEntry+                              runDB $ do+                                  update accountID [AccountsTableName =. name]+                                  Just updatedAccount <- get accountID+                                  liftIO $ Gtk.listStoreSetValue store index (Entity accountID updatedAccount)+                              Gtk.widgetSetSensitive buttonAdd False+                              Gtk.widgetSetSensitive buttonUpdate False+                              optionsAccountUpdate mainState store++                          _               -> return ()++    observableRegister (mainStateAccountsUpdated mainState) $ \entities -> do+        listSize <- Gtk.listStoreGetSize store+        when (listSize - 2 /= length entities) $ do+            Gtk.listStoreClear store+            (Just incomeEntity) <- runDB $ selectFirst [ AccountsTableId ==. mainStateIncomeID mainState ] []+            (Just outcomeEntity) <- runDB $ selectFirst [ AccountsTableId ==. mainStateOutcomeID mainState ] []+            forM_ [incomeEntity, outcomeEntity] $ Gtk.listStoreAppend store+            forM_ entities $ Gtk.listStoreAppend store++    Gtk.widgetShowAll root+    return $ OptionsAccountWidget (Gtk.castToVBox root) store+  where+    optionsAccountGetCursor treeView store = do+            ([index], _) <- Gtk.treeViewGetCursor treeView+            entity <- Gtk.listStoreGetValue store index+            return (index, entity)++optionsAccountToIDList :: OptionsAccountWidget -> IO [AccountsTableId]+optionsAccountToIDList accountWidget = do+    list <- Gtk.listStoreToList $ optionsAccountStore accountWidget+    forM (drop 2 list) $ \(Entity accountID _) -> return accountID++optionsAccountUpdate :: MainState -> Gtk.ListStore (Entity AccountsTable) -> IO ()+optionsAccountUpdate mainState store = do+    list <- Gtk.listStoreToList store+    observableSet (mainStateAccountsUpdated mainState) $ drop 2 list++optionsAccountTableNew :: IO (Gtk.TreeView, Gtk.ListStore (Entity AccountsTable))+optionsAccountTableNew = do+    treeView <- Gtk.treeViewNew+    store <- Gtk.listStoreNew []+    Gtk.treeViewSetModel treeView store++    column1 <- tableTextColumnNew (__ "Name") store $ \(Entity _ account) -> [ Gtk.cellText := accountsTableName account ]++    Gtk.treeViewSetHeadersVisible treeView False+    _ <- Gtk.treeViewAppendColumn treeView column1++    Gtk.widgetShowAll treeView+    return (treeView, store)
+ src/Coin/UI/Options/OptionsTag.hs view
@@ -0,0 +1,219 @@+{-+ *  Programmer:	Piotr Borek+ *  E-mail:     piotrborek@op.pl+ *  Copyright 2015 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.Options.OptionsTag (+    OptionsTagWidget,+    optionsTagNew+) where++import qualified System.Glib.Types as Gtk+import qualified Graphics.UI.Gtk as Gtk+import Graphics.UI.Gtk ( AttrOp(..) )++import Data.Maybe+import Control.Monad+import Control.Monad.IO.Class+import Database.Persist++import Coin.DB.Tables+import Coin.DB.Functions+import Coin.Utils.I18N+import Coin.Utils.StringUtils+import Coin.UI.Widgets.MessageBox+import Coin.Utils.TableView+import Coin.UI.Builder.GtkUIBuilder+import Coin.UI.Utils.CssUtils+import Coin.UI.MainState++data OptionsTagWidget = OptionsTagWidget {+    widgetContainer :: Gtk.VBox+}++instance Gtk.GObjectClass OptionsTagWidget where+    toGObject = Gtk.toGObject . widgetContainer+    unsafeCastGObject = undefined++instance Gtk.WidgetClass OptionsTagWidget++optionsTagNew :: MainState -> IO OptionsTagWidget+optionsTagNew mainState = do+    let buttonCss =+            [ "* {"+            , "    transition: 200ms ease-in-out;"+            , "}"+            , "button {"+            , "    border-width: 1px;"+            , "    padding: 5px;"+            , "}"+            , "button:hover {"+            , "    border-color: rgba(40, 40, 40, 0.5);"+            , "}"+            ]++    (treeView, store) <- optionsTagTableNew++    (getObject, root) <- uiBuildGtk $ do+        vbox Nothing False 0 $ do+            pack Gtk.PackNatural 4 $ hbox Nothing False 4 $ do+                label Nothing (__"Name")+                pack Gtk.PackGrow 0 $ entry (Just "entryName") ""+                hbox Nothing True 0 $ do+                    packing Gtk.PackGrow 0+                    buttonAttrs [ Gtk.buttonImagePosition := Gtk.PosTop, Gtk.buttonRelief := Gtk.ReliefNone, cssStyle := buttonCss ]+                    buttonFromStock (Just "buttonAdd") Gtk.stockAdd+                    buttonAttrs [ Gtk.buttonImagePosition := Gtk.PosTop, Gtk.buttonRelief := Gtk.ReliefNone, cssStyle:= buttonCss ]+                    buttonFromStock (Just "buttonUpdate") Gtk.stockRefresh+                    buttonAttrs [ Gtk.buttonImagePosition := Gtk.PosTop, Gtk.buttonRelief := Gtk.ReliefNone, cssStyle := buttonCss ]+                    buttonFromStock (Just "buttonRemove") Gtk.stockRemove+            scrolledWindow Nothing $+                putWidget treeView++    let nameEntry    = Gtk.castToEntry . fromJust $ getObject "entryName"+    let buttonAdd    = Gtk.castToButton . fromJust $ getObject "buttonAdd"+    let buttonUpdate = Gtk.castToButton . fromJust $ getObject "buttonUpdate"+    let buttonRemove = Gtk.castToButton . fromJust $ getObject "buttonRemove"++    forM_ [buttonAdd, buttonUpdate, buttonRemove] $ flip Gtk.widgetSetSensitive False++    observableRegister (mainStateSelectedAccountName mainState) $ \_ -> do+        Gtk.widgetSetSensitive buttonAdd False+        Gtk.widgetSetSensitive buttonUpdate False+        Gtk.widgetSetSensitive buttonRemove False+        Gtk.entrySetText nameEntry ""+        selection <- Gtk.treeViewGetSelection treeView+        Gtk.treeSelectionUnselectAll selection++    void $ Gtk.on treeView Gtk.cursorChanged $ do+        (_, (Entity tagID tag)) <- optionsTagGetCursor treeView store+        let tagName = tagsTableName tag+        Gtk.entrySetText nameEntry tagName+        Gtk.widgetSetSensitive buttonAdd False+        Gtk.widgetSetSensitive buttonUpdate False+        if tagName == mainStateNoneName mainState+            then Gtk.widgetSetSensitive buttonRemove False+            else do+                op <- runDB $ selectFirst [ OperationsTableTag ==. tagID ] []+                case op of+                    Just _  -> Gtk.widgetSetSensitive buttonRemove False+                    Nothing -> Gtk.widgetSetSensitive buttonRemove True++    void $ Gtk.on nameEntry Gtk.keyReleaseEvent $ do+        liftIO $ do+            name <- strip <$> Gtk.entryGetText nameEntry+            if name == []+                then do+                    Gtk.widgetSetSensitive buttonAdd False+                    Gtk.widgetSetSensitive buttonUpdate False+                else do+                    list <- Gtk.listStoreToList store+                    let filtered = filter (\(Entity _ tag) -> name == tagsTableName tag) list+                    if length filtered == 0+                        then do+                            Gtk.widgetSetSensitive buttonAdd True+                            (is, _) <- Gtk.treeViewGetCursor treeView+                            case is of+                                [index] -> do+                                    (Entity _ tag) <- Gtk.listStoreGetValue store index+                                    if tagsTableName tag == mainStateNoneName mainState+                                        then Gtk.widgetSetSensitive buttonUpdate False+                                        else Gtk.widgetSetSensitive buttonUpdate True+                                _       ->+                                    Gtk.widgetSetSensitive buttonUpdate False+                        else do+                            Gtk.widgetSetSensitive buttonAdd False+                            Gtk.widgetSetSensitive buttonUpdate False+        return True++    void $ Gtk.on buttonAdd Gtk.buttonActivated $ do+        name <- strip <$> Gtk.entryGetText nameEntry+        void $ runDB $ do+            tagID <- insert $ TagsTable name+            liftIO $ Gtk.listStoreAppend store $ Entity tagID (TagsTable name)+        Gtk.entrySetText nameEntry ""+        Gtk.widgetSetSensitive buttonAdd False+        Gtk.widgetSetSensitive buttonUpdate False+        optionsTagUpdate mainState store++    void $ Gtk.on buttonUpdate Gtk.buttonActivated $ do+        (index, Entity tagID tag) <- optionsTagGetCursor treeView store+        messageBoxNew Gtk.MessageQuestion+                      Gtk.ButtonsYesNo+                      ((__"Do you want to update") ++ " \'" ++ tagsTableName tag ++ "\' " ++ (__"tag name ?")) $+                      \case+                          Gtk.ResponseYes -> do+                              name <- strip <$> Gtk.entryGetText nameEntry+                              runDB $ do+                                  update tagID [TagsTableName =. name]+                                  Just updatedTag <- get tagID+                                  liftIO $ Gtk.listStoreSetValue store index (Entity tagID updatedTag)+                              Gtk.widgetSetSensitive buttonAdd False+                              Gtk.widgetSetSensitive buttonUpdate False+                              optionsTagUpdate mainState store++                          _               -> return ()++    void $ Gtk.on buttonRemove Gtk.buttonActivated $ do+        (index, Entity tagID tag) <- optionsTagGetCursor treeView store+        messageBoxNew Gtk.MessageQuestion+                      Gtk.ButtonsYesNo+                      ((__"Do you want to remove") ++ " \'" ++ tagsTableName tag ++ "\' " ++ (__"tag ?")) $+                      \case+                          Gtk.ResponseYes -> do+                              Gtk.listStoreRemove store index+                              runDB $ delete tagID+                              optionsTagUpdate mainState store++                          _               -> return ()++    observableRegister (mainStateTagsUpdated mainState) $ \entities -> do+        listSize <- Gtk.listStoreGetSize store+        when (listSize /= length entities) $ do+            Gtk.listStoreClear store+            forM_ entities $ Gtk.listStoreAppend store++    Gtk.widgetShowAll root+    return $ OptionsTagWidget $ Gtk.castToVBox root+  where+    optionsTagGetCursor treeView store = do+        ([index], _) <- Gtk.treeViewGetCursor treeView+        entity <- Gtk.listStoreGetValue store index+        return (index, entity)+++optionsTagUpdate :: MainState -> Gtk.ListStore (Entity TagsTable) -> IO ()+optionsTagUpdate mainState store = do+    list <- Gtk.listStoreToList store+    observableSet (mainStateTagsUpdated mainState) list++optionsTagTableNew :: IO (Gtk.TreeView, Gtk.ListStore (Entity TagsTable))+optionsTagTableNew = do+    treeView <- Gtk.treeViewNew+    store <- Gtk.listStoreNew []+    Gtk.treeViewSetModel treeView store++    column1 <- tableTextColumnNew (__ "Name") store $ \(Entity _ tag) -> [ Gtk.cellText := tagsTableName tag ]++    Gtk.treeViewSetHeadersVisible treeView False+    _ <- Gtk.treeViewAppendColumn treeView column1++    Gtk.widgetShowAll treeView+    return (treeView, store)
+ src/Coin/UI/Raports/RaportHistory.hs view
@@ -0,0 +1,217 @@+{-+ *  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+ *+-}++module Coin.UI.Raports.RaportHistory (+    RaportHistoryWidget,+    castToRaportHistory,+    raportHistoryNew,+    raportHistoryUpdate,+    raportHistoryUpdate'+) where++import qualified System.Glib.GObject as Gtk+import qualified Graphics.UI.Gtk as Gtk+import Graphics.UI.Gtk ( AttrOp(..) )++import qualified Data.Text as T++import Control.Monad+import Control.Monad.IO.Class+import Data.Maybe+import Data.Foldable+import Database.Persist++import Coin.DB.Tables+import Coin.DB.Functions+import Coin.Utils.I18N+import Coin.Utils.ValueParser+import Coin.UI.MainState+import Coin.UI.Builder.GtkUIBuilder+import Coin.UI.Widgets.MiniCalendar+import Coin.UI.Utils.CalendarUtils+import Coin.UI.HistoryView+import Coin.UI.AccountsComboBox++data RaportHistoryWidget = RaportHistoryWidget {+    raportHistoryRoot         :: Gtk.Widget,+    raportHistoryAccountsBox  :: Gtk.ComboBox,+    raportHistoryView         :: HistoryViewWidget,+    raportHistoryMiniCalendar :: MiniCalendarWidget,+    raportHistoryBalance      :: Gtk.Label,+    raportHistoryIncomes      :: Gtk.Label,+    raportHistoryOutcomes     :: Gtk.Label+}++instance Gtk.GObjectClass RaportHistoryWidget where+    toGObject = Gtk.toGObject . raportHistoryRoot+    unsafeCastGObject = undefined++instance Gtk.WidgetClass RaportHistoryWidget++castToRaportHistory :: Gtk.WidgetClass cls => cls -> IO RaportHistoryWidget+castToRaportHistory widget = do+    q <- Gtk.quarkFromString "Coin.UI.Raports.RaportHistory"+    (Just h) <- Gtk.objectGetAttributeUnsafe q widget+    return h++raportHistoryNew :: MainState -> IO RaportHistoryWidget+raportHistoryNew mainState = do+    accountsBox <- accountsComboBoxNew mainState+    historyView <- historyViewNew True True True+    miniCalendar <- miniCalendarNew++    (getObject, root) <- uiBuildGtk $ do+        globalCss [ "#Marked {"+                  , "    font-weight: bold;"+                  , "}"+                  ]+        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 miniCalendar++            gridAttach 0 1 1 1 $ do+                labelAttrs [ Gtk.miscXalign := 1.0, Gtk.widgetName := Just "Marked" ]+                label Nothing (__"Account name:")+            gridAttach 1 1 1 1 $ putWidget accountsBox++            gridAttach 0 2 1 1 $ do+                labelAttrs [ Gtk.miscXalign := 1.0, Gtk.widgetName := Just "Marked" ]+                label Nothing (__"Current balance:")+            gridAttach 1 2 1 1 $ do+                labelAttrs [ Gtk.miscXalign := 0.0 ]+                label (Just "balance") "0.00"++            gridAttach 0 3 1 1 $ do+                labelAttrs [ Gtk.miscXalign := 1.0, Gtk.widgetName := Just "Marked" ]+                label Nothing (__"Incomes:")+            gridAttach 1 3 1 1 $ do+                labelAttrs [ Gtk.miscXalign := 0.0 ]+                label (Just "incomes") "0.00"++            gridAttach 0 4 1 1 $ do+                labelAttrs [ Gtk.miscXalign := 1.0, Gtk.widgetName := Just "Marked" ]+                label Nothing (__"Outcomes:")+            gridAttach 1 4 1 1 $ do+                labelAttrs [ Gtk.miscXalign := 0.0 ]+                label (Just "outcomes") "0.00"++            gridAttach 0 5 2 1 $ do+                widgetAttrs [ Gtk.widgetVExpand := True, Gtk.widgetHExpand := True ]+                scrolledWindow Nothing $ putWidget historyView++    let balance  = Gtk.castToLabel . fromJust . getObject $ "balance"+    let incomes  = Gtk.castToLabel . fromJust . getObject $ "incomes"+    let outcomes = Gtk.castToLabel . fromJust . getObject $ "outcomes"++    let historyWidget = RaportHistoryWidget+                            root+                            accountsBox+                            historyView+                            miniCalendar+                            balance+                            incomes+                            outcomes++    q <- Gtk.quarkFromString "Coin.UI.Raports.RaportHistory"+    Gtk.objectSetAttribute q root $ Just historyWidget++    void $ Gtk.on accountsBox Gtk.changed $ raportHistoryUpdate mainState historyWidget++    miniCalendarOnChange miniCalendar $ \_ _ ->+        raportHistoryUpdate mainState historyWidget++    raportHistoryUpdate mainState historyWidget++    mainStateSavePropertiesAction mainState "Coin.UI.Raports.RaportHistory" $ do+        i <- liftIO $ Gtk.comboBoxGetActive accountsBox+        propertyInsert "i" i++    mainStateReadPropertiesAction mainState "Coin.UI.Raports.RaportHistory" $ do+        propertyRead "i" $ \i ->+            liftIO $ Gtk.comboBoxSetActive accountsBox i++    return historyWidget++raportHistoryUpdate' :: Gtk.WidgetClass cls => MainState -> cls -> IO ()+raportHistoryUpdate' mainState widget = castToRaportHistory widget >>= raportHistoryUpdate mainState++raportHistoryUpdate :: MainState -> RaportHistoryWidget -> IO ()+raportHistoryUpdate mainState historyWidget = do+    raportHistoryViewUpdate historyWidget mainState+    raportHistoryBalanceUpdate historyWidget++raportHistoryBalanceUpdate :: RaportHistoryWidget -> IO ()+raportHistoryBalanceUpdate historyWidget = do+    name <- Gtk.comboBoxGetActiveText (raportHistoryAccountsBox historyWidget)+    when (isJust name) $ do+        accountID <- accountsTableSelectID $ T.unpack $ fromJust name+        val <- accountsTableSelectBalance accountID+        Gtk.labelSetText (raportHistoryBalance historyWidget) $ valueShow val++raportHistoryViewUpdate :: RaportHistoryWidget -> MainState -> IO ()+raportHistoryViewUpdate historyWidget mainState = do+    name <- Gtk.comboBoxGetActiveText (raportHistoryAccountsBox historyWidget)+    when (isJust name) $ do+        entities <- raportHistorySelect (raportHistoryMiniCalendar historyWidget) $ T.unpack $ fromJust name+        historyViewUpdate mainState (raportHistoryView historyWidget) entities++        let incomeID = mainStateIncomeID mainState+        let outcomeID = mainStateOutcomeID mainState+        let inSum  = foldr' (\(Entity _ op) s ->+                                 if operationsTableFrom op == incomeID+                                 then s + operationsTableValue op+                                 else s )+                            0+                            entities+        let outSum = foldr' (\(Entity _ op) s ->+                                 if operationsTableTo op == outcomeID+                                 then s + operationsTableValue op+                                 else s )+                            0+                            entities++        Gtk.labelSetText (raportHistoryIncomes historyWidget) $ valueShow inSum+        Gtk.labelSetText (raportHistoryOutcomes historyWidget) $ valueShow outSum++raportHistorySelect :: MiniCalendarWidget -> String -> IO [Entity OperationsTable]+raportHistorySelect cal accountName =+    if (accountName == [])+        then return []+        else do+            accountID <- accountsTableSelectID accountName+            (year, month) <- miniCalendarGetDate cal+            runDB $+                selectList (   [ OperationsTableFrom ==. accountID+                               , OperationsTableDate >=. calendarDateToInt (year, month, 1)+                               , OperationsTableDate <=. calendarDateToInt (year, month, 31)+                               ]+                           ||. [ OperationsTableTo ==. accountID+                               , OperationsTableDate >=. calendarDateToInt (year, month, 1)+                               , OperationsTableDate <=. calendarDateToInt (year, month, 31)+                               ]+                           )+                           [ Desc OperationsTableDate ]
+ src/Coin/UI/Raports/RaportQuery.hs view
@@ -0,0 +1,295 @@+{-+ *  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.Utils.I18N+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++    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)
+ src/Coin/UI/Raports/RaportSummary.hs view
@@ -0,0 +1,112 @@+{-+ *  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+ *+-}++module Coin.UI.Raports.RaportSummary (+    RaportSummaryWidget,+    castToRaportSummary,+    raportSummaryNew,+    raportSummaryUpdate,+    raportSummaryUpdate'+) where++import qualified System.Glib.GObject as Gtk+import qualified Graphics.UI.Gtk as Gtk+import Graphics.UI.Gtk ( AttrOp(..) )++import Control.Monad+import Data.Foldable+import Data.Int+import Database.Persist++import Coin.DB.Tables+import Coin.DB.Functions+import Coin.UI.MainState+import Coin.Utils.I18N+import Coin.Utils.TableView+import Coin.Utils.ValueParser++type SummaryData = (String, String)++data RaportSummaryWidget = RaportSummaryWidget {+    raportSummaryRoot  :: Gtk.TreeView,+    raportSummaryStore :: Gtk.ListStore SummaryData+}++instance Gtk.GObjectClass RaportSummaryWidget where+    toGObject = Gtk.toGObject . raportSummaryRoot+    unsafeCastGObject = undefined++instance Gtk.WidgetClass RaportSummaryWidget++castToRaportSummary :: Gtk.WidgetClass cls => cls -> IO RaportSummaryWidget+castToRaportSummary widget = do+    q <- Gtk.quarkFromString "Coin.UI.Raports.RaportSummary"+    (Just h) <- Gtk.objectGetAttributeUnsafe q widget+    return h++raportSummaryNew :: MainState -> IO RaportSummaryWidget+raportSummaryNew mainState = do+    store <- Gtk.listStoreNew []+    treeView <- Gtk.treeViewNewWithModel store++    col1 <- tableTextColumnNew (__"Account name")    store $ \(x, _) -> [ Gtk.cellText := x ]+    col2 <- tableTextColumnNew (__"Current balance") store $ \(_, x) -> [ Gtk.cellText := x ]++    forM_ [col1, col2] $ Gtk.treeViewAppendColumn treeView+    Gtk.treeViewSetHeadersVisible treeView True++    let raportSummary = RaportSummaryWidget treeView store+    raportSummaryUpdate mainState raportSummary++    q <- Gtk.quarkFromString "Coin.UI.Raports.RaportSummary"+    Gtk.objectSetAttribute q treeView $ Just raportSummary++    return raportSummary++raportSummaryUpdate' :: Gtk.WidgetClass cls => MainState -> cls -> IO ()+raportSummaryUpdate' mainState widget = castToRaportSummary widget >>= raportSummaryUpdate mainState++raportSummaryUpdate :: MainState -> RaportSummaryWidget -> IO ()+raportSummaryUpdate mainState raportSummary = do+    let store = raportSummaryStore raportSummary+    (list, s) <- raportSummarySelect mainState++    Gtk.listStoreClear store+    forM_ list $ Gtk.listStoreAppend store++    void $ Gtk.listStoreAppend store ("--------", "")+    void $ Gtk.listStoreAppend store (__"Sum", valueShow s)++raportSummarySelect :: MainState -> IO ([SummaryData], Int64)+raportSummarySelect mainState = do+    let incomeID = mainStateIncomeID mainState+    let outcomeID = mainStateOutcomeID mainState++    entities <- runDB $+        selectList [ AccountsTableId !=. incomeID, AccountsTableId !=. outcomeID] []++    let s = foldr' (\(Entity _ account) x -> x + accountsTableBalance account ) 0 entities++    let list = flip map entities $ \(Entity _ account) ->+                   (accountsTableName account, valueShow $ accountsTableBalance account)++    return (list, s)
+ src/Coin/UI/TagsComboBox.hs view
@@ -0,0 +1,64 @@+{-+ *  Programmer:	Piotr Borek+ *  E-mail:     piotrborek@op.pl+ *  Copyright 2015 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.TagsComboBox (+    tagsComboBoxNew,+    tagsComboBoxSelect+) where++import qualified Graphics.UI.Gtk as Gtk+import Graphics.UI.Gtk ( AttrOp(..) )++import qualified Data.Text as T+import Control.Monad++import Database.Persist+import Data.List+import Coin.DB.Tables+import Coin.DB.Functions+import Coin.UI.Utils.Observable+import Coin.UI.MainState++tagsComboBoxNew :: MainState -> IO Gtk.ComboBox+tagsComboBoxNew mainState = do+    c <- Gtk.comboBoxNewWithEntry+    void $ Gtk.comboBoxSetModelText c+    (Just entry) <- Gtk.binGetChild c+    Gtk.set (Gtk.castToEntry entry) [Gtk.entryEditable := False]++    observableRegister (mainStateTagsUpdated mainState) $ tagsComboBoxUpdate' c++    Gtk.widgetSetSizeRequest c 240 28+    return c++tagsComboBoxSelect :: IO [Entity TagsTable]+tagsComboBoxSelect = runDB $ selectList [] []++tagsComboBoxUpdate' :: Gtk.ComboBox -> [Entity TagsTable] -> IO ()+tagsComboBoxUpdate' combo entities = do+    boxModel <- Gtk.comboBoxGetModelText combo++    let tagsList = sort $ flip map entities $ \(Entity _ tag) -> T.pack (tagsTableName tag)++    Gtk.listStoreClear boxModel+    forM_ tagsList $ Gtk.listStoreAppend boxModel+    Gtk.comboBoxSetActive combo 0
+ src/Coin/UI/Utils/CalendarUtils.hs view
@@ -0,0 +1,152 @@+{-+ *  Programmer:	Piotr Borek+ *  E-mail:     piotrborek@op.pl+ *  Copyright 2015 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.Utils.CalendarUtils (+    Days (..),+    Months (..),+    succ',+    pred',+    intToDay,+    intToMonth,+    calendarGetDate,+    calendarGetInfo,+    calendarDateToInt,+    calendarIntToDate,+    calendarShow+) where++import Data.Bits+import Data.Time+import Data.Time.Calendar.WeekDate++import Coin.Utils.I18N++data Days = Monday+          | Tuesday+          | Wednesday+          | Thursday+          | Friday+          | Saturday+          | Sunday+          deriving (Eq, Ord, Enum, Bounded)++data Months = January+            | February+            | March+            | April+            | May+            | June+            | July+            | August+            | September+            | October+            | November+            | December+            deriving (Eq, Ord, Enum, Bounded)++instance Show Days where+    show Monday    = __"Mo"+    show Tuesday   = __"Tu"+    show Wednesday = __"We"+    show Thursday  = __"Th"+    show Friday    = __"Fr"+    show Saturday  = __"Sa"+    show Sunday    = __"Su"++instance Show Months where+    show January   = __"January"+    show February  = __"February"+    show March     = __"March"+    show April     = __"April"+    show May       = __"May"+    show June      = __"June"+    show July      = __"July"+    show August    = __"August"+    show September = __"September"+    show October   = __"October"+    show November  = __"November"+    show December  = __"December"++succ' :: (Eq a, Enum a, Bounded a) => a -> a+succ' x+    | x == maxBound = minBound+    | otherwise     = succ x++pred' :: (Eq a, Enum a, Bounded a) => a -> a+pred' x+    | x == minBound = maxBound+    | otherwise     = pred x++intToDay :: Int -> Days+intToDay x+    | x == 0    = Monday+    | x == 1    = Tuesday+    | x == 2    = Wednesday+    | x == 3    = Thursday+    | x == 4    = Friday+    | x == 5    = Saturday+    | x == 6    = Sunday+    | otherwise = undefined++intToMonth :: Int -> Months+intToMonth x+    | x ==  1   = January+    | x ==  2   = February+    | x ==  3   = March+    | x ==  4   = April+    | x ==  5   = May+    | x ==  6   = June+    | x ==  7   = July+    | x ==  8   = August+    | x ==  9   = September+    | x == 10   = October+    | x == 11   = November+    | x == 12   = December+    | otherwise = undefined++calendarGetDate :: IO (Integer, Int, Int, Int, Int)+calendarGetDate = do+    c <- getCurrentTime+    let (year, month, day) = toGregorian $ utctDay c+    let numberOfDays = gregorianMonthLength year month+    let (_, _, firstDay) = toWeekDate $ fromGregorian year month 1+    return (year, month, day, numberOfDays, firstDay)++calendarGetInfo :: Integer -> Int -> IO (Int, Int)+calendarGetInfo year month = do+    let numberOfDays = gregorianMonthLength year month+    let (_, _, firstDay) = toWeekDate $ fromGregorian year month 1+    return (firstDay, numberOfDays)++calendarDateToInt :: (Integer, Int, Int) -> Int+calendarDateToInt (year, month, day) = (day .&. 0x1F) + (shiftL (month .&. 0xF) 5) + (shiftL (fromInteger year) 9)++calendarIntToDate :: Int -> (Integer, Int, Int)+calendarIntToDate date = (toInteger $ shiftR date 9, (shiftR date 5) .&. 0xF, date .&. 0x1F)++calendarShow :: Int -> String+calendarShow date = let (year, month, day) = calendarIntToDate date+                    in show year ++ "-" ++ show' month ++ "-" ++ show' day+  where+    show' x | length (show x) == 0 = "00"+            | length (show x) == 1 = "0" ++ show x+            | otherwise            = show x
+ src/Coin/UI/Utils/CssUtils.hs view
@@ -0,0 +1,143 @@+{-+ *  Programmer:	Piotr Borek+ *  E-mail:     piotrborek@op.pl+ *  Copyright 2015 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.Utils.CssUtils (+    gtkStyleProviderPriorityTheme,+    gtkStyleProviderPrioritySetting,+    gtkStyleProviderPriorityApplication,+    gtkStyleProviderPriorityUser,+    cssUtilsAddProvider,+    cssUtilsProviderNew,+    cssStyle,+    cssStyleReset+) where++import Graphics.UI.Gtk+import Graphics.UI.Gtk.General.CssProvider+import Graphics.UI.Gtk.General.StyleContext++import Control.Exception++gtkStyleProviderPriorityTheme :: Int+gtkStyleProviderPriorityTheme = 200++gtkStyleProviderPrioritySetting :: Int+gtkStyleProviderPrioritySetting = 400++gtkStyleProviderPriorityApplication :: Int+gtkStyleProviderPriorityApplication = 600++gtkStyleProviderPriorityUser :: Int+gtkStyleProviderPriorityUser = 800++cssUtilsAddProvider :: WidgetClass cls => cls -> CssProvider -> Int -> IO ()+cssUtilsAddProvider widget provider priority = do+    context <- widgetGetStyleContext $ castToWidget widget+    styleContextAddProvider context provider priority++cssUtilsProviderNew :: [String] -> IO CssProvider+cssUtilsProviderNew text = do+    provider <- cssProviderNew+    catch (cssProviderLoadFromString provider $ unlines text)+          (\(SomeException e) -> do+               putStrLn "cssUtilsProviderNew Exception."+               putStrLn $ show e+               putStrLn "Text:"+               putStrLn $ unlines text+               throw e+          )+    return provider++cssStyle :: WidgetClass cls => Attr cls [String]+cssStyle = newAttr (\_ -> undefined)+                   (\w text -> do+                       cssProvider <- cssUtilsProviderNew text+                       cssUtilsAddProvider w cssProvider gtkStyleProviderPriorityApplication+                   )++cssStyleReset :: String+cssStyleReset = unlines+    {- Gtk-3.20 -}+    [ "* {"+    , "    all: unset;"+    , "}"+    ]+    {- Gtk-3.18+    [ "* {"+    , "    color: inherit;"+    , "    font-size: inherit;"+    , "    background-color: initial;"+    , "    font-family: inherit;"+    , "    font-style: inherit;"+    , "    font-variant: inherit;"+    , "    font-weight: inherit;"+    , "    text-shadow: inherit;"+    , "    icon-shadow: inherit;"+    , "    box-shadow: initial;"+    , "    margin-top: initial;"+    , "    margin-left: initial;"+    , "    margin-bottom: initial;"+    , "    margin-right: initial;"+    , "    padding-top: initial;"+    , "    padding-left: initial;"+    , "    padding-bottom: initial;"+    , "    padding-right: initial;"+    , "    border-top-style: initial;"+    , "    border-top-width: initial;"+    , "    border-left-style: initial;"+    , "    border-left-width: initial;"+    , "    border-bottom-style: initial;"+    , "    border-bottom-width: initial;"+    , "    border-right-style: initial;"+    , "    border-right-width: initial;"+    , "    border-top-left-radius: initial;"+    , "    border-top-right-radius: initial;"+    , "    border-bottom-right-radius: initial;"+    , "    border-bottom-left-radius: initial;"+    , "    outline-style: initial;"+    , "    outline-width: initial;"+    , "    outline-offset: initial;"+    , "    background-clip: initial;"+    , "    background-origin: initial;"+    , "    background-size: initial;"+    , "    background-position: initial;"+    , "    border-top-color: initial;"+    , "    border-right-color: initial;"+    , "    border-bottom-color: initial;"+    , "    border-left-color: initial;"+    , "    outline-color:  initial;"+    , "    background-repeat: initial;"+    , "    background-image: initial;"+    , "    border-image-source: initial;"+    , "    border-image-repeat: initial;"+    , "    border-image-slice: initial;"+    , "    border-image-width: initial;"+    , "    transition-property: initial;"+    , "    transition-duration: initial;"+    , "    transition-timing-function: initial;"+    , "    transition-delay: initial;"+    , "    engine: initial;"+    , "    gtk-key-bindings: initial;"+    , "    -GtkNotebook-initial-gap: 0;"+    , "}"+    ]+    -}
+ src/Coin/UI/Utils/Observable.hs view
@@ -0,0 +1,50 @@+{-+ *  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.Utils.Observable (+    Observable,+    observableNew,+    observableRegister,+    observableSet+) where++import Control.Monad+import Control.Concurrent.MVar++data Observable a = Observable {+    observableList :: MVar [a -> IO ()]+}++observableNew :: IO (Observable a)+observableNew = do+    var <- newMVar []+    return $ Observable var++observableRegister :: Observable a -> (a -> IO ()) -> IO ()+observableRegister observable action =+    modifyMVar_ (observableList observable) $ \actions ->+        return $ action : actions++observableSet :: Observable a -> a -> IO ()+observableSet observable value = do+    actions <- readMVar $ observableList observable+    forM_ actions $ \action -> action value
+ src/Coin/UI/Widgets/Calendar.hs view
@@ -0,0 +1,408 @@+{-+ *  Programmer:	Piotr Borek+ *  E-mail:     piotrborek@op.pl+ *  Copyright 2015 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.Widgets.Calendar (+    CalendarSize (..),+    CalendarWidget,+    calendarNew,+    calendarGetSelectedDate,+    calendarSelectDate,+    calendarOnChange,+) where++import qualified System.Glib.Types as Gtk+import qualified Graphics.UI.Gtk as Gtk+import Graphics.UI.Gtk ( AttrOp(..) )++import Numeric+import Control.Monad+import Data.Maybe+import Data.IORef++import Coin.UI.Builder.GtkUIBuilder+import Coin.UI.Utils.CalendarUtils+import Coin.UI.Utils.CssUtils+import Coin.UI.Utils.Observable+import Coin.Utils.I18N++data CalendarWidget = CalendarWidget {+    calendarContainer     :: Gtk.Box,+    calendarYearLabel     :: Gtk.Label,+    calendarMonthLabel    :: Gtk.Label,+    calendarButtons       :: [Gtk.Button],+    calendarYear          :: IORef Integer,+    calendarMonth         :: IORef Int,+    calendarDay           :: IORef Int,+    calendarSelectedYear  :: IORef Integer,+    calendarSelectedMonth :: IORef Int,+    calendarSelectedDay   :: IORef Int,+    calendarChange        :: Observable (Integer, Int, Int)+}++instance Gtk.GObjectClass CalendarWidget where+    toGObject = Gtk.toGObject . calendarContainer+    unsafeCastGObject = undefined++instance Gtk.WidgetClass CalendarWidget++data CalendarSize = CalendarSizeNormal+                  | CalendarSizeSmall+                  deriving Eq++calendarNew :: CalendarSize -> IO CalendarWidget+calendarNew calendarSize = do+    (year, month, day, numberOfDays, firstDay) <- calendarGetDate++    refYear  <- newIORef year+    refMonth <- newIORef month+    refDay   <- newIORef day++    selectedYear  <- newIORef year+    selectedMonth <- newIORef month+    selectedDay   <- newIORef day++    cal <- Gtk.calendarNew+    calStyle <- Gtk.widgetGetStyle cal+    bg <- colorToString <$> Gtk.styleGetBackground calStyle Gtk.StateNormal+    fg <- colorToString <$> Gtk.styleGetText calStyle Gtk.StateNormal+    sb <- colorToString <$> Gtk.styleGetLight calStyle Gtk.StateSelected++    let css = [ cssStyleReset+              , "* {"+              , "    color: " ++ fg ++ ";"+              , "}"+              , "frame {"+              , "    background-color: " ++ bg ++ ";"+              , "    border: 1px;"+              , "    border-style: solid;"+              , "    border-radius: 10px;"+              , "    padding: 10px 5px 10px 5px;"+              , "}"+              , "label {"+              , "    padding: 2px;"+              , "}"+              , "button {"+              , "    transition: 200ms ease-in-out;"+              , if calendarSize == CalendarSizeNormal then "    font-size: 1.1em;" else mempty+              , "    background-color: " ++ bg ++ ";"+              , "    border-color: " ++ bg ++ ";"+              , "    border-radius: 8px 0px 8px 0px;"+              , "    border-width: 1px;"+              , "    border-style: solid;"+              , "    padding: 2px 4px 2px 4px;"+              , "}"+              , "#TodayButton {"+              , "    transition: none;"+              , if calendarSize == CalendarSizeNormal then "    font-size: 1em;" else mempty+              , "    border-radius: 8px 0px 8px 0px;"+              , "    padding: 0px;"+              , "}"+              , "#TodayButton:active {"+              , "    background-color: " ++ sb ++ ";"+              , "}"+              , "#Arrow {"+              , "    font-weight: bold;"+              , if calendarSize == CalendarSizeNormal then "    font-size: 2em;" else mempty+              , "    padding: 0px;"+              , "    border-style: none;"+              , "    border-radius: 12px;"+              , "}"+              , "#Arrow:hover {"+              , "    background-color: " ++ sb ++ ";"+              , "}"+              , "#DayName {"+              , "    background-color: " ++ sb ++ ";"+              , "}"+              , "#Sunday {"+              , "    background-color: " ++ sb ++ ";"+              , "    font-weight: bold;"+              , if calendarSize == CalendarSizeNormal then "    font-size: 1.4em;" else mempty+              , "}"+              , "#Insensitive {"+              , "    border-color: " ++ bg ++ ";"+              , "}"+              , "#SensitiveSunday {"+              , "    font-weight: bold;"+              , if calendarSize == CalendarSizeNormal then "    font-size: 1.4em;" else mempty+              , "}"+              , "#Today {"+              , "    border-color: " ++ fg ++ ";"+              , "}"+              , "#TodaySunday {"+              , "    border-color: " ++ fg ++ ";"+              , "    font-weight: bold;"+              , if calendarSize == CalendarSizeNormal then "    font-size: 1.4em;" else mempty+              , "}"+              , "#TodaySelected {"+              , "    background-color: " ++ sb ++ ";"+              , "    border-color: " ++ fg ++ ";"+              , "}"+              , "#TodaySelectedSunday {"+              , "    background-color: " ++ sb ++ ";"+              , "    border-color: " ++ fg ++ ";"+              , "    font-weight: bold;"+              , if calendarSize == CalendarSizeNormal then "    font-size: 1.4em;" else mempty+              , "}"+              , "#Selected {"+              , "    background-color: " ++ sb ++ ";"+              , "}"+              , "#SelectedSunday {"+              , "    background-color: " ++ sb ++ ";"+              , "    font-weight: bold;"+              , if calendarSize == CalendarSizeNormal then "    font-size: 1.4em;" else mempty+              , "}"+              , "#TodayButton:hover,"+              , "#Today:hover,"+              , "#TodaySunday:hover,"+              , "#TodaySelected:hover,"+              , "#TodaySelectedSunday:hover,"+              , "#SelectedSunday:hover,"+              , "#Selected:hover,"+              , "#SensitiveSunday:hover,"+              , "#Sensitive:hover {"+              , "    border-color: " ++ sb ++ ";"+              , "}"+              ]++    (getObject, root) <- uiBuildGtk $ do+        packing Gtk.PackNatural 0+        vbox Nothing False 0 $ hbox Nothing False 0 $ do+            globalCss css+            hbox Nothing False 0 $+                frame Nothing Nothing $ do+                    gridAttrs [ gridRowHomogeneous := True, gridColumnHomogeneous := True, Gtk.containerBorderWidth := 4 ]+                    grid Nothing $ do+                        gridAttach 0 0 1 1 $ do+                            buttonAttrs [ Gtk.widgetName := Just "Arrow" ]+                            button (Just "monthLeft") "<"+                        gridAttach 1 0 4 1 $ label (Just "month") (show $ intToMonth month)+                        gridAttach 5 0 1 1 $ do+                            buttonAttrs [ Gtk.widgetName := Just "Arrow" ]+                            button (Just "monthRight") ">"+                        gridAttach 7 0 1 1 $ do+                            buttonAttrs [ Gtk.widgetName := Just "Arrow" ]+                            button (Just "yearLeft") "<"+                        gridAttach 8 0 2 1 $ label (Just "year") (show year)+                        gridAttach 10 0 1 1 $ do+                            buttonAttrs [ Gtk.widgetName := Just "Arrow" ]+                            button (Just "yearRight") ">"+                        gridAttach 11 0 3 1 $ do+                            buttonAttrs [ Gtk.widgetName := Just "TodayButton" ]+                            button (Just "today") (__"Today")++                        forM_ [0 .. 13] $ \i ->+                            gridAttach i 1 1 1 $ do+                                if i `mod` 7 == 6+                                    then labelAttrs [ Gtk.widgetName := Just "Sunday" ]+                                    else labelAttrs [ Gtk.widgetName := Just "DayName" ]+                                label Nothing (show $ intToDay $ i `mod` 7)++                        forM_ [0 .. 13] $ \i ->+                            forM_ [0 .. 2] $ \j -> do+                                let index = j * 14 + i+                                gridAttach i (j + 2) 1 1 $ button (Just $ "button#" ++ show index) ""++    let buttons = map (\i -> Gtk.castToButton . fromJust . getObject $ "button#" ++ show i) ([0 .. 41] :: [Int])+    let monthLabel = Gtk.castToLabel . fromJust . getObject $ "month"+    let yearLabel  = Gtk.castToLabel . fromJust . getObject $ "year"++    yearMonthObservable <- observableNew+    let calendarWidget = CalendarWidget+                             (Gtk.castToBox root)+                             yearLabel+                             monthLabel+                             buttons+                             refYear+                             refMonth+                             refDay+                             selectedYear+                             selectedMonth+                             selectedDay+                             yearMonthObservable++    let todayButton = Gtk.castToButton . fromJust . getObject $ "today"+    void $ Gtk.on todayButton Gtk.buttonActivated $ do+        (y, m, d, _, _) <- calendarGetDate+        calendarSetSelectedDate calendarWidget y m d+        calendarSelectYearMonthDay calendarWidget y m d+        calendarOnChangeEmit calendarWidget++    let monthLeft   = Gtk.castToButton . fromJust . getObject $ "monthLeft"+    void $ Gtk.on monthLeft Gtk.buttonActivated $ do+        (y, m, d) <- calendarGetYearMonthDay calendarWidget+        calendarSelectYearMonthDay calendarWidget y (m - 1) d++    let monthRight  = Gtk.castToButton . fromJust . getObject $ "monthRight"+    void $ Gtk.on monthRight Gtk.buttonActivated $ do+        (y, m, d) <- calendarGetYearMonthDay calendarWidget+        calendarSelectYearMonthDay calendarWidget y (m + 1) d++    let yearLeft    = Gtk.castToButton . fromJust . getObject $ "yearLeft"+    void $ Gtk.on yearLeft Gtk.buttonActivated $ do+        (y, m, d) <- calendarGetYearMonthDay calendarWidget+        calendarSelectYearMonthDay calendarWidget (y - 1) m d++    let yearRight   = Gtk.castToButton . fromJust . getObject $ "yearRight"+    void $ Gtk.on yearRight Gtk.buttonActivated $ do+        (y, m, d) <- calendarGetYearMonthDay calendarWidget+        calendarSelectYearMonthDay calendarWidget (y + 1) m d++    calendarSetSelectedDate calendarWidget year month day+    calendarSetYearMonthDay calendarWidget year month day+    calendarLabelButtons firstDay numberOfDays buttons+    calendarSelectWidget calendarWidget++    forM_ buttons $ \btn ->+        void $ Gtk.on btn Gtk.buttonActivated $ do+            txt <- Gtk.buttonGetLabel btn+            when (txt /= []) $ do+                let d = read txt+                (y, m, _) <- calendarGetYearMonthDay calendarWidget+                calendarSetSelectedDate calendarWidget y m d+                calendarSelectWidget calendarWidget+                calendarOnChangeEmit calendarWidget++    return calendarWidget++  where+    showHex' i = let h = showHex i ""+                 in if length h < 2 then "0" ++ h else h++    colorToString (Gtk.Color r g b) = "#" ++ showHex' (r `div` 256) ++ showHex' (g `div` 256) ++ showHex' (b `div` 256)++calendarOnChangeEmit :: CalendarWidget -> IO ()+calendarOnChangeEmit calendarWidget = do+    (y, m, d) <- calendarGetSelectedDate calendarWidget+    observableSet (calendarChange calendarWidget) (y, m, d)++calendarOnChange :: CalendarWidget -> (Integer -> Int -> Int -> IO ()) -> IO ()+calendarOnChange calendarWidget action =+    observableRegister (calendarChange calendarWidget) $ \(year, month, day) -> action year month day++calendarSelectDate :: CalendarWidget -> (Integer, Int, Int) -> IO ()+calendarSelectDate calendarWidget (year, month, day) = do+    (firstDay, numberOfDays) <- calendarGetInfo year month+    calendarSelectYearMonthDay calendarWidget year month day+    calendarSetSelectedDate calendarWidget year month day+    calendarSetYearMonthDay calendarWidget year month day+    calendarLabelButtons firstDay numberOfDays $ calendarButtons calendarWidget+    calendarSelectWidget calendarWidget++calendarSelectYearMonthDay :: CalendarWidget -> Integer -> Int -> Int -> IO ()+calendarSelectYearMonthDay calendarWidget year month day = do+    let (month'', year') | month < 1  = (12, year - 1)+                         | month > 12 = (1, year + 1)+                         | otherwise  = (month, year)+    let year'' = if year' < 0 then 0 else year'++    Gtk.labelSetText (calendarYearLabel calendarWidget) $ show year''+    Gtk.labelSetText (calendarMonthLabel calendarWidget) $ show (intToMonth month'')++    calendarSetYearMonthDay calendarWidget year'' month'' day++    (firstDay, numberOfDays) <- calendarGetInfo year'' month''++    calendarLabelButtons firstDay numberOfDays $ calendarButtons calendarWidget+    calendarSelectWidget calendarWidget++calendarGetYearMonthDay :: CalendarWidget -> IO (Integer, Int, Int)+calendarGetYearMonthDay calendarWidget = do+    y <- readIORef $ calendarYear calendarWidget+    m <- readIORef $ calendarMonth calendarWidget+    d <- readIORef $ calendarDay calendarWidget+    return (y, m, d)++calendarSetYearMonthDay :: CalendarWidget -> Integer -> Int -> Int -> IO ()+calendarSetYearMonthDay calendarWidget year month day = do+    writeIORef (calendarYear calendarWidget) year+    writeIORef (calendarMonth calendarWidget) month+    writeIORef (calendarDay calendarWidget) day++calendarGetSelectedDate :: CalendarWidget -> IO (Integer, Int, Int)+calendarGetSelectedDate calendarWidget = do+    y <- readIORef $ calendarSelectedYear calendarWidget+    m <- readIORef $ calendarSelectedMonth calendarWidget+    d <- readIORef $ calendarSelectedDay calendarWidget+    return (y, m, d)++calendarSetSelectedDate :: CalendarWidget -> Integer -> Int -> Int -> IO ()+calendarSetSelectedDate calendarWidget year month day = do+    writeIORef (calendarSelectedYear calendarWidget) year+    writeIORef (calendarSelectedMonth calendarWidget) month+    writeIORef (calendarSelectedDay calendarWidget) day++calendarLabelButtons :: Int -> Int -> [Gtk.Button] -> IO ()+calendarLabelButtons firstDay numberOfDays buttons = do+    forM_ buttons $ flip Gtk.widgetSetName ""++    forM_ [0 .. 41] $ \i -> do+        let btn = buttons !! i+        let k = i - firstDay + 2+        if k > 0 && k <= numberOfDays+            then do+                if i `mod` 7 == 6+                    then Gtk.widgetSetName btn "SensitiveSunday"+                    else Gtk.widgetSetName btn "Sensitive"+                Gtk.buttonSetLabel btn $ show k+            else do+                Gtk.widgetSetName btn "Insensitive"+                Gtk.buttonSetLabel btn ""++calendarSelectWidget :: CalendarWidget -> IO ()+calendarSelectWidget calendarWidget = do+    let buttons = calendarButtons calendarWidget++    forM_ buttons $ \btn -> do+        name <- Gtk.widgetGetName btn+        case name of+            "Today"               -> Gtk.widgetSetName btn "Sensitive"+            "TodaySunday"         -> Gtk.widgetSetName btn "SensitiveSunday"+            "TodaySelected"       -> Gtk.widgetSetName btn "Sensitive"+            "TodaySelectedSunday" -> Gtk.widgetSetName btn "SensitiveSunday"+            "Selected"            -> Gtk.widgetSetName btn "Sensitive"+            "SelectedSunday"      -> Gtk.widgetSetName btn "SensitiveSunday"+            _                     -> return ()++    (year, month, _ ) <- calendarGetYearMonthDay calendarWidget+    (year', month', day', _, _) <- calendarGetDate+    when (year == year' && month == month') $+        forM_ buttons $ \btn -> do+            txt <- Gtk.buttonGetLabel btn+            when (txt == show day') $ do+                name <- Gtk.widgetGetName btn+                case name of+                    "Sensitive"       -> Gtk.widgetSetName btn "Today"+                    "SensitiveSunday" -> Gtk.widgetSetName btn "TodaySunday"+                    _                -> return ()++    (year'', month'', day'') <- calendarGetSelectedDate calendarWidget+    when (year == year'' && month == month'') $+        forM_ buttons $ \btn -> do+            txt <- Gtk.buttonGetLabel btn+            when (txt == show day'') $ do+                name <- Gtk.widgetGetName btn+                case name of+                    "Today"           -> Gtk.widgetSetName btn "TodaySelected"+                    "TodaySunday"     -> Gtk.widgetSetName btn "TodaySelectedSunday"+                    "Sensitive"       -> Gtk.widgetSetName btn "Selected"+                    "SensitiveSunday" -> Gtk.widgetSetName btn "SelectedSunday"+                    _                -> return ()
+ src/Coin/UI/Widgets/CheckList.hs view
@@ -0,0 +1,181 @@+{-+ *  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.Widgets.CheckList (+    CheckListWidget,+    checkListNew,+    checkListAppend,+    checkListClear,+    checkListGetSelected,+    checkListGetSelectionIndex,+    checkListSetSelectionIndex+) where++import qualified System.Glib.GObject as Gtk+import qualified Graphics.UI.Gtk as Gtk+import Graphics.UI.Gtk ( AttrOp(..) )++import qualified Data.Text as T++import Control.Monad+import Data.Foldable+import Data.IORef++import Coin.Utils.I18N+import Coin.UI.Builder.GtkUIBuilder++data CheckListWidget a = CheckListWidget {+    checkListRoot     :: Gtk.Widget,+    checkListStore    :: Gtk.ListStore (Bool, T.Text),+    checkListOriginal :: IORef [a],+    checkListSelected :: IORef [Int],+    checkListToText   :: a -> T.Text+}++instance Gtk.GObjectClass (CheckListWidget a) where+    toGObject = Gtk.toGObject . checkListRoot+    unsafeCastGObject = undefined++instance Gtk.WidgetClass (CheckListWidget a)++reserved :: Int+reserved = 2++checkListNew :: String -> (a -> T.Text) -> IO (CheckListWidget a)+checkListNew name toText = do+    store <- Gtk.listStoreNew []+    treeView <- Gtk.treeViewNewWithModel store+    Gtk.treeViewSetHeadersVisible treeView False++    col1 <- Gtk.treeViewColumnNew+    col2 <- Gtk.treeViewColumnNew++    cell1 <- Gtk.cellRendererToggleNew+    Gtk.cellRendererToggleSetRadio cell1 False+    cell2 <- Gtk.cellRendererTextNew++    Gtk.cellLayoutSetAttributes col1 cell1 store $ \(x, _) -> [ Gtk.cellToggleActive := x ]+    Gtk.cellLayoutSetAttributes col2 cell2 store $ \(_, x) -> [ Gtk.cellText := x ]++    Gtk.treeViewColumnPackStart col1 cell1 True+    Gtk.treeViewColumnPackStart col2 cell2 True++    forM_ [col1, col2] $ Gtk.treeViewAppendColumn treeView++    (_, root) <- uiBuildGtk $+        vbox Nothing False 2 $ do+            pack Gtk.PackNatural 2 $ do+                labelAttrs [ Gtk.miscXalign := 0.0 ]+                label Nothing $ " " ++ name+            scrolledWindow Nothing $ putWidget treeView++    selectedList <- newIORef []+    originalList <- newIORef []+    let checkList = CheckListWidget root store originalList selectedList toText++    checkListClear checkList++    void $ Gtk.on cell1 Gtk.cellToggled $ \s -> do+        let i = read s+        (selected, _) <- Gtk.listStoreGetValue store i+        if | i == 0    -> if selected then+                              checkListLoadState checkList+                          else do+                              checkListSaveState checkList+                              checkListSelectAll checkList+                              checkListModifySelection checkList 0 $ const True+           | i == 1    -> if selected then+                              checkListLoadState checkList+                          else do+                              checkListSaveState checkList+                              checkListDeselectAll checkList+                              checkListModifySelection checkList 1 $ const True+           | otherwise -> do+                              checkListModifySelection checkList 0 $ const False+                              checkListModifySelection checkList 1 $ const False+                              checkListModifySelection checkList i not++    return checkList++checkListSaveState :: CheckListWidget a -> IO ()+checkListSaveState checkList = do+    indexes <- checkListGetSelectionIndex checkList+    modifyIORef' (checkListSelected checkList) $ const indexes++checkListLoadState :: CheckListWidget a -> IO ()+checkListLoadState checkList = do+    indexes <- readIORef $ checkListSelected checkList+    checkListSetSelectionIndex checkList indexes++checkListModifySelection :: CheckListWidget a -> Int -> (Bool -> Bool) -> IO ()+checkListModifySelection checkList i f = do+    (selected, text) <- Gtk.listStoreGetValue (checkListStore checkList) i+    Gtk.listStoreSetValue (checkListStore checkList) i (f selected, text)++checkListDeselectAll :: CheckListWidget a -> IO ()+checkListDeselectAll checkList = do+    size <- Gtk.listStoreGetSize $ checkListStore checkList+    forM_ [0 .. size - 1] $ \k -> checkListModifySelection checkList k $ const False++checkListSelectAll :: CheckListWidget a -> IO ()+checkListSelectAll checkList = do+    size <- Gtk.listStoreGetSize $ checkListStore checkList+    forM_ [0 .. size - 1] $ \k -> checkListModifySelection checkList k $ const True+    checkListModifySelection checkList 0 $ const False+    checkListModifySelection checkList 1 $ const False++checkListGetSelected :: CheckListWidget a -> IO [a]+checkListGetSelected checkList = do+    indexes <- checkListGetSelectionIndex checkList+    elements <- readIORef $ checkListOriginal checkList+    forM indexes $ \i -> return $ elements !! i++checkListSetSelectionIndex :: CheckListWidget a -> [Int] -> IO ()+checkListSetSelectionIndex checkList indexes = do+    checkListDeselectAll checkList+    forM_ indexes $ \k -> checkListModifySelection checkList (k + reserved) $ const True++checkListGetSelectionIndex :: CheckListWidget a -> IO [Int]+checkListGetSelectionIndex checkList = do+    size <- Gtk.listStoreGetSize $ checkListStore checkList+    foldrM (\i acc -> do+                (sel, _) <- Gtk.listStoreGetValue (checkListStore checkList) i+                if sel then+                    return (i - reserved: acc)+                else+                    return acc)+           []+           [reserved .. size - 1]++checkListAppend' :: CheckListWidget a -> Bool -> T.Text -> IO ()+checkListAppend' checkList toggle text = void $ Gtk.listStoreAppend (checkListStore checkList) (toggle, text)++checkListAppend :: CheckListWidget a -> Bool -> a -> IO ()+checkListAppend checkList toggle entity = do+    checkListAppend' checkList toggle (checkListToText checkList entity)+    modifyIORef' (checkListOriginal checkList) (++[entity])++checkListClear :: CheckListWidget a -> IO ()+checkListClear checkList = do+    Gtk.listStoreClear $ checkListStore checkList+    checkListAppend' checkList False (T.pack $ __"Select all")+    checkListAppend' checkList False (T.pack $ __"Deselect all")
+ src/Coin/UI/Widgets/InputBox.hs view
@@ -0,0 +1,58 @@+{-+ *  Programmer:	Piotr Borek+ *  E-mail:     piotrborek@op.pl+ *  Copyright 2015 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.Widgets.InputBox (+    inputBoxNew+) where++import Data.Maybe++import Graphics.UI.Gtk++import Coin.UI.Builder.GtkUIBuilder+import Coin.UI.Widgets.ResponseButtons++inputBoxNew :: String -> (Maybe String -> IO ()) -> IO ()+inputBoxNew msg fun = do+    responseButtons <- responseButtonsNew ButtonsOkCancel++    (getObject, root) <-uiBuildGtk $ do+        windowAttrs [ windowModal := True, windowTypeHint := WindowTypeHintDialog, windowResizable := False ]+        window Nothing "" $ do+            vbox Nothing False 0 $ do+                packing PackGrow 5+                hbox Nothing False 0 $ do+                    packing PackNatural 5+                    imageFromStock Nothing stockEdit IconSizeDialog+                    label Nothing msg+                    pack PackGrow 5 $ entry (Just "text") ""+                packDefault $ hseparator Nothing+                putWidget responseButtons++    responseButtonsOnActivated responseButtons $ \r -> do+        s <- entryGetText . castToEntry . fromJust $ getObject "text"+        widgetDestroy root+        if (r == ResponseOk && s /= "")+            then fun $ Just s+            else fun Nothing++    widgetShowAll root
+ src/Coin/UI/Widgets/MessageBox.hs view
@@ -0,0 +1,85 @@+{-+ *  Programmer:	Piotr Borek+ *  E-mail:     piotrborek@op.pl+ *  Copyright 2015 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.Widgets.MessageBox (+    messageBoxNew,+    messageBoxNew_+) where++import Graphics.UI.Gtk++import Coin.UI.Builder.GtkUIBuilder+import Coin.Utils.I18N+import Coin.UI.Widgets.ResponseButtons+import Coin.UI.Utils.CssUtils++messageBoxNew :: MessageType -> ButtonsType -> String -> (ResponseId -> IO ()) -> IO ()+messageBoxNew mType bType msg fun = do+    responseButtons <- responseButtonsNew bType++    let labelCss =+            [ "label {"+            , "    font-size: 1.2em;"+            , "    padding: 5px;"+            , "}"+            ]+    (_, root) <- uiBuildGtk $ do+        windowAttrs [ windowModal := True, windowTypeHint := WindowTypeHintDialog, windowResizable := False ]+        window Nothing (messageBoxGetTitle mType) $ do+            vbox Nothing False 0 $ do+                packing PackGrow 5+                hbox Nothing False 0 $ do+                    packing PackNatural 5+                    imageFromStock Nothing (messageBoxGetImage mType) IconSizeDialog+                    labelAttrs [ cssStyle := labelCss ]+                    label Nothing msg+                packDefault $ hseparator Nothing+                putWidget responseButtons++    responseButtonsOnActivated responseButtons $ \r -> do+        widgetDestroy root+        fun r++    widgetShowAll root++    return ()++messageBoxNew_ :: MessageType -> ButtonsType -> String -> IO ()+messageBoxNew_ mType bType msg = messageBoxNew mType bType msg $ \_ -> do return ()++messageBoxGetImage :: MessageType -> StockId+messageBoxGetImage mType =+    case mType of+        MessageInfo     -> stockDialogInfo+        MessageWarning  -> stockDialogWarning+        MessageQuestion -> stockDialogQuestion+        MessageError    -> stockDialogError+        _               -> stockMissingImage++messageBoxGetTitle :: MessageType -> String+messageBoxGetTitle mType =+    case mType of+        MessageInfo     -> __ "Info"+        MessageWarning  -> __ "Warning"+        MessageQuestion -> __ "Question"+        MessageError    -> __ "Error"+        _               -> ""
+ src/Coin/UI/Widgets/MiniCalendar.hs view
@@ -0,0 +1,213 @@+{-+ *  Programmer:	Piotr Borek+ *  E-mail:     piotrborek@op.pl+ *  Copyright 2015 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.Widgets.MiniCalendar (+    MiniCalendarWidget,+    miniCalendarNew,+    miniCalendarGetDate,+    miniCalendarSetDate,+    miniCalendarOnChange+) where++import qualified System.Glib.Types as Gtk+import qualified Graphics.UI.Gtk as Gtk+import Graphics.UI.Gtk ( AttrOp(..) )++import Control.Monad+import Data.Maybe+import Data.IORef++import Coin.UI.Builder.GtkUIBuilder+import Coin.UI.Utils.CssUtils+import Coin.UI.Utils.CalendarUtils+import Coin.UI.Utils.Observable+import Coin.Utils.ColorUtils+import Coin.Utils.I18N++data MiniCalendarWidget = MiniCalendarWidget {+    miniCalendarContainer  :: Gtk.Box,+    miniCalendarYearLabel  :: Gtk.Label,+    miniCalendarMonthLabel :: Gtk.Label,+    miniCalendarYear       :: IORef Integer,+    miniCalendarMonth      :: IORef Int,+    miniCalendarChange     :: Observable (Integer, Int)+}++instance Gtk.GObjectClass MiniCalendarWidget where+    toGObject = Gtk.toGObject . miniCalendarContainer+    unsafeCastGObject = undefined++instance Gtk.WidgetClass MiniCalendarWidget++miniCalendarNew :: IO MiniCalendarWidget+miniCalendarNew = do+    (year, month, _, _, _) <- calendarGetDate++    refYear  <- newIORef year+    refMonth <- newIORef month+    calendarObservable <- observableNew++    cal <- Gtk.calendarNew+    calStyle <- Gtk.widgetGetStyle cal+    bg <- colorToString <$> Gtk.styleGetBackground calStyle Gtk.StateNormal+    fg <- colorToString <$> Gtk.styleGetText calStyle Gtk.StateNormal+    sb <- colorToString <$> Gtk.styleGetLight calStyle Gtk.StateSelected++    let css = [ cssStyleReset+              , "* {"+              , "    color: " ++ fg ++ ";"+              , "}"+              , "frame {"+              , "    background-color: " ++ bg ++ ";"+              , "    border: 1px;"+              , "    border-style: solid;"+              , "    border-radius: 10px;"+              , "    padding: 4px 4px 4px 4px;"+              , "}"+              , "label {"+              , "    padding: 2px;"+              , "}"+              , "button {"+              , "    transition: 200ms ease-in-out;"+              , "    font-size: 1.1em;"+              , "    background-color: " ++ bg ++ ";"+              , "    border-color: " ++ bg ++ ";"+              , "    border-radius: 8px 0px 8px 0px;"+              , "    border-width: 1px;"+              , "    border-style: solid;"+              , "    padding: 2px;"+              , "}"+              , "#TodayButton {"+              , "    transition: none;"+              , "    font-size: 1em;"+              , "    border-radius: 8px 0px 8px 0px;"+              , "    padding: 0px;"+              , "}"+              , "#TodayButton:active {"+              , "    background-color: " ++ sb ++ ";"+              , "}"+              , "#Arrow {"+              , "    font-weight: bold;"+              , "    font-size: 2em;"+              , "    padding: 0px 6px 0px 6px;"+              , "    border-style: none;"+              , "    border-radius: 12px;"+              , "}"+              , "#Arrow:hover {"+              , "    background-color: " ++ sb ++ ";"+              , "}"+              , "#TodayButton:hover {"+              , "    border-color: " ++ sb ++ ";"+              , "}"+              ]++    (getObject, root) <- uiBuildGtk $ do+        packing Gtk.PackNatural 0+        vbox Nothing False 0 $ hbox Nothing False 0 $ do+            globalCss css+            hbox Nothing False 0 $ do+                frame Nothing Nothing $ do+                    grid Nothing $ do+                        gridAttach 0 0 1 1 $ do+                            buttonAttrs [ Gtk.widgetName := Just "Arrow" ]+                            button (Just "monthLeft") "<"+                        gridAttach 1 0 3 1 $ do+                            widgetAttrs [ Gtk.widgetWidthRequest := 100 ]+                            label (Just "month") (show $ intToMonth month)+                        gridAttach 4 0 1 1 $ do+                            buttonAttrs [ Gtk.widgetName := Just "Arrow" ]+                            button (Just "monthRight") ">"+                        gridAttach 5 0 1 1 $ do+                            buttonAttrs [ Gtk.widgetName := Just "Arrow" ]+                            button (Just "yearLeft") "<"+                        gridAttach 6 0 3 1 $ do+                            widgetAttrs [ Gtk.widgetWidthRequest := 60 ]+                            label (Just "year") (show year)+                        gridAttach 9 0 1 1 $ do+                            buttonAttrs [ Gtk.widgetName := Just "Arrow" ]+                            button (Just "yearRight") ">"+                        gridAttach 10 0 3 1 $ do+                            buttonAttrs [ Gtk.widgetName := Just "TodayButton" ]+                            button (Just "today") (__"Today")++    let monthLabel = Gtk.castToLabel . fromJust . getObject $ "month"+    let yearLabel  = Gtk.castToLabel . fromJust . getObject $ "year"+    let monthLeft   = Gtk.castToButton . fromJust . getObject $ "monthLeft"+    let monthRight  = Gtk.castToButton . fromJust . getObject $ "monthRight"+    let yearLeft    = Gtk.castToButton . fromJust . getObject $ "yearLeft"+    let yearRight   = Gtk.castToButton . fromJust . getObject $ "yearRight"+    let todayButton = Gtk.castToButton . fromJust . getObject $ "today"++    let miniCalendarWidget = MiniCalendarWidget+                                 (Gtk.castToBox root)+                                 yearLabel+                                 monthLabel+                                 refYear+                                 refMonth+                                 calendarObservable++    void $ Gtk.on todayButton Gtk.buttonActivated $ do+        (y, m, _, _, _) <- calendarGetDate+        miniCalendarSetDate miniCalendarWidget y m++    void $ Gtk.on monthLeft Gtk.buttonActivated $ do+        (y, m) <- miniCalendarGetDate miniCalendarWidget+        miniCalendarSetDate miniCalendarWidget y (m - 1)++    void $ Gtk.on monthRight Gtk.buttonActivated $ do+        (y, m) <- miniCalendarGetDate miniCalendarWidget+        miniCalendarSetDate miniCalendarWidget y (m + 1)++    void $ Gtk.on yearLeft Gtk.buttonActivated $ do+        (y, m) <- miniCalendarGetDate miniCalendarWidget+        miniCalendarSetDate miniCalendarWidget (y - 1) m++    void $ Gtk.on yearRight Gtk.buttonActivated $ do+        (y, m) <- miniCalendarGetDate miniCalendarWidget+        miniCalendarSetDate miniCalendarWidget (y + 1) m++    miniCalendarSetDate miniCalendarWidget year month++    return miniCalendarWidget++miniCalendarSetDate :: MiniCalendarWidget -> Integer -> Int -> IO ()+miniCalendarSetDate cal year month = do+    let (month'', year') = if month < 1 then (12, year - 1) else (if month > 12 then (1, year + 1) else (month, year))+    let year'' = if year' < 0 then 0 else year'++    Gtk.labelSetText (miniCalendarYearLabel cal) $ show year''+    Gtk.labelSetText (miniCalendarMonthLabel cal) $ show (intToMonth month'')++    writeIORef (miniCalendarYear cal) year''+    writeIORef (miniCalendarMonth cal) month''++    observableSet (miniCalendarChange cal) (year'', month'')++miniCalendarGetDate :: MiniCalendarWidget -> IO (Integer, Int)+miniCalendarGetDate cal = do+    y <- readIORef $ miniCalendarYear cal+    m <- readIORef $ miniCalendarMonth cal+    return (y, m)++miniCalendarOnChange :: MiniCalendarWidget -> (Integer -> Int -> IO ()) -> IO ()+miniCalendarOnChange cal action = do+    observableRegister (miniCalendarChange cal) $ \(year, month) -> action year month
+ src/Coin/UI/Widgets/MultiList.hs view
@@ -0,0 +1,180 @@+{-+ *  Programmer:	Piotr Borek+ *  E-mail:     piotrborek@op.pl+ *  Copyright 2015 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.Widgets.MultiList (+    MultiListWidget,+    multiListNew,+    multiListButtonNew,+    multiListButtonShow,+    multiListButtonOnActivated,+    multiListOptionClear,+    multiListOptionAdd,+    multiListOptionAdd',+    multiListOptionSetCursor,+    multiListOptionGetCursor,+    multiListOptionToList+) where++import qualified System.Glib.Types as Gtk+import qualified Graphics.UI.Gtk as Gtk+import Graphics.UI.Gtk ( AttrOp(..) )++import Control.Monad+import Data.IORef++import Coin.UI.Widgets.SimpleListView+import Coin.UI.Utils.CssUtils++data MultiListData = MultiListData {+    multiListButton      :: Gtk.Button,+    multiListWindow      :: Gtk.ScrolledWindow,+    multiListView        :: SimpleListView,+    multiListConnections :: IORef [Gtk.ConnectId SimpleListView]+}++data MultiListWidget = MultiListWidget {+    multiListContainer :: Gtk.VBox,+    multiListWidgets   :: IORef [MultiListData],+    multiListCounter   :: IORef Int+}++instance Gtk.GObjectClass MultiListWidget where+    toGObject = Gtk.toGObject . multiListContainer+    unsafeCastGObject = undefined++instance Gtk.WidgetClass MultiListWidget++multiListNew :: IO MultiListWidget+multiListNew = do+    box <- Gtk.vBoxNew False 0+    widgets <- newIORef []+    counter <- newIORef 0+    return $ MultiListWidget box widgets counter++multiListButtonNew :: MultiListWidget -> String -> IO Int+multiListButtonNew multiList text = do+    let buttonCss =+           [ "button {"+           , "    padding: 5px;"+           , "    border-radius: 8px;"+           , "    font-weight: bold;"+           , "}"+           ]++    index <- readIORef $ multiListCounter multiList++    button <- Gtk.buttonNew+    Gtk.set button [ Gtk.buttonLabel := text, Gtk.buttonXalign := 0.0, cssStyle := buttonCss]+    void $ Gtk.on button Gtk.buttonActivated $ multiListButtonShow multiList index+    listView <- simpleListViewNew []++    let vbox = multiListContainer multiList+    Gtk.boxPackStart vbox button Gtk.PackNatural 0++    scrolledWindow <- Gtk.scrolledWindowNew Nothing Nothing+    Gtk.scrolledWindowAddWithViewport scrolledWindow listView++    Gtk.boxPackStart vbox scrolledWindow Gtk.PackGrow 0++    connections <- newIORef []+    modifyIORef' (multiListWidgets multiList) $ \w ->+        w ++ [MultiListData button scrolledWindow listView connections]++    modifyIORef' (multiListCounter multiList) (+1)++    return index++multiListButtonShow :: MultiListWidget -> Int -> IO ()+multiListButtonShow multiList index = do+    widgets <- readIORef $ multiListWidgets multiList+    forM_ widgets $ \d -> Gtk.widgetHide $ multiListWindow d+    let d = widgets !! index+    Gtk.widgetShow $ multiListWindow d++multiListButtonOnActivated :: MultiListWidget -> Int -> IO () -> IO ()+multiListButtonOnActivated multiList index action = do+    widgets <- readIORef $ multiListWidgets multiList+    let d = widgets !! index+    void $ Gtk.on (multiListButton d) Gtk.buttonActivated action++multiListOptionClear :: MultiListWidget -> Int -> IO ()+multiListOptionClear multiList index = do+    widgets <- readIORef $ multiListWidgets multiList+    let d = widgets !! index++    connections <- readIORef $ multiListConnections d+    forM_ connections Gtk.signalDisconnect+    modifyIORef' (multiListConnections d) $ const []++    simpleListViewClear $ multiListView d++multiListOptionAdd' :: MultiListWidget -> Int -> [(String, IO ())] -> IO ()+multiListOptionAdd' multiList index tuples =+    forM_ tuples $ \(text, action) -> multiListOptionAdd multiList index text action++multiListOptionAdd :: MultiListWidget -> Int -> String -> IO () -> IO ()+multiListOptionAdd multiList index text action = do+    widgets <- readIORef $ multiListWidgets multiList+    let d = widgets !! index+    let list = multiListView d+    listIndex <- simpleListViewAppend list text+    connID <- Gtk.on list Gtk.cursorChanged $ do+        (path, _) <- Gtk.treeViewGetCursor list+        when (path == [listIndex]) $ do+            forM_ widgets $ \dta ->+                when (list /= multiListView dta) $ do+                    selection <- Gtk.treeViewGetSelection $ multiListView dta+                    Gtk.treeViewSetCursor (multiListView dta) [] Nothing+                    Gtk.treeSelectionUnselectAll selection+            action++    modifyIORef' (multiListConnections d) (connID:)++multiListOptionSetCursor :: MultiListWidget -> Int -> Int -> IO ()+multiListOptionSetCursor multiList buttonIndex listIndex = do+    widgets <- readIORef $ multiListWidgets multiList+    let d = widgets !! buttonIndex+    let list = multiListView d+    multiListButtonShow multiList buttonIndex+    Gtk.treeViewSetCursor list [listIndex] Nothing++multiListOptionGetCursor :: MultiListWidget -> IO (Maybe (Int, Int))+multiListOptionGetCursor multiList = do+    widgets <- readIORef $ multiListWidgets multiList++    foldM (\rval (idx, widget) ->+               case rval of+                   Just _  -> return rval+                   Nothing -> do+                       (path, _) <- Gtk.treeViewGetCursor $ multiListView widget+                       case path of+                           [path'] -> return $ Just (idx, path')+                           _       -> return Nothing+          )+          Nothing+          (zip [0..] widgets)++multiListOptionToList :: MultiListWidget -> Int -> IO [String]+multiListOptionToList multiList index = do+    widgets <- readIORef $ multiListWidgets multiList+    let d = widgets !! index+    simpleListViewToList $ multiListView d
+ src/Coin/UI/Widgets/ResponseButtons.hs view
@@ -0,0 +1,136 @@+{-+ *  Programmer:	Piotr Borek+ *  E-mail:     piotrborek@op.pl+ *  Copyright 2015 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.Widgets.ResponseButtons (+    responseButtonsNew,+    responseButtonsOnActivated+) where++import System.Glib.Types+import Graphics.UI.Gtk++import Control.Monad++import Coin.UI.Builder.GtkUIBuilder+import Coin.UI.Utils.CssUtils++data ResponseButtonsWidget = ResponseButtonsWidget {+    widgetContainer :: HBox,+    button1         :: Maybe Button,+    button2         :: Maybe Button,+    buttonType      :: ButtonsType+}++instance GObjectClass ResponseButtonsWidget where+    toGObject = toGObject . widgetContainer+    unsafeCastGObject = undefined++instance WidgetClass ResponseButtonsWidget++responseButtonsNew :: ButtonsType -> IO ResponseButtonsWidget+responseButtonsNew bType = do+    (getObject, root) <-uiBuildGtk $ do+        hbox Nothing False 0 $ do+            label Nothing ""+            packing PackNatural 5+            hbox Nothing True 0 $ do+                packing PackGrow 0+                myButtonsNew bType++    let b1 = castToButton `liftM` getObject "button1"+    let b2 = castToButton `liftM` getObject "button2"++    return $ ResponseButtonsWidget (castToHBox root) b1 b2 bType++responseButtonsOnActivated :: ResponseButtonsWidget -> (ResponseId -> IO ()) -> IO ()+responseButtonsOnActivated w f = do+    case button1 w of+        Just b1 ->+            case buttonType w of+                ButtonsYesNo    -> do+                    _ <- on b1 buttonActivated $ f ResponseYes+                    return ()+                ButtonsOkCancel -> do+                    _ <- on b1 buttonActivated $ f ResponseOk+                    return ()+                _               ->+                    return ()+        Nothing ->+            return ()++    case button2 w of+        Just b2 ->+            case buttonType w of+                ButtonsYesNo    -> do+                    _ <- on b2 buttonActivated $ f ResponseNo+                    return ()+                ButtonsOkCancel -> do+                    _ <- on b2 buttonActivated $ f ResponseCancel+                    return ()+                ButtonsOk     -> do+                    _ <- on b2 buttonActivated $ f ResponseOk+                    return ()+                ButtonsClose  -> do+                    _ <- on b2 buttonActivated $ f ResponseClose+                    return ()+                ButtonsCancel -> do+                    _ <- on b2 buttonActivated $ f ResponseCancel+                    return ()+                _             ->+                    return ()+        Nothing ->+            return ()++myButtonsNew :: ButtonsType -> UIBuilder a+myButtonsNew bType = do+    let buttonCss =+            [ "button {"+            , "    padding-left: 15px;"+            , "    padding-right: 15px;"+            , "}"+            ]+    case bType of+        ButtonsNone     -> do+            label Nothing ""+            label Nothing ""+        ButtonsOk       -> do+            label Nothing ""+            buttonAttrs [ cssStyle := buttonCss ]+            buttonFromStock (Just "button2") stockOk+        ButtonsClose    -> do+            label Nothing ""+            buttonAttrs [ cssStyle := buttonCss ]+            buttonFromStock (Just "button2") stockClose+        ButtonsCancel   -> do+            label Nothing ""+            buttonAttrs [ cssStyle := buttonCss ]+            buttonFromStock (Just "button2") stockCancel+        ButtonsYesNo    -> do+            buttonAttrs [ cssStyle := buttonCss ]+            buttonFromStock (Just "button1") stockYes+            buttonAttrs [ cssStyle := buttonCss ]+            buttonFromStock (Just "button2") stockNo+        ButtonsOkCancel -> do+            buttonAttrs [ cssStyle := buttonCss ]+            buttonFromStock (Just "button1") stockOk+            buttonAttrs [ cssStyle := buttonCss ]+            buttonFromStock (Just "button2") stockCancel
+ src/Coin/UI/Widgets/SimpleListView.hs view
@@ -0,0 +1,83 @@+{-+ *  Programmer:	Piotr Borek+ *  E-mail:     piotrborek@op.pl+ *  Copyright 2015 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.Widgets.SimpleListView (+    SimpleListView,+    simpleListViewNew,+    simpleListViewAppend,+    simpleListViewAppendList,+    simpleListViewClear,+    simpleListViewToList+) where++import System.Glib.Types+import Graphics.UI.Gtk++import Control.Monad++data SimpleListView = SimpleListView {+    simpleListViewContainer :: TreeView,+    simpleListViewStore     :: ListStore String+}++instance GObjectClass SimpleListView where+    toGObject = toGObject . simpleListViewContainer+    unsafeCastGObject = undefined++instance WidgetClass SimpleListView+instance ContainerClass SimpleListView+instance TreeViewClass SimpleListView++instance Eq SimpleListView where+    a == b = simpleListViewContainer a == simpleListViewContainer b++simpleListViewNew :: [String] -> IO SimpleListView+simpleListViewNew list = do+    store <- listStoreNew list+    treeView <- treeViewNewWithModel store++    when (treeView == treeView) $ return ()++    column <- treeViewColumnNew+    cell <- cellRendererTextNew++    cellLayoutSetAttributes column cell store $ \row -> [ cellText := row ]+    treeViewColumnPackStart column cell True+    treeViewSetHeadersVisible treeView False++    _ <- treeViewAppendColumn treeView column++    return $ SimpleListView+                 treeView+                 store++simpleListViewAppend :: SimpleListView -> String -> IO Int+simpleListViewAppend simpleView text = listStoreAppend (simpleListViewStore simpleView) text++simpleListViewAppendList :: SimpleListView -> [String] -> IO ()+simpleListViewAppendList simpleView texts = forM_ texts $ simpleListViewAppend simpleView++simpleListViewClear :: SimpleListView -> IO ()+simpleListViewClear simpleView = listStoreClear (simpleListViewStore simpleView)++simpleListViewToList :: SimpleListView -> IO [String]+simpleListViewToList simpleView = listStoreToList (simpleListViewStore simpleView)
+ src/Coin/UI/Widgets/StackWidget.hs view
@@ -0,0 +1,92 @@+{-+ *  Programmer:	Piotr Borek+ *  E-mail:     piotrborek@op.pl+ *  Copyright 2015 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.Widgets.StackWidget (+    StackWidget,+    stackWidgetNew,+    stackWidgetAdd,+    stackWidgetGet,+    stackWidgetShow,+    stackWidgetGetVisible+) where++import qualified System.Glib.Types as Gtk+import qualified Graphics.UI.Gtk as Gtk+import qualified Data.Map.Strict as Map++import Control.Monad++import Coin.Utils.IORef++data StackWidget = StackWidget {+    stackContainer :: Gtk.VBox,+    stackWidgetMap :: IORef (Map.Map String Gtk.Widget)+}++instance Gtk.GObjectClass StackWidget where+    toGObject = Gtk.toGObject . stackContainer+    unsafeCastGObject = undefined++instance Gtk.WidgetClass StackWidget++stackWidgetNew :: IO StackWidget+stackWidgetNew = do+    box <- Gtk.vBoxNew False 0+    Gtk.widgetShow box+    ref <- newIORef Map.empty+    return $ StackWidget box ref++stackWidgetAdd :: Gtk.WidgetClass cls => StackWidget -> String -> cls -> IO ()+stackWidgetAdd stack name widget = do+    Gtk.boxPackStart (stackContainer stack) widget Gtk.PackGrow 0+    atomicModifyIORef_' (stackWidgetMap stack) $ Map.insert name (Gtk.castToWidget widget)+    Gtk.widgetHide widget++stackWidgetGet :: StackWidget -> String -> IO Gtk.Widget+stackWidgetGet stack name = do+    (Just w) <- Map.lookup name <$> atomicReadIORef' (stackWidgetMap stack)+    return w++stackWidgetShow :: StackWidget -> String -> IO ()+stackWidgetShow stack name = do+    m <- readIORef $ stackWidgetMap stack+    case Map.lookup name m of+        Just widget -> do+            forM_ (Map.elems m) Gtk.widgetHide+            Gtk.widgetShow widget+        Nothing     -> return ()++stackWidgetGetVisible :: StackWidget -> IO (Maybe String)+stackWidgetGetVisible stack = do+    m <- readIORef $ stackWidgetMap stack++    foldM (\rval (name, widget) ->+              case rval of+                  j@(Just _) ->+                      return j+                  Nothing -> do+                      visible <- Gtk.widgetGetVisible widget+                      if visible then return $ Just name+                      else return Nothing+          )+          Nothing+          (Map.toList m)
+ src/Coin/Utils/ColorUtils.hs view
@@ -0,0 +1,37 @@+{-+ *  Programmer:	Piotr Borek+ *  E-mail:     piotrborek@op.pl+ *  Copyright 2015 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.Utils.ColorUtils (+    colorToString+) where++import qualified Graphics.UI.Gtk as Gtk++import Data.Word+import Numeric++showHex' :: Word16 -> String+showHex' i = let h = showHex i ""+             in if length h < 2 then "0" ++ h else h++colorToString :: Gtk.Color -> String+colorToString (Gtk.Color r g b) = "#" ++ showHex' (r `div` 256) ++ showHex' (g `div` 256) ++ showHex' (b `div` 256)
+ src/Coin/Utils/Exception.hs view
@@ -0,0 +1,32 @@+{-  + *  Programmer:	Piotr Borek+ *  E-mail:     piotrborek@op.pl+ *  Copyright 2014 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.Utils.Exception where++import Control.Monad+import Control.Exception++catchAny :: IO a -> (SomeException -> IO a) -> IO a+catchAny = catch++try' :: IO a -> IO (Maybe a)+try' action = liftM Just action `catchAny` \_ -> return Nothing
+ src/Coin/Utils/FileHelper.hs view
@@ -0,0 +1,28 @@+{-+ *  Programmer:	Piotr Borek+ *  E-mail:     piotrborek@op.pl+ *  Copyright 2015 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.Utils.FileHelper where++separateFilePath :: String -> (String, String)+separateFilePath file =+    let (f, d) = span (/= '/') $ reverse file+    in (reverse $ tail d, reverse f)
+ src/Coin/Utils/I18N.hs view
@@ -0,0 +1,30 @@+{-  + *  Programmer:	Piotr Borek+ *  E-mail:     piotrborek@op.pl+ *  Copyright 2014 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.Utils.I18N where++import Text.I18N.GetText+import System.IO.Unsafe++{-# NOINLINE __ #-}+__ :: String -> String+__ = unsafePerformIO . getText
+ src/Coin/Utils/IORef.hs view
@@ -0,0 +1,39 @@+{-+ *  Programmer:	Piotr Borek+ *  E-mail:     piotrborek@op.pl+ *  Copyright 2015 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.Utils.IORef (+    module Data.IORef,+    atomicModifyIORef_',+    atomicReadIORef'+) where++import Data.IORef++atomicModifyIORef_' :: IORef a -> (a -> a) -> IO ()+atomicModifyIORef_' ref f = atomicModifyIORef' ref g+    where+        g x = (f x, ())++atomicReadIORef' :: IORef a -> IO a+atomicReadIORef' ref = atomicModifyIORef' ref g+    where+        g x = (x, x)
+ src/Coin/Utils/LocaleHelper.hs view
@@ -0,0 +1,46 @@+{-+ *  Programmer:	Piotr Borek+ *  E-mail:     piotrborek@op.pl+ *  Copyright 2015 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.Utils.LocaleHelper where++import Text.I18N.GetText+import System.Directory+import System.Locale.SetLocale+import System.FilePath++import Coin.Utils.FileHelper++initLocale :: String -> String -> IO ()+initLocale programName filePath = do+    exePath <- findExecutable programName+    curDir  <- getCurrentDirectory++    _ <- setLocale LC_ALL $ Just ""+    _ <- case exePath of+            Just path -> do+                let (exeDir, _) = separateFilePath path+                bindTextDomain programName (Just $ exeDir </> filePath)+            Nothing   ->+                bindTextDomain programName (Just $ curDir </> filePath)+    _ <- textDomain $ Just programName++    return ()
+ src/Coin/Utils/PropertyMap.hs view
@@ -0,0 +1,125 @@+{-+ *  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+-}++{-# LANGUAGE FlexibleInstances #-}++module Coin.Utils.PropertyMap (+    Property (..),+    PropertyMap,+    IsProperty,+    empty,+    insert,+    insertMaybe,+    delete,+    lookup,+    union+) where++import Prelude hiding (lookup)++import qualified Data.Map.Strict as Map++import Data.Binary++data Property = StringProperty String+              | IntProperty Int+              | MapProperty (Map.Map String Property)+              | IntListProperty [Int]+              | DateProperty (Integer, Int, Int)+              | BoolProperty Bool+              deriving Show++type PropertyMap = Map.Map String Property++class IsProperty a where+    toProperty   :: a -> Property+    fromProperty :: Property -> a++instance IsProperty String where+    toProperty = StringProperty+    fromProperty (StringProperty a) = a+    fromProperty x = error $ "instance IsProperty String: type conversion error.\n" ++ show x++instance IsProperty Int where+    toProperty = IntProperty+    fromProperty (IntProperty a) = a+    fromProperty x = error $ "instance IsProperty Int: type conversion error.\n" ++ show x++instance IsProperty (Map.Map String Property) where+    toProperty = MapProperty+    fromProperty (MapProperty a) = a+    fromProperty x = error $ "instance IsProperty Map: type conversion error.\n" ++ show x++instance IsProperty [Int] where+    toProperty = IntListProperty+    fromProperty (IntListProperty a) = a+    fromProperty x = error $ "instance IsProperty [Int]: type conversion error.\n" ++ show x++instance IsProperty (Integer, Int, Int) where+    toProperty = DateProperty+    fromProperty (DateProperty a) = a+    fromProperty x = error $ "instance IsProperty (Integer, Int, Int): type conversion error.\n" ++ show x++instance IsProperty Bool where+    toProperty = BoolProperty+    fromProperty (BoolProperty a) = a+    fromProperty x = error $ "instance IsProperty Bool: type conversion error.\n" ++ show x++instance Binary Property where+    put (StringProperty value)  = putWord8 255 >> put value+    put (IntProperty value)     = putWord8 254 >> put value+    put (MapProperty value)     = putWord8 253 >> put value+    put (IntListProperty value) = putWord8 252 >> put value+    put (DateProperty value)    = putWord8 251 >> put value+    put (BoolProperty value)    = putWord8 250 >> put value++    get = do+        t <- getWord8+        case t of+            255 -> StringProperty  <$> get+            254 -> IntProperty     <$> get+            253 -> MapProperty     <$> get+            252 -> IntListProperty <$> get+            251 -> DateProperty    <$> get+            250 -> BoolProperty    <$> get+            _   -> error "Error: PropertyMap.hs (instance Binary Property)."++empty :: PropertyMap+empty = Map.empty++insert :: IsProperty a => String -> a -> PropertyMap -> PropertyMap+insert key value = Map.insert key $ toProperty value++insertMaybe :: IsProperty a => String -> Maybe a -> PropertyMap -> PropertyMap+insertMaybe key value m =+    case value of+        Just value' -> insert key value' m+        Nothing     -> delete key m++delete :: String -> PropertyMap -> PropertyMap+delete = Map.delete++lookup :: IsProperty a => String -> PropertyMap -> Maybe a+lookup key m = fromProperty <$> Map.lookup key m++union :: PropertyMap -> PropertyMap -> PropertyMap+union = Map.union
+ src/Coin/Utils/StringUtils.hs view
@@ -0,0 +1,29 @@+{-+ *  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.Utils.StringUtils (+    strip+) where++strip :: String -> String+strip [] = []+strip xs = reverse $ dropWhile (== ' ') (reverse $ dropWhile (== ' ') xs)
+ src/Coin/Utils/TableView.hs view
@@ -0,0 +1,41 @@+{-+ *  Programmer:	Piotr Borek+ *  E-mail:     piotrborek@op.pl+ *  Copyright 2015 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.Utils.TableView (+    tableTextColumnNew+) where++import Graphics.UI.Gtk++tableTextColumnNew :: (TreeModelClass (model row), TypedTreeModelClass model)+    => String+    -> model row+    -> (row -> [AttrOp CellRendererText])+    -> IO TreeViewColumn+tableTextColumnNew columnName store f = do+    column <- treeViewColumnNew+    cell   <- cellRendererTextNew++    treeViewColumnSetTitle column columnName+    cellLayoutSetAttributes column cell store f+    treeViewColumnPackStart column cell True+    return column
+ src/Coin/Utils/ValueParser.hs view
@@ -0,0 +1,72 @@+{-+ *  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.Utils.ValueParser (+    parseValue,+    valueShow+) where++charToInt :: Char -> Maybe Int+charToInt '0' = Just 0+charToInt '1' = Just 1+charToInt '2' = Just 2+charToInt '3' = Just 3+charToInt '4' = Just 4+charToInt '5' = Just 5+charToInt '6' = Just 6+charToInt '7' = Just 7+charToInt '8' = Just 8+charToInt '9' = Just 9+charToInt _   = Nothing++parseValue :: String -> Maybe Int+parseValue []   = Nothing+parseValue text = parseValueA (reverse text) 0 100++parseValueA :: String -> Int -> Int -> Maybe Int+parseValueA [] acc _ = return acc+parseValueA (x:xs) acc mult =+    if or [x == ',', x == '.']+        then+            if mult == 10000+                then parseValueB xs (acc `div` 100) (mult `div` 100)+                else Nothing+        else do+            digit <- charToInt x+            parseValueA xs (acc + mult * digit) (mult * 10)++parseValueB :: String -> Int -> Int -> Maybe Int+parseValueB [] acc _ = return acc+parseValueB (x:xs) acc mult = do+    digit <- charToInt x+    parseValueB xs (acc + mult * digit) (mult * 10)++valueShow :: (Num n, Show n) => n -> String+valueShow val = let (a, b) = splitAt 2 $ reverse val'+                in reverse b ++ "." ++ reverse a+  where+      val' = let text = show val+             in case length text of+                    0 -> "000"+                    1 -> "00" ++ text+                    2 -> "0" ++ text+                    _ -> text
+ src/Main.hs view
@@ -0,0 +1,48 @@+{-+ *  Programmer:	Piotr Borek+ *  E-mail:     piotrborek@op.pl+ *  Copyright 2015 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 Main (main) where++import System.FilePath+import Graphics.UI.Gtk++import Coin.UI.MainState+import Coin.UI.MainWindow+import Coin.UI.MainInitialize+import Coin.Utils.LocaleHelper++import Coin.DB.Tables++main :: IO ()+main = do+    initLocale "coin" $ "resources" </> "i18n"++    initializeDatabase++    _ <- initGUI++    mainState <- mainStateNew+    window <- mainWindowNew mainState+    mainInitializeWidgets mainState++    widgetShow window+    mainGUI
+ stack.yaml view
@@ -0,0 +1,8 @@+flags:+  text:+    integer-simple: false+packages:+- '.'+extra-deps:+- text-1.2.2.1+resolver: lts-6.0