diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,1 @@ +GPL diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/coin.cabal b/coin.cabal new file mode 100644 --- /dev/null +++ b/coin.cabal @@ -0,0 +1,98 @@ +name: coin +version: 1.0 +Build-Type: Simple +cabal-version: >= 1.16 +author: Piotr Borek +maintainer: Piotr Borek +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 diff --git a/resources/i18n/pl/LC_MESSAGES/coin.mo b/resources/i18n/pl/LC_MESSAGES/coin.mo new file mode 100644 Binary files /dev/null and b/resources/i18n/pl/LC_MESSAGES/coin.mo differ diff --git a/resources/i18n/pl/LC_MESSAGES/coin.po b/resources/i18n/pl/LC_MESSAGES/coin.po new file mode 100644 --- /dev/null +++ b/resources/i18n/pl/LC_MESSAGES/coin.po @@ -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 \n" +"Language-Team: LANGUAGE \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" diff --git a/resources/i18n/pl/LC_MESSAGES/convert b/resources/i18n/pl/LC_MESSAGES/convert new file mode 100644 --- /dev/null +++ b/resources/i18n/pl/LC_MESSAGES/convert @@ -0,0 +1,3 @@ +#!/bin/bash + +msgfmt coin.po -o coin.mo diff --git a/src/Coin/Config/Dirs.hs b/src/Coin/Config/Dirs.hs new file mode 100644 --- /dev/null +++ b/src/Coin/Config/Dirs.hs @@ -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" diff --git a/src/Coin/DB/Functions.hs b/src/Coin/DB/Functions.hs new file mode 100644 --- /dev/null +++ b/src/Coin/DB/Functions.hs @@ -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 diff --git a/src/Coin/DB/Tables.hs b/src/Coin/DB/Tables.hs new file mode 100644 --- /dev/null +++ b/src/Coin/DB/Tables.hs @@ -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] [] diff --git a/src/Coin/UI/Accounts/AccountsHistory.hs b/src/Coin/UI/Accounts/AccountsHistory.hs new file mode 100644 --- /dev/null +++ b/src/Coin/UI/Accounts/AccountsHistory.hs @@ -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 ] diff --git a/src/Coin/UI/Accounts/AccountsIncome.hs b/src/Coin/UI/Accounts/AccountsIncome.hs new file mode 100644 --- /dev/null +++ b/src/Coin/UI/Accounts/AccountsIncome.hs @@ -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 diff --git a/src/Coin/UI/Accounts/AccountsOutcome.hs b/src/Coin/UI/Accounts/AccountsOutcome.hs new file mode 100644 --- /dev/null +++ b/src/Coin/UI/Accounts/AccountsOutcome.hs @@ -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 diff --git a/src/Coin/UI/Accounts/AccountsTransfer.hs b/src/Coin/UI/Accounts/AccountsTransfer.hs new file mode 100644 --- /dev/null +++ b/src/Coin/UI/Accounts/AccountsTransfer.hs @@ -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 diff --git a/src/Coin/UI/Accounts/AccountsWidget.hs b/src/Coin/UI/Accounts/AccountsWidget.hs new file mode 100644 --- /dev/null +++ b/src/Coin/UI/Accounts/AccountsWidget.hs @@ -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 diff --git a/src/Coin/UI/AccountsComboBox.hs b/src/Coin/UI/AccountsComboBox.hs new file mode 100644 --- /dev/null +++ b/src/Coin/UI/AccountsComboBox.hs @@ -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 diff --git a/src/Coin/UI/Builder/GtkUIAttributes.hs b/src/Coin/UI/Builder/GtkUIAttributes.hs new file mode 100644 --- /dev/null +++ b/src/Coin/UI/Builder/GtkUIAttributes.hs @@ -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 diff --git a/src/Coin/UI/Builder/GtkUIBuilder.hs b/src/Coin/UI/Builder/GtkUIBuilder.hs new file mode 100644 --- /dev/null +++ b/src/Coin/UI/Builder/GtkUIBuilder.hs @@ -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 diff --git a/src/Coin/UI/Builder/GtkUIBuilderState.hs b/src/Coin/UI/Builder/GtkUIBuilderState.hs new file mode 100644 --- /dev/null +++ b/src/Coin/UI/Builder/GtkUIBuilderState.hs @@ -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 diff --git a/src/Coin/UI/Builder/GtkUIUtils.hs b/src/Coin/UI/Builder/GtkUIUtils.hs new file mode 100644 --- /dev/null +++ b/src/Coin/UI/Builder/GtkUIUtils.hs @@ -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 diff --git a/src/Coin/UI/HistoryView.hs b/src/Coin/UI/HistoryView.hs new file mode 100644 --- /dev/null +++ b/src/Coin/UI/HistoryView.hs @@ -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 diff --git a/src/Coin/UI/MainInitialize.hs b/src/Coin/UI/MainInitialize.hs new file mode 100644 --- /dev/null +++ b/src/Coin/UI/MainInitialize.hs @@ -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 diff --git a/src/Coin/UI/MainMultiList.hs b/src/Coin/UI/MainMultiList.hs new file mode 100644 --- /dev/null +++ b/src/Coin/UI/MainMultiList.hs @@ -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" diff --git a/src/Coin/UI/MainState.hs b/src/Coin/UI/MainState.hs new file mode 100644 --- /dev/null +++ b/src/Coin/UI/MainState.hs @@ -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 diff --git a/src/Coin/UI/MainWindow.hs b/src/Coin/UI/MainWindow.hs new file mode 100644 --- /dev/null +++ b/src/Coin/UI/MainWindow.hs @@ -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 diff --git a/src/Coin/UI/Options/OptionsAccount.hs b/src/Coin/UI/Options/OptionsAccount.hs new file mode 100644 --- /dev/null +++ b/src/Coin/UI/Options/OptionsAccount.hs @@ -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) diff --git a/src/Coin/UI/Options/OptionsTag.hs b/src/Coin/UI/Options/OptionsTag.hs new file mode 100644 --- /dev/null +++ b/src/Coin/UI/Options/OptionsTag.hs @@ -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) diff --git a/src/Coin/UI/Raports/RaportHistory.hs b/src/Coin/UI/Raports/RaportHistory.hs new file mode 100644 --- /dev/null +++ b/src/Coin/UI/Raports/RaportHistory.hs @@ -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 ] diff --git a/src/Coin/UI/Raports/RaportQuery.hs b/src/Coin/UI/Raports/RaportQuery.hs new file mode 100644 --- /dev/null +++ b/src/Coin/UI/Raports/RaportQuery.hs @@ -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) diff --git a/src/Coin/UI/Raports/RaportSummary.hs b/src/Coin/UI/Raports/RaportSummary.hs new file mode 100644 --- /dev/null +++ b/src/Coin/UI/Raports/RaportSummary.hs @@ -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) diff --git a/src/Coin/UI/TagsComboBox.hs b/src/Coin/UI/TagsComboBox.hs new file mode 100644 --- /dev/null +++ b/src/Coin/UI/TagsComboBox.hs @@ -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 diff --git a/src/Coin/UI/Utils/CalendarUtils.hs b/src/Coin/UI/Utils/CalendarUtils.hs new file mode 100644 --- /dev/null +++ b/src/Coin/UI/Utils/CalendarUtils.hs @@ -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 diff --git a/src/Coin/UI/Utils/CssUtils.hs b/src/Coin/UI/Utils/CssUtils.hs new file mode 100644 --- /dev/null +++ b/src/Coin/UI/Utils/CssUtils.hs @@ -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;" + , "}" + ] + -} diff --git a/src/Coin/UI/Utils/Observable.hs b/src/Coin/UI/Utils/Observable.hs new file mode 100644 --- /dev/null +++ b/src/Coin/UI/Utils/Observable.hs @@ -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 diff --git a/src/Coin/UI/Widgets/Calendar.hs b/src/Coin/UI/Widgets/Calendar.hs new file mode 100644 --- /dev/null +++ b/src/Coin/UI/Widgets/Calendar.hs @@ -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 () diff --git a/src/Coin/UI/Widgets/CheckList.hs b/src/Coin/UI/Widgets/CheckList.hs new file mode 100644 --- /dev/null +++ b/src/Coin/UI/Widgets/CheckList.hs @@ -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") diff --git a/src/Coin/UI/Widgets/InputBox.hs b/src/Coin/UI/Widgets/InputBox.hs new file mode 100644 --- /dev/null +++ b/src/Coin/UI/Widgets/InputBox.hs @@ -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 diff --git a/src/Coin/UI/Widgets/MessageBox.hs b/src/Coin/UI/Widgets/MessageBox.hs new file mode 100644 --- /dev/null +++ b/src/Coin/UI/Widgets/MessageBox.hs @@ -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" + _ -> "" diff --git a/src/Coin/UI/Widgets/MiniCalendar.hs b/src/Coin/UI/Widgets/MiniCalendar.hs new file mode 100644 --- /dev/null +++ b/src/Coin/UI/Widgets/MiniCalendar.hs @@ -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 diff --git a/src/Coin/UI/Widgets/MultiList.hs b/src/Coin/UI/Widgets/MultiList.hs new file mode 100644 --- /dev/null +++ b/src/Coin/UI/Widgets/MultiList.hs @@ -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 diff --git a/src/Coin/UI/Widgets/ResponseButtons.hs b/src/Coin/UI/Widgets/ResponseButtons.hs new file mode 100644 --- /dev/null +++ b/src/Coin/UI/Widgets/ResponseButtons.hs @@ -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 diff --git a/src/Coin/UI/Widgets/SimpleListView.hs b/src/Coin/UI/Widgets/SimpleListView.hs new file mode 100644 --- /dev/null +++ b/src/Coin/UI/Widgets/SimpleListView.hs @@ -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) diff --git a/src/Coin/UI/Widgets/StackWidget.hs b/src/Coin/UI/Widgets/StackWidget.hs new file mode 100644 --- /dev/null +++ b/src/Coin/UI/Widgets/StackWidget.hs @@ -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) diff --git a/src/Coin/Utils/ColorUtils.hs b/src/Coin/Utils/ColorUtils.hs new file mode 100644 --- /dev/null +++ b/src/Coin/Utils/ColorUtils.hs @@ -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) diff --git a/src/Coin/Utils/Exception.hs b/src/Coin/Utils/Exception.hs new file mode 100644 --- /dev/null +++ b/src/Coin/Utils/Exception.hs @@ -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 diff --git a/src/Coin/Utils/FileHelper.hs b/src/Coin/Utils/FileHelper.hs new file mode 100644 --- /dev/null +++ b/src/Coin/Utils/FileHelper.hs @@ -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) diff --git a/src/Coin/Utils/I18N.hs b/src/Coin/Utils/I18N.hs new file mode 100644 --- /dev/null +++ b/src/Coin/Utils/I18N.hs @@ -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 diff --git a/src/Coin/Utils/IORef.hs b/src/Coin/Utils/IORef.hs new file mode 100644 --- /dev/null +++ b/src/Coin/Utils/IORef.hs @@ -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) diff --git a/src/Coin/Utils/LocaleHelper.hs b/src/Coin/Utils/LocaleHelper.hs new file mode 100644 --- /dev/null +++ b/src/Coin/Utils/LocaleHelper.hs @@ -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 () diff --git a/src/Coin/Utils/PropertyMap.hs b/src/Coin/Utils/PropertyMap.hs new file mode 100644 --- /dev/null +++ b/src/Coin/Utils/PropertyMap.hs @@ -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 diff --git a/src/Coin/Utils/StringUtils.hs b/src/Coin/Utils/StringUtils.hs new file mode 100644 --- /dev/null +++ b/src/Coin/Utils/StringUtils.hs @@ -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) diff --git a/src/Coin/Utils/TableView.hs b/src/Coin/Utils/TableView.hs new file mode 100644 --- /dev/null +++ b/src/Coin/Utils/TableView.hs @@ -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 diff --git a/src/Coin/Utils/ValueParser.hs b/src/Coin/Utils/ValueParser.hs new file mode 100644 --- /dev/null +++ b/src/Coin/Utils/ValueParser.hs @@ -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 diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -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 diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,8 @@ +flags: + text: + integer-simple: false +packages: +- '.' +extra-deps: +- text-1.2.2.1 +resolver: lts-6.0