From a50b3a513bd03139274527d437da3caf5f9dd93a Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Mon, 15 Jun 2015 20:58:10 +0200 Subject: [PATCH 01/16] Correction : Calc.Balance : utilise Typeable1 pour supporter GHC-7.6. --- lib/Hcompta/Calc/Balance.hs | 25 +++++++++++++------------ 1 file changed, 13 insertions(+), 12 deletions(-) diff --git a/lib/Hcompta/Calc/Balance.hs b/lib/Hcompta/Calc/Balance.hs index 269ffb9..5499e58 100644 --- a/lib/Hcompta/Calc/Balance.hs +++ b/lib/Hcompta/Calc/Balance.hs @@ -4,6 +4,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} -- FIXME: to be removed when dropping GHC-7.6 support module Hcompta.Calc.Balance where import Control.Exception (assert) @@ -84,10 +85,10 @@ data Amount amount => Balance amount { balance_by_account :: Balance_by_Account amount (Amount_Unit amount) , balance_by_unit :: Balance_by_Unit amount (Amount_Unit amount) } -deriving instance Amount amount => Data (Balance amount) -deriving instance Amount amount => Eq (Balance amount) -deriving instance Amount amount => Show (Balance amount) -deriving instance Typeable Balance +deriving instance Amount amount => Data (Balance amount) +deriving instance Amount amount => Eq (Balance amount) +deriving instance Amount amount => Show (Balance amount) +deriving instance Typeable1 Balance -- FIXME: use 'Typeable' when dropping GHC-7.6 support type Balance_by_Account amount unit = TreeMap Account.Name @@ -229,10 +230,10 @@ union b0 b1 = newtype Amount amount => Deviation amount = Deviation (Balance_by_Unit amount (Amount_Unit amount)) -deriving instance Amount amount => Data (Deviation amount) -deriving instance Amount amount => Eq (Deviation amount) -deriving instance Amount amount => Show (Deviation amount) -deriving instance Typeable Deviation +deriving instance Amount amount => Data (Deviation amount) +deriving instance Amount amount => Eq (Deviation amount) +deriving instance Amount amount => Show (Deviation amount) +deriving instance Typeable1 Deviation -- FIXME: use 'Typeable' when dropping GHC-7.6 support -- | Return the 'balance_by_unit' of the given 'Balance' with: -- @@ -359,10 +360,10 @@ data Amount amount => Account_Sum_Expanded amount { exclusive :: Map (Amount_Unit amount) amount , inclusive :: Map (Amount_Unit amount) amount -- ^ 'amount_add' folded over 'exclusive' and 'inclusive' of 'Lib.TreeMap.node_descendants' } -deriving instance Amount amount => Data (Account_Sum_Expanded amount) -deriving instance Amount amount => Eq (Account_Sum_Expanded amount) -deriving instance Amount amount => Show (Account_Sum_Expanded amount) -deriving instance Typeable Account_Sum_Expanded +deriving instance Amount amount => Data (Account_Sum_Expanded amount) +deriving instance Amount amount => Eq (Account_Sum_Expanded amount) +deriving instance Amount amount => Show (Account_Sum_Expanded amount) +deriving instance Typeable1 Account_Sum_Expanded -- FIXME: use 'Typeable' when dropping GHC-7.6 support -- | Return the given 'Balance_by_Account' with: -- -- 2.47.2 From 85f19e1c3310a6c03feeef5e8e967c1e56fc7450 Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Tue, 16 Jun 2015 02:44:08 +0200 Subject: [PATCH 02/16] Correction : CLI.Command.Balance : filtres. --- cli/Hcompta/CLI/Command/Balance.hs | 61 ++++++++++++++++++------------ lib/Hcompta/Model/Filter.hs | 10 ++--- lib/Hcompta/Model/Filter/Read.hs | 18 +++++---- lib/Test/Main.hs | 40 ++++++++++++-------- 4 files changed, 77 insertions(+), 52 deletions(-) diff --git a/cli/Hcompta/CLI/Command/Balance.hs b/cli/Hcompta/CLI/Command/Balance.hs index b57a41c..cd09258 100644 --- a/cli/Hcompta/CLI/Command/Balance.hs +++ b/cli/Hcompta/CLI/Command/Balance.hs @@ -6,6 +6,7 @@ module Hcompta.CLI.Command.Balance where import Prelude hiding (foldr) -- import Control.Monad ((>=>)) +import Control.Applicative ((<$>)) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Except (runExceptT) import qualified Data.Either @@ -50,22 +51,19 @@ import qualified Hcompta.Model.Filter.Read as Filter.Read data Ctx = Ctx - { ctx_input :: [FilePath] - , ctx_redundant :: Bool - , ctx_balance_filter :: Filter.Test_Bool (Filter.Test_Balance - ( Account - , Balance.Amount_Sum Amount - )) - , ctx_posting_filter :: Filter.Test_Bool (Filter.Test_Posting Ledger.Posting) + { ctx_input :: [FilePath] + , ctx_redundant :: Bool + , ctx_transaction_filter :: Filter.Test_Bool (Filter.Test_Transaction Ledger.Transaction) + , ctx_posting_filter :: Filter.Test_Bool (Filter.Test_Posting Ledger.Posting) } deriving (Show) nil :: Ctx nil = Ctx - { ctx_input = [] - , ctx_redundant = False - , ctx_balance_filter = Filter.Any - , ctx_posting_filter = Filter.Any + { ctx_input = [] + , ctx_redundant = False + , ctx_transaction_filter = Filter.Any + , ctx_posting_filter = Filter.Any } usage :: IO String @@ -89,13 +87,13 @@ options = (ReqArg (\s _context ctx -> do return $ ctx{ctx_input=s:ctx_input ctx}) "FILE") "read data from given file, can be use multiple times" - , Option "b" ["balance-filter"] + , Option "t" ["transaction-filter"] (ReqArg (\s context ctx -> do - ctx_balance_filter <- do - case Filter.Read.read Filter.Read.test_balance s of + ctx_transaction_filter <- do + case Filter.Read.read Filter.Read.test_transaction s of Left ko -> Write.fatal context $ toDoc context ko Right ok -> return ok - return $ ctx{ctx_balance_filter}) "FILTER") + return $ ctx{ctx_transaction_filter}) "FILTER") "filter on posting" , Option "p" ["posting-filter"] (ReqArg (\s context ctx -> do @@ -135,22 +133,24 @@ run context args = do (flip mapM_) errs $ \(_path, err) -> do Write.fatal context $ toDoc context err ([], journals) -> do - (filters::[Filter.Test_Bool (Filter.Test_Transaction Ledger.Transaction)]) <- + (balance_filter:: + Filter.Test_Bool (Filter.Test_Balance + (Account, Balance.Amount_Sum Amount))) <- + foldr Filter.And Filter.Any <$> do (flip mapM) text_filters $ \s -> - case Filter.Read.read Filter.Read.test_transaction s of + case Filter.Read.read Filter.Read.test_balance s of Left ko -> Write.fatal context $ toDoc context ko Right ok -> return ok - let transaction_filter = foldr Filter.And Filter.Any filters - Write.debug context $ "transaction_filter: " ++ show transaction_filter + Write.debug context $ "balance_filter: " ++ show balance_filter + Write.debug context $ "transaction_filter: " ++ show (ctx_transaction_filter ctx) Write.debug context $ "posting_filter: " ++ show (ctx_posting_filter ctx) - Write.debug context $ "balance_filter: " ++ show (ctx_balance_filter ctx) let (balance_by_account::Balance.Balance_by_Account (Balance.Amount_Sum Amount) Amount.Unit) = foldr (Ledger.Journal.fold (flip (foldr (flip (foldr (\tr -> - case Filter.test transaction_filter tr of + case Filter.test (ctx_transaction_filter ctx) tr of False -> id True -> let filter_postings = @@ -175,7 +175,7 @@ run context args = do let balance_expanded = Lib.TreeMap.filter_with_Path (\acct -> Data.Foldable.any - (Filter.test (ctx_balance_filter ctx) . (acct,)) . + (Filter.test balance_filter . (acct,)) . Balance.inclusive) $ Balance.expanded balance_by_account style_color <- Write.with_color context IO.stdout @@ -218,10 +218,23 @@ write_by_accounts ctx = (Lib.TreeMap.node_descendants node) let is_worth = ctx_redundant ctx - || Data.Map.size + -- NOTE: worth if no descendant + -- but account inclusive + -- has at least a non-zero amount + || (Data.Map.null descendants && not + (Data.Map.null + (Data.Map.filter + (not . Amount.is_zero . Balance.amount_sum_balance) + (Balance.inclusive balance)))) + -- NOTE: worth if account exclusive + -- has at least a non-zero amount + || not (Data.Map.null (Data.Map.filter (not . Amount.is_zero . Balance.amount_sum_balance) - (Balance.exclusive balance)) > 0 + (Balance.exclusive balance))) + -- NOTE: worth if account has at least more than + -- one descendant account whose inclusive + -- has at least a non-zero amount || Data.Map.size (Data.Map.filter ( maybe False diff --git a/lib/Hcompta/Model/Filter.hs b/lib/Hcompta/Model/Filter.hs index 2c296ed..aefc3be 100644 --- a/lib/Hcompta/Model/Filter.hs +++ b/lib/Hcompta/Model/Filter.hs @@ -207,7 +207,7 @@ type Test_Account data Test_Account_Section = Test_Account_Section_Any - | Test_Account_Section_Skip + | Test_Account_Section_Many | Test_Account_Section_Text Test_Text deriving (Eq, Show, Typeable) @@ -217,19 +217,19 @@ instance Test Test_Account Account where where comp :: [Test_Account_Section] -> [Account.Name] -> Bool comp [] [] = True - comp [Test_Account_Section_Skip] _ = True - comp [] _ = True + comp [Test_Account_Section_Many] _ = True + comp [] _ = False {- comp (s:[]) (n:_) = case s of Test_Account_Section_Any -> True - Test_Account_Section_Skip -> True + Test_Account_Section_Many -> True Test_Account_Section_Text m -> test m n -} comp so@(s:ss) no@(n:ns) = case s of Test_Account_Section_Any -> comp ss ns - Test_Account_Section_Skip -> comp ss no || comp so ns + Test_Account_Section_Many -> comp ss no || comp so ns Test_Account_Section_Text m -> test m n && comp ss ns comp _ [] = False diff --git a/lib/Hcompta/Model/Filter/Read.hs b/lib/Hcompta/Model/Filter/Read.hs index 9dcbd05..b856862 100644 --- a/lib/Hcompta/Model/Filter/Read.hs +++ b/lib/Hcompta/Model/Filter/Read.hs @@ -234,19 +234,21 @@ test_account_section test_account_section make_test_text = do R.choice_try [ R.char '*' - <* R.lookAhead account_name_sep_or_eof + <* R.lookAhead account_section_end >> return Test_Account_Section_Any , R.many1 (R.satisfy (\c -> c /= account_name_sep && not (Data.Char.isSpace c))) >>= (liftM Test_Account_Section_Text . make_test_text) - , R.lookAhead account_name_sep_or_eof - >> R.many (R.try (R.char account_name_sep - >> R.lookAhead account_name_sep_or_eof)) - >> return Test_Account_Section_Skip + , R.lookAhead account_section_end + >> R.many (R.try (R.char account_name_sep >> R.lookAhead (R.try account_section_end))) + >> return Test_Account_Section_Many ] where - account_name_sep_or_eof = - (R.try (R.char account_name_sep) >> return ()) - <|> R.eof + account_section_end = + R.choice_try + [ R.char account_name_sep >> return () + , R.space_horizontal >> return () + , R.eof + ] -- ** Parse 'Test_Account' account_name_sep :: Char diff --git a/lib/Test/Main.hs b/lib/Test/Main.hs index 3e65d29..6094a95 100644 --- a/lib/Test/Main.hs +++ b/lib/Test/Main.hs @@ -17,7 +17,7 @@ import qualified Data.Map.Strict as Data.Map import Data.Text (Text) import qualified Data.Time.Calendar as Time import qualified Data.Time.LocalTime as Time -import qualified Text.Parsec as P hiding (char, string) +import qualified Text.Parsec as P hiding (char, string, space) import qualified Text.Parsec.Pos as P -- import qualified Text.PrettyPrint.Leijen.Text as PP @@ -237,12 +237,12 @@ test_Hcompta = (("A":|[]::Account)) , ": A" ~? Filter.test - [ Filter.Test_Account_Section_Skip + [ Filter.Test_Account_Section_Many ] (("A":|[]::Account)) , ":A A" ~? Filter.test - [ Filter.Test_Account_Section_Skip + [ Filter.Test_Account_Section_Many , Filter.Test_Account_Section_Text (Filter.Test_Text_Exact "A") ] @@ -251,14 +251,14 @@ test_Hcompta = Filter.test [ Filter.Test_Account_Section_Text (Filter.Test_Text_Exact "A") - , Filter.Test_Account_Section_Skip + , Filter.Test_Account_Section_Many ] (("A":|[]::Account)) , "A: A:B" ~? Filter.test [ Filter.Test_Account_Section_Text (Filter.Test_Text_Exact "A") - , Filter.Test_Account_Section_Skip + , Filter.Test_Account_Section_Many ] (("A":|"B":[]::Account)) , "A:B A:B" ~? @@ -273,22 +273,22 @@ test_Hcompta = Filter.test [ Filter.Test_Account_Section_Text (Filter.Test_Text_Exact "A") - , Filter.Test_Account_Section_Skip + , Filter.Test_Account_Section_Many , Filter.Test_Account_Section_Text (Filter.Test_Text_Exact "B") ] (("A":|"B":[]::Account)) , ":B: A:B:C" ~? Filter.test - [ Filter.Test_Account_Section_Skip + [ Filter.Test_Account_Section_Many , Filter.Test_Account_Section_Text (Filter.Test_Text_Exact "B") - , Filter.Test_Account_Section_Skip + , Filter.Test_Account_Section_Many ] (("A":|"B":"C":[]::Account)) , ":C A:B:C" ~? Filter.test - [ Filter.Test_Account_Section_Skip + [ Filter.Test_Account_Section_Many , Filter.Test_Account_Section_Text (Filter.Test_Text_Exact "C") ] @@ -327,7 +327,7 @@ test_Hcompta = (Filter.Read.test_account <* P.eof) () "" ("::A"::Text)]) ~?= - [ [ Filter.Test_Account_Section_Skip + [ [ Filter.Test_Account_Section_Many , Filter.Test_Account_Section_Text (Filter.Test_Text_Exact "A") ] ] @@ -337,7 +337,7 @@ test_Hcompta = (Filter.Read.test_account <* P.eof) () "" (":A"::Text)]) ~?= - [ [ Filter.Test_Account_Section_Skip + [ [ Filter.Test_Account_Section_Many , Filter.Test_Account_Section_Text (Filter.Test_Text_Exact "A") ] ] @@ -348,7 +348,7 @@ test_Hcompta = () "" ("A:"::Text)]) ~?= [ [ Filter.Test_Account_Section_Text (Filter.Test_Text_Exact "A") - , Filter.Test_Account_Section_Skip + , Filter.Test_Account_Section_Many ] ] , "A::" ~: @@ -358,7 +358,7 @@ test_Hcompta = () "" ("A::"::Text)]) ~?= [ [ Filter.Test_Account_Section_Text (Filter.Test_Text_Exact "A") - , Filter.Test_Account_Section_Skip + , Filter.Test_Account_Section_Many ] ] , "A:B" ~: @@ -377,7 +377,7 @@ test_Hcompta = () "" ("A::B"::Text)]) ~?= [ [ Filter.Test_Account_Section_Text (Filter.Test_Text_Exact "A") - , Filter.Test_Account_Section_Skip + , Filter.Test_Account_Section_Many , Filter.Test_Account_Section_Text (Filter.Test_Text_Exact "B") ] ] @@ -388,10 +388,20 @@ test_Hcompta = () "" ("A:::B"::Text)]) ~?= [ [ Filter.Test_Account_Section_Text (Filter.Test_Text_Exact "A") - , Filter.Test_Account_Section_Skip + , Filter.Test_Account_Section_Many , Filter.Test_Account_Section_Text (Filter.Test_Text_Exact "B") ] ] + , "A: " ~: + (Data.Either.rights $ + [P.runParser + (Filter.Read.test_account <* P.char ' ' <* P.eof) + () "" ("A: "::Text)]) + ~?= + [ [ Filter.Test_Account_Section_Text (Filter.Test_Text_Exact "A") + , Filter.Test_Account_Section_Many + ] + ] ] ] ] -- 2.47.2 From 8b216a7e00382a5995f145d2ce9c281c4db3edf8 Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Tue, 16 Jun 2015 03:00:25 +0200 Subject: [PATCH 03/16] =?utf8?q?Correction=20:=20Lib.Parsec=20:=20=C3=A9vi?= =?utf8?q?te=20une=20d=C3=A9pendance=20directe=20vers=20mtl-2.0.?= MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit --- lib/Hcompta/Lib/Parsec.hs | 2 +- lib/hcompta-lib.cabal | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/Hcompta/Lib/Parsec.hs b/lib/Hcompta/Lib/Parsec.hs index 2f45a2c..8456c65 100644 --- a/lib/Hcompta/Lib/Parsec.hs +++ b/lib/Hcompta/Lib/Parsec.hs @@ -5,8 +5,8 @@ module Hcompta.Lib.Parsec where import Control.Monad.Trans.State (StateT(..), get, put) import Control.Monad.Trans.Class (lift, MonadTrans(..)) -import Control.Monad.Identity (Identity(..)) import qualified Data.Char +import Data.Functor.Identity (Identity(..)) import qualified Data.List import qualified Text.Parsec as R hiding (satisfy, string, char, space, newline, crlf) import Text.Parsec (Stream, ParsecT, (<|>), ()) diff --git a/lib/hcompta-lib.cabal b/lib/hcompta-lib.cabal index 69dca38..0848f8d 100644 --- a/lib/hcompta-lib.cabal +++ b/lib/hcompta-lib.cabal @@ -92,7 +92,7 @@ Library , HUnit , integer-gmp -- , lens - , mtl >= 2.0 + -- , mtl >= 2.0 , parsec >= 3.1.2 && < 4 -- NOTE: needed for Text.Parsec.Text , regex-base -- 2.47.2 From 12213243390b647abee81d62f0bf2830683434d6 Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Tue, 16 Jun 2015 05:33:29 +0200 Subject: [PATCH 04/16] =?utf8?q?Suppression=20:=20Lib.Foldable=20:=20Compo?= =?utf8?q?sition=20d=C3=A9j=C3=A0=20dans=20Data.Functor.Compose.?= MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit --- lib/Hcompta/Format/Ledger/Write.hs | 5 +++-- lib/Hcompta/Lib/Foldable.hs | 15 --------------- lib/Hcompta/Model/Filter.hs | 4 ++-- 3 files changed, 5 insertions(+), 19 deletions(-) diff --git a/lib/Hcompta/Format/Ledger/Write.hs b/lib/Hcompta/Format/Ledger/Write.hs index db5b214..6c31692 100644 --- a/lib/Hcompta/Format/Ledger/Write.hs +++ b/lib/Hcompta/Format/Ledger/Write.hs @@ -11,6 +11,7 @@ import Control.Applicative ((<$>), (<*)) import Data.Decimal (DecimalRaw(..)) import qualified Data.Char (isSpace) import Data.Fixed (showFixed) +import qualified Data.Functor.Compose import qualified Data.Foldable import Data.Foldable (Foldable) import qualified Data.List @@ -375,7 +376,7 @@ postings_lengths type_ ps pl = ( account_length type_ (posting_account p) + amounts_length (posting_amounts p) ) ) pl - (Lib.Foldable.Composition ps) + (Data.Functor.Compose.Compose ps) -- * Printing 'Transaction' @@ -467,7 +468,7 @@ transaction_lengths journal :: Journal -> Doc journal Journal { journal_transactions } = - transactions (Lib.Foldable.Composition journal_transactions) + transactions (Data.Functor.Compose.Compose journal_transactions) -- * Rendering diff --git a/lib/Hcompta/Lib/Foldable.hs b/lib/Hcompta/Lib/Foldable.hs index bbd9561..ba668c9 100644 --- a/lib/Hcompta/Lib/Foldable.hs +++ b/lib/Hcompta/Lib/Foldable.hs @@ -37,18 +37,3 @@ accumLeftsAndFoldrRights f rempty m = where left a ~(l, r) = (a`mappend`l, r) right a ~(l, r) = (l, f a r) - --- | Type composition. --- --- NOTE: this could eventually be replaced by --- adding a dependency on --- -newtype Composition g f a = Composition (g (f a)) - --- | A 'Foldable' of a 'Foldable' is itself a 'Foldable'. -instance (Foldable f1, Foldable f2) - => Foldable (Composition f1 f2) where - foldr f acc (Composition o) = - Data.Foldable.foldr - (flip $ Data.Foldable.foldr f) - acc o diff --git a/lib/Hcompta/Model/Filter.hs b/lib/Hcompta/Model/Filter.hs index aefc3be..6a7298f 100644 --- a/lib/Hcompta/Model/Filter.hs +++ b/lib/Hcompta/Model/Filter.hs @@ -11,6 +11,7 @@ import Control.Applicative (pure, (<$>), (<*>)) import Data.Data import qualified Data.Foldable import Data.Foldable (Foldable(..)) +import qualified Data.Functor.Compose import Data.Traversable (Traversable(..)) import Data.Monoid (Monoid(..)) import Data.Typeable () @@ -25,7 +26,6 @@ import Text.Regex.TDFA.Text () import qualified Data.List.NonEmpty as NonEmpty -- import Data.List.NonEmpty (NonEmpty(..)) import qualified Hcompta.Lib.Regex as Regex -import qualified Hcompta.Lib.Foldable as Lib.Foldable import Hcompta.Lib.Regex (Regex) import qualified Hcompta.Model.Date as Date () import Hcompta.Model.Date (Date) @@ -307,7 +307,7 @@ instance Transaction t test f $ transaction_description t test (Test_Transaction_Posting f) t = Data.Foldable.any (test f) $ - Lib.Foldable.Composition $ + Data.Functor.Compose.Compose $ transaction_postings t -- ** Type 'Test_Balance' -- 2.47.2 From a173d0820b634d09744b284c1a85e3965f9ad134 Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Wed, 17 Jun 2015 03:56:54 +0200 Subject: [PATCH 05/16] =?utf8?q?Modif=20:=20CLI.Lang=20:=20utilise=20la=20?= =?utf8?q?classe=20ToDoc=20pour=20g=C3=A9rer=20les=20traductions.?= MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit --- cli/Hcompta/CLI/Command.hs | 8 +- cli/Hcompta/CLI/Command/Balance.hs | 20 +- cli/Hcompta/CLI/Command/Print.hs | 5 +- cli/Hcompta/CLI/Context.hs | 32 +-- cli/Hcompta/CLI/Format/Ledger.hs | 135 ++----------- cli/Hcompta/CLI/I18N.hs | 190 ------------------ cli/Hcompta/CLI/Lang.hs | 303 +++++++++++++++++++++++++++++ cli/Hcompta/CLI/Write.hs | 11 +- cli/hcompta-cli.cabal | 2 +- cli/i18n/en.msg | 23 --- cli/i18n/fr.msg | 23 --- lib/Hcompta/Format/Ledger/Read.hs | 160 ++------------- lib/Hcompta/Format/Ledger/Write.hs | 1 - lib/Hcompta/Lib/Parsec.hs | 52 ++++- lib/Hcompta/Model/Date.hs | 1 + lib/Hcompta/Model/Date/Read.hs | 169 ++++++++++++++++ lib/Hcompta/Model/Filter/Read.hs | 24 +-- lib/Test/Main.hs | 21 +- lib/hcompta-lib.cabal | 2 + 19 files changed, 608 insertions(+), 574 deletions(-) delete mode 100644 cli/Hcompta/CLI/I18N.hs create mode 100644 cli/Hcompta/CLI/Lang.hs delete mode 100644 cli/i18n/en.msg delete mode 100644 cli/i18n/fr.msg create mode 100644 lib/Hcompta/Model/Date/Read.hs diff --git a/cli/Hcompta/CLI/Command.hs b/cli/Hcompta/CLI/Command.hs index 0481d66..107c180 100644 --- a/cli/Hcompta/CLI/Command.hs +++ b/cli/Hcompta/CLI/Command.hs @@ -3,6 +3,7 @@ {-# LANGUAGE TupleSections #-} module Hcompta.CLI.Command where +import Data.Maybe (fromMaybe) import qualified Data.Text.Lazy as TL import System.Console.GetOpt ( ArgDescr(..) @@ -17,6 +18,7 @@ import qualified Hcompta.CLI.Args as Args import qualified Hcompta.CLI.Command.Balance as Command.Balance import qualified Hcompta.CLI.Command.Print as Command.Print import qualified Hcompta.CLI.Context as Context +import qualified Hcompta.CLI.Lang as Lang import qualified Hcompta.CLI.Write as Write import qualified Hcompta.Lib.Leijen as W import Hcompta.Lib.Leijen ((<>)) @@ -72,8 +74,10 @@ options = "colorize output" , Option "" ["lang"] (ReqArg (\lang _context context -> do - return $ context{Context.langs= - lang:Context.langs context}) + return $ context{Context.lang = + fromMaybe (Context.lang context) $ + Lang.lang_of_strings [lang] + }) "[xx|xx-XX]") "RFC1766 / ISO 639-1 language code (eg, fr, en-GB, etc.)" ] diff --git a/cli/Hcompta/CLI/Command/Balance.hs b/cli/Hcompta/CLI/Command/Balance.hs index cd09258..fd776ae 100644 --- a/cli/Hcompta/CLI/Command/Balance.hs +++ b/cli/Hcompta/CLI/Command/Balance.hs @@ -30,7 +30,7 @@ import qualified Hcompta.Calc.Balance as Balance import qualified Hcompta.CLI.Args as Args import qualified Hcompta.CLI.Context as Context import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger -import qualified Hcompta.CLI.I18N as I18N +import qualified Hcompta.CLI.Lang as Lang import qualified Hcompta.CLI.Lib.Leijen.Table as Table import qualified Hcompta.CLI.Write as Write import qualified Hcompta.Format.Ledger as Ledger @@ -91,7 +91,7 @@ options = (ReqArg (\s context ctx -> do ctx_transaction_filter <- do case Filter.Read.read Filter.Read.test_transaction s of - Left ko -> Write.fatal context $ toDoc context ko + Left ko -> Write.fatal context $ ko Right ok -> return ok return $ ctx{ctx_transaction_filter}) "FILTER") "filter on posting" @@ -99,7 +99,7 @@ options = (ReqArg (\s context ctx -> do ctx_posting_filter <- do case Filter.Read.read Filter.Read.test_posting s of - Left ko -> Write.fatal context $ toDoc context ko + Left ko -> Write.fatal context $ ko Right ok -> return ok return $ ctx{ctx_posting_filter}) "FILTER") "filter on balance" @@ -131,7 +131,7 @@ run context args = do case read_journals of (errs@(_:_), _journals) -> (flip mapM_) errs $ \(_path, err) -> do - Write.fatal context $ toDoc context err + Write.fatal context $ err ([], journals) -> do (balance_filter:: Filter.Test_Bool (Filter.Test_Balance @@ -139,7 +139,7 @@ run context args = do foldr Filter.And Filter.Any <$> do (flip mapM) text_filters $ \s -> case Filter.Read.read Filter.Read.test_balance s of - Left ko -> Write.fatal context $ toDoc context ko + Left ko -> Write.fatal context $ ko Right ok -> return ok Write.debug context $ "balance_filter: " ++ show balance_filter Write.debug context $ "transaction_filter: " ++ show (ctx_transaction_filter ctx) @@ -185,12 +185,12 @@ run context args = do } IO.stdout $ do toDoc () $ let title = TL.toStrict . W.displayT . W.renderCompact False . - I18N.render (Context.langs context) in + toDoc (Context.lang context) in zipWith id - [ Table.column (title I18N.Message_Balance_debit) Table.Align_Right - , Table.column (title I18N.Message_Balance_credit) Table.Align_Right - , Table.column (title I18N.Message_Balance_total) Table.Align_Right - , Table.column (title I18N.Message_Account) Table.Align_Left + [ Table.column (title Lang.Message_Balance_debit) Table.Align_Right + , Table.column (title Lang.Message_Balance_credit) Table.Align_Right + , Table.column (title Lang.Message_Balance_total) Table.Align_Right + , Table.column (title Lang.Message_Account) Table.Align_Left ] $ flip (write_by_accounts ctx) balance_expanded $ zipWith (:) diff --git a/cli/Hcompta/CLI/Command/Print.hs b/cli/Hcompta/CLI/Command/Print.hs index d184370..3f3a32b 100644 --- a/cli/Hcompta/CLI/Command/Print.hs +++ b/cli/Hcompta/CLI/Command/Print.hs @@ -28,7 +28,6 @@ import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal import qualified Hcompta.Format.Ledger.Read as Ledger.Read import qualified Hcompta.Format.Ledger.Write as Ledger.Write import qualified Hcompta.Lib.Leijen as W -import Hcompta.Lib.Leijen (toDoc, ToDoc(..)) import qualified Hcompta.Model.Filter as Filter import qualified Hcompta.Model.Filter.Read as Filter.Read @@ -94,12 +93,12 @@ run context args = do case read_journals of (errs@(_:_), _journals) -> (flip mapM_) errs $ \(_path, err) -> do - Write.fatal context $ toDoc context err + Write.fatal context $ err ([], journals) -> do (filters::[Filter.Test_Bool (Filter.Test_Transaction Ledger.Transaction)]) <- (flip mapM) text_filters $ \s -> case Filter.Read.read Filter.Read.test_transaction s of - Left ko -> Write.fatal context $ toDoc context ko + Left ko -> Write.fatal context $ ko Right ok -> return ok Write.debug context $ show filters style_color <- Write.with_color context IO.stdout diff --git a/cli/Hcompta/CLI/Context.hs b/cli/Hcompta/CLI/Context.hs index e43bb8f..01493fa 100644 --- a/cli/Hcompta/CLI/Context.hs +++ b/cli/Hcompta/CLI/Context.hs @@ -1,12 +1,9 @@ {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} module Hcompta.CLI.Context where -import Control.Monad (liftM) -import qualified Data.List -import Data.Maybe (catMaybes) -import System.Environment (getEnvironment) -import System.IO.Memoize (once) +import Hcompta.CLI.Lang data App = App @@ -15,18 +12,18 @@ data Context { verbosity :: Verbosity , command :: String , color :: Maybe Bool - , langs :: [String] + , lang :: Lang } deriving (Show) context :: IO Context context = do - langs <- get_langs + lang <- get_lang return $ Context { verbosity = Verbosity_Info , command = "" , color = Nothing - , langs + , lang } data Verbosity @@ -36,22 +33,3 @@ data Verbosity | Verbosity_Debug deriving (Bounded, Enum, Eq, Ord, Show) --- TODO: check that this is expected behavior --- and portability issues -get_langs :: IO [String] -get_langs = do - once getEnvironment - >>= liftM (\env -> - Data.List.concatMap - ((\lang -> - let short = takeWhile ('_' /=) lang in - if short == lang - then [lang] - else [lang, short]) - . Data.List.takeWhile (\c -> c /= '.') ) $ - catMaybes - [ Data.List.lookup "LC_ALL" env - , Data.List.lookup "LC_CTYPE" env - , Data.List.lookup "LANG" env - , Just "en" - ]) diff --git a/cli/Hcompta/CLI/Format/Ledger.hs b/cli/Hcompta/CLI/Format/Ledger.hs index bd12508..da5dd4c 100644 --- a/cli/Hcompta/CLI/Format/Ledger.hs +++ b/cli/Hcompta/CLI/Format/Ledger.hs @@ -6,25 +6,20 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Hcompta.CLI.Format.Ledger where -import Prelude hiding (error) import Control.Exception (tryJust) import Control.Monad (guard) import qualified Data.List import qualified Data.Text.Lazy as TL import System.Environment as Env (getEnv) import System.IO.Error (isDoesNotExistError) -import qualified Text.Parsec as Parsec -import qualified Text.Parsec.Error as Parsec.Error import qualified Hcompta.Lib.Leijen as W -import Hcompta.Lib.Leijen (ToDoc(..), (<>)) -import qualified Hcompta.Lib.Parsec as Lib.Parsec +import Hcompta.Lib.Leijen (ToDoc(..)) import qualified Hcompta.Calc.Balance as Calc.Balance import qualified Hcompta.CLI.Context as Context -import Hcompta.CLI.Context (Context) -import qualified Hcompta.CLI.I18N as I18N +import qualified Hcompta.CLI.Lang as Lang +import Hcompta.CLI.Lang (Lang) import qualified Hcompta.CLI.Write as Write -import qualified Hcompta.Model.Filter.Read as Filter.Read import qualified Hcompta.Format.Ledger.Read as Ledger.Read import qualified Hcompta.Format.Ledger.Write as Ledger.Write import qualified Hcompta.Model.Amount as Amount @@ -44,132 +39,42 @@ paths context [] = do >>= \xx -> case xx of Right ok -> return [ok] Left _ko -> do - let langs = Context.langs context + let lang = Context.lang context Write.fatal context $ - I18N.render langs - I18N.Message_no_ledger_file_given + toDoc lang $ Lang.Message_no_ledger_file_given paths _context ps = return ps -instance ToDoc Context Parsec.SourcePos where - toDoc context pos = do - let langs = Context.langs context - I18N.render langs $ do - case Parsec.sourceName pos of - "" -> I18N.Message_at - (Parsec.sourceLine pos) - (Parsec.sourceColumn pos) - path -> I18N.Message_in_file path - (Parsec.sourceLine pos) - (Parsec.sourceColumn pos) - -instance ToDoc Context e => ToDoc Context [Lib.Parsec.Error e] where - toDoc context errors = - W.vsep $ do - (flip map) errors $ (\error -> - case error of - Lib.Parsec.Error_At pos errs -> W.vsep $ - [ toDoc context pos - , toDoc context errs - ] - Lib.Parsec.Error_Parser err -> - W.vsep $ - [ toDoc context (Parsec.errorPos err) - , showErrorMessages - (Parsec.Error.errorMessages err) - ] - Lib.Parsec.Error_Custom pos err -> W.vsep $ - [ toDoc context pos - , toDoc context err - ] - ) - where - langs = Context.langs context - showErrorMessages :: [Parsec.Error.Message] -> W.Doc - showErrorMessages msgs - | null msgs = i18n $ I18N.Message_unknown - | otherwise = W.vsep $ -- clean $ - [showSysUnExpect, showUnExpect, showExpect, showMessages] - where - i18n = I18N.render langs - (sysUnExpect,msgs1) = span ((Parsec.Error.SysUnExpect "") ==) msgs - (unExpect,msgs2) = span ((Parsec.Error.UnExpect "") ==) msgs1 - (expect,messages) = span ((Parsec.Error.Expect "") ==) msgs2 - - showExpect = showMany (Just (i18n . I18N.Message_expect)) expect - showUnExpect = showMany (Just (i18n . I18N.Message_unexpect)) unExpect - showSysUnExpect - | not (null unExpect) || null sysUnExpect = W.empty - | null firstMsg = i18n $ I18N.Message_sysunexpect_end_of_input - | otherwise = i18n $ I18N.Message_sysunexpect firstMsg - where - firstMsg = Parsec.Error.messageString (head sysUnExpect) - - showMessages = showMany Nothing messages - - -- helpers - showMany :: (Maybe (W.Doc -> W.Doc)) -> [Parsec.Error.Message] -> W.Doc - showMany pre msgs_ = - case clean (map Parsec.Error.messageString msgs_) of - [] -> W.empty - ms -> - case pre of - Nothing -> commasOr ms - Just p -> p $ commasOr ms - - commasOr :: [String] -> W.Doc - commasOr [] = W.empty - commasOr [m] = W.text $ TL.pack m - commasOr ms = commaSep (init ms) - <> (W.space <> i18n I18N.Message_or <> W.space) - <> (W.bold $ W.dullblack $ W.text $ TL.pack $ last ms) - commaSep = W.intercalate (W.comma <> W.space) - (W.bold . W.dullblack . W.text . TL.pack) - . clean - - clean = Data.List.nub . filter (not . null) - -instance ToDoc Context Ledger.Read.Error where - toDoc context err = +instance ToDoc Lang Ledger.Read.Error where + toDoc lang err = case err of - Ledger.Read.Error_year_or_day_is_missing -> - I18N.render langs $ I18N.Message_year_or_day_is_missing - Ledger.Read.Error_invalid_date (y, m, d) -> - I18N.render langs $ I18N.Message_invalid_date y m d - Ledger.Read.Error_invalid_time_of_day (h, m, s) -> - I18N.render langs $ I18N.Message_invalid_time_of_day h m s + Ledger.Read.Error_date date -> toDoc lang date Ledger.Read.Error_transaction_not_equilibrated tr unit_sums -> i18n_transaction_not_equilibrated tr unit_sums - I18N.Message_the_following_transaction_is_not_equilibrated_because + Lang.Message_the_following_transaction_is_not_equilibrated_because Ledger.Read.Error_virtual_transaction_not_equilibrated tr unit_sums -> i18n_transaction_not_equilibrated tr unit_sums - I18N.Message_the_following_virtual_transaction_is_not_equilibrated_because - Ledger.Read.Error_reading_file file_path exn -> W.vsep $ - [ I18N.render langs $ - I18N.Message_failed_to_read_file file_path + Lang.Message_the_following_virtual_transaction_is_not_equilibrated_because + Ledger.Read.Error_reading_file file_path exn -> + W.vsep $ + [ toDoc lang $ Lang.Message_failed_to_read_file file_path , W.text $ TL.pack $ show exn ] - Ledger.Read.Error_including_file file_path errs -> W.vsep $ - [ I18N.render langs $ - I18N.Message_failed_to_include_file file_path - , toDoc context errs + Ledger.Read.Error_including_file file_path errs -> + W.vsep $ + [ toDoc lang $ Lang.Message_failed_to_include_file file_path + , toDoc lang errs ] where - langs = Context.langs context i18n_transaction_not_equilibrated tr unit_sums msg = W.vsep $ - [ I18N.render langs msg + [ toDoc lang msg , W.vsep $ Data.List.map (\Calc.Balance.Unit_Sum{Calc.Balance.unit_sum_amount} -> let amt = Calc.Balance.amount_sum_balance unit_sum_amount in - I18N.render langs $ - I18N.Message_unit_sums_up_to_the_non_null_amount + toDoc lang $ + Lang.Message_unit_sums_up_to_the_non_null_amount (Amount.unit amt) amt ) unit_sums , W.space , Ledger.Write.transaction tr ] - -instance ToDoc Context Filter.Read.Error where - toDoc context err = - case err of - Filter.Read.Error_Unknown -> toDoc context ("error"::String) diff --git a/cli/Hcompta/CLI/I18N.hs b/cli/Hcompta/CLI/I18N.hs deleted file mode 100644 index 694f683..0000000 --- a/cli/Hcompta/CLI/I18N.hs +++ /dev/null @@ -1,190 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Hcompta.CLI.I18N where - -import qualified Data.Text -import Data.Text (Text) --- import qualified Data.Monoid - -import qualified Hcompta.Format.Ledger.Write as Ledger.Write -import Hcompta.Model.Amount.Unit (Unit) -import Hcompta.Model.Amount (Amount) -import qualified Hcompta.Lib.Leijen as W -import Hcompta.Lib.Leijen (ToDoc(..), (<>)) - -(#) :: ToDoc () a => a -> W.Doc -(#) = toDoc () - -instance ToDoc m Text where - toDoc _ = W.strict_text -instance ToDoc m String where - toDoc _ = W.strict_text . Data.Text.pack -instance ToDoc m Int where - toDoc _ = W.int -instance ToDoc m Integer where - toDoc _ = W.integer -instance ToDoc m Unit where - toDoc _ = Ledger.Write.unit -instance ToDoc m Amount where - toDoc _ = Ledger.Write.amount - -data Message - = Message_ERROR - | Message_no_ledger_file_given - | Message_at - {message_line :: Int - ,message_col :: Int - } - | Message_in_file - {message_path :: FilePath - ,message_line :: Int - ,message_col :: Int - } - | Message_failed_to_read_file - {message_path :: FilePath} - | Message_failed_to_include_file - {message_path :: FilePath} - | Message_the_following_transaction_is_not_equilibrated_because {} - | Message_the_following_virtual_transaction_is_not_equilibrated_because {} - | Message_unit_sums_up_to_the_non_null_amount - {message_Unit :: Unit - ,message_Amount :: Amount} - | Message_year_or_day_is_missing {} - | Message_invalid_date - {message_Year :: Integer - ,message_Month :: Int - ,message_Day :: Int - } - | Message_invalid_time_of_day - { message_Hour :: Int - , message_Month :: Int - , message_Second :: Integer - } - | Message_unexpect {message_Doc :: W.Doc} - | Message_sysunexpect {message_Msg :: String} - | Message_expect {message_Doc :: W.Doc} - | Message_message {message_Msg :: String} - | Message_sysunexpect_end_of_input {} - | Message_unknown {} - | Message_or {} - | Message_Balance_total {} - | Message_Balance_debit {} - | Message_Balance_credit {} - | Message_Account {} - -type Lang = String - -render :: [Lang] -> Message -> W.Doc -render ("fr" :_) = render_fr_FR -render ("fr_FR":_) = render_fr_FR -render ("en" :_) = render_en_US -render ("en_US":_) = render_en_US -render (_:xs) = render xs -render _ = render_en_US - -render_en_US :: Message -> W.Doc -render_en_US m = - case m of - Message_ERROR -> - "ERROR" - Message_no_ledger_file_given -> - "no ledger file given, please use:" <> W.line <> - "- either -i FILE parameter" <> W.line <> - "- or LEDGER_FILE environment variable." - Message_at line col -> - "(line " <> (#)line <> ", column " <> (#)col <> ")" - Message_in_file path line col -> - "(line " <> (#)line <> ", column " <> (#)col <> ") in: " <> (#)path - Message_failed_to_read_file path -> - "failed to read file: " <> (#)path - Message_failed_to_include_file path -> - "failed to include file: " <> (#)path - Message_the_following_transaction_is_not_equilibrated_because -> - "the following transaction is not equilibrated, because:" - Message_the_following_virtual_transaction_is_not_equilibrated_because -> - "the following virtual transaction is not equilibrated, because:" - Message_unit_sums_up_to_the_non_null_amount unit amount -> - " - unit " <> (#)unit <> " sums up to the non-null amount: " <> (#)amount - Message_year_or_day_is_missing -> - "year or day is missing" - Message_invalid_date year month day -> - "invalid date (year " <> (#)year <> ", month " <> (#)month <> ", day " <> (#)day <> ")" - Message_invalid_time_of_day hour minute second -> - "invalid time of day (hour " <> (#)hour <> ", minute " <> (#)minute <> ", second " <> (#)second <> ")" - Message_unexpect doc -> - "found : " <> (#)doc - Message_sysunexpect doc -> - "is written : " <> (#)doc - Message_expect doc -> - "but expect : " <> (#)doc - Message_message doc -> - (#)doc - Message_sysunexpect_end_of_input -> - "end of file unexpected" - Message_unknown -> - "unkown" - Message_or -> - "or" - Message_Balance_total -> - "Balance" - Message_Balance_debit -> - "Debit" - Message_Balance_credit -> - "Credit" - Message_Account -> - "Account" - -render_fr_FR :: Message -> W.Doc -render_fr_FR m = - case m of - Message_ERROR -> - "ERREUR" - Message_no_ledger_file_given -> - "aucun fichier indiqué, veuillez utiliser :" <> W.line <> - " - soit le paramètre -i FICHIER," <> W.line <> - " - soit la variable d’environnement LEDGER_FILE." - Message_at line col -> - "(ligne " <> (#)line <> ", colonne " <> (#)col <> ")" - Message_in_file path line col -> - "(ligne " <> (#)line <> ", colonne " <> (#)col <> ") dans : " <> (#)path - Message_failed_to_read_file path -> - "échec de la lecture du fichier : " <> (#)path - Message_failed_to_include_file path -> - "échec à l’inclusion du fichier : " <> (#)path - Message_the_following_transaction_is_not_equilibrated_because -> - "la transaction suivante n’est pas équilibrée, car :" - Message_the_following_virtual_transaction_is_not_equilibrated_because -> - "la transaction virtuelle suivante n’est pas équilibrée, car :" - Message_unit_sums_up_to_the_non_null_amount unit amount -> - " - l’unité " <> (#)unit <> " a le solde non-nul : " <> (#)amount - Message_year_or_day_is_missing -> - "l’année ou le jour est manquant-e" - Message_invalid_date year month day -> - "date incorrecte (année " <> (#)year <> ", mois " <> (#)month <> ", jour " <> (#)day <> ")" - Message_invalid_time_of_day hour minute second -> - "heure incorrecte (heure " <> (#)hour <> ", minute " <> (#)minute <> ", seconde " <> (#)second <> ")" - Message_unexpect doc -> - "trouve : " <> (#)doc - Message_sysunexpect doc -> - "est écrit : " <> (#)doc - Message_expect doc -> - "mais s’attend à : " <> (#)doc - Message_message doc -> - (#)doc - Message_sysunexpect_end_of_input -> - "fin de fichier inattendue" - Message_unknown -> - "inconnu" - Message_or -> - "ou" - Message_Balance_total -> - "Solde" - Message_Balance_debit -> - "Débit" - Message_Balance_credit -> - "Crédit" - Message_Account -> - "Compte" diff --git a/cli/Hcompta/CLI/Lang.hs b/cli/Hcompta/CLI/Lang.hs new file mode 100644 index 0000000..9d122f4 --- /dev/null +++ b/cli/Hcompta/CLI/Lang.hs @@ -0,0 +1,303 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Hcompta.CLI.Lang where + +import Prelude hiding (error) +import Control.Monad (liftM) +import qualified Data.List +import Data.Maybe (catMaybes, fromMaybe) +import qualified Data.Text +import Data.Text (Text) +import qualified Data.Text.Lazy as TL +import System.Environment (getEnvironment) +import System.IO.Memoize (once) +import qualified Text.Parsec as Parsec +import qualified Text.Parsec.Error as Parsec.Error + +import qualified Hcompta.Format.Ledger.Write as Ledger.Write +import Hcompta.Model.Amount.Unit (Unit) +import Hcompta.Model.Amount (Amount) +import qualified Hcompta.Model.Date.Read as Date.Read +import qualified Hcompta.Model.Filter.Read as Filter.Read +import qualified Hcompta.Lib.Leijen as W +import Hcompta.Lib.Leijen (ToDoc(..), (<>)) +import qualified Hcompta.Lib.Parsec as Lib.Parsec + +data Lang + = FR + | EN + deriving (Show) + +-- TODO: check that this is expected behavior +-- and portability issues +get_lang :: IO Lang +get_lang = do + once getEnvironment + >>= liftM (\env -> + fromMaybe EN $ lang_of_strings $ + Data.List.concatMap + ((\lang -> + let short = takeWhile ('_' /=) lang in + if short == lang + then [lang] + else [lang, short]) + . Data.List.takeWhile (\c -> c /= '.') ) $ + catMaybes + [ Data.List.lookup "LC_ALL" env + , Data.List.lookup "LC_CTYPE" env + , Data.List.lookup "LANG" env + ]) + +lang_of_strings :: [String] -> Maybe Lang +lang_of_strings s = + case s of + ("fr" :_) -> Just $ FR + ("fr_FR":_) -> Just $ FR + ("en" :_) -> Just $ EN + ("en_US":_) -> Just $ EN + (_:xs) -> lang_of_strings xs + [] -> Nothing + +(#) :: ToDoc () a => a -> W.Doc +(#) = toDoc () + +instance ToDoc m Text where + toDoc _ = W.strict_text +instance ToDoc m String where + toDoc _ = W.strict_text . Data.Text.pack +instance ToDoc m Int where + toDoc _ = W.int +instance ToDoc m Integer where + toDoc _ = W.integer +instance ToDoc m Unit where + toDoc _ = Ledger.Write.unit +instance ToDoc m Amount where + toDoc _ = Ledger.Write.amount +instance ToDoc Lang Date.Read.Error where + toDoc FR Date.Read.Error_year_or_day_is_missing = + "l’année ou le jour est manquant·e" + toDoc FR (Date.Read.Error_invalid_date (year, month, day)) = + "date incorrecte (année " <> (#)year <> ", mois " <> (#)month <> ", jour " <> (#)day <> ")" + toDoc FR (Date.Read.Error_invalid_time_of_day (hour, minute, second)) = + "heure incorrecte (heure " <> (#)hour <> ", minute " <> (#)minute <> ", seconde " <> (#)second <> ")" + toDoc EN Date.Read.Error_year_or_day_is_missing = + "year or day is missing" + toDoc EN (Date.Read.Error_invalid_date (year, month, day)) = + "invalid date (year " <> (#)year <> ", month " <> (#)month <> ", day " <> (#)day <> ")" + toDoc EN (Date.Read.Error_invalid_time_of_day (hour, minute, second)) = + "invalid time of day (hour " <> (#)hour <> ", minute " <> (#)minute <> ", second " <> (#)second <> ")" +instance ToDoc Lang Parsec.SourcePos where + toDoc EN pos = do + let line = Parsec.sourceLine pos + let col = Parsec.sourceColumn pos + case Parsec.sourceName pos of + "" -> "(line " <> (#)line <> ", column " <> (#)col <> ")" + path -> "(line " <> (#)line <> ", column " <> (#)col <> ") in: " <> (#)path + toDoc FR pos = do + let line = Parsec.sourceLine pos + let col = Parsec.sourceColumn pos + case Parsec.sourceName pos of + "" -> "(ligne " <> (#)line <> ", colonne " <> (#)col <> ")" + path -> "(ligne " <> (#)line <> ", colonne " <> (#)col <> ") dans : " <> (#)path +instance ToDoc Lang e + => ToDoc Lang [Lib.Parsec.Error e] where + toDoc lang errors = + W.vsep $ do + (flip map) errors $ (\error -> + case error of + Lib.Parsec.Error_At pos errs -> W.vsep $ + [ toDoc lang pos + , toDoc lang errs + ] + Lib.Parsec.Error_Parser err -> + W.vsep $ + [ toDoc lang (Parsec.errorPos err) + , showErrorMessages + (Parsec.Error.errorMessages err) + ] + Lib.Parsec.Error_Custom pos err -> W.vsep $ + [ toDoc lang pos + , toDoc lang err + ] + ) + where + showErrorMessages :: [Parsec.Error.Message] -> W.Doc + showErrorMessages msgs + | null msgs = toDoc lang $ Message_unknown + | otherwise = W.vsep $ -- clean $ + [showSysUnExpect, showUnExpect, showExpect, showMessages] + where + (sysUnExpect,msgs1) = span ((Parsec.Error.SysUnExpect "") ==) msgs + (unExpect,msgs2) = span ((Parsec.Error.UnExpect "") ==) msgs1 + (expect,messages) = span ((Parsec.Error.Expect "") ==) msgs2 + + showExpect = showMany (Just (toDoc lang . Message_expect)) expect + showUnExpect = showMany (Just (toDoc lang . Message_unexpect)) unExpect + showSysUnExpect + | not (null unExpect) || null sysUnExpect = W.empty + | null firstMsg = toDoc lang $ Message_sysunexpect_end_of_input + | otherwise = toDoc lang $ Message_sysunexpect firstMsg + where + firstMsg = Parsec.Error.messageString (head sysUnExpect) + + showMessages = showMany Nothing messages + + -- helpers + showMany :: (Maybe (W.Doc -> W.Doc)) -> [Parsec.Error.Message] -> W.Doc + showMany pre msgs_ = + case clean (map Parsec.Error.messageString msgs_) of + [] -> W.empty + ms -> + case pre of + Nothing -> commasOr ms + Just p -> p $ commasOr ms + + commasOr :: [String] -> W.Doc + commasOr [] = W.empty + commasOr [m] = W.bold $ W.dullblack $ W.text $ TL.pack m + commasOr ms = commaSep (init ms) + <> (W.space <> toDoc lang Message_or <> W.space) + <> (W.bold $ W.dullblack $ W.text $ TL.pack $ last ms) + commaSep = W.intercalate (W.comma <> W.space) + (W.bold . W.dullblack . W.text . TL.pack) + . clean + + clean = Data.List.nub . filter (not . null) +instance ToDoc Lang Filter.Read.Error where + toDoc FR err = + case err of + Filter.Read.Error_Unknown -> "erreur" + toDoc EN err = + case err of + Filter.Read.Error_Unknown -> "error" + +data Message + = Message_ERROR + | Message_no_ledger_file_given + | Message_failed_to_read_file + {message_path :: FilePath} + | Message_failed_to_include_file + {message_path :: FilePath} + | Message_the_following_transaction_is_not_equilibrated_because {} + | Message_the_following_virtual_transaction_is_not_equilibrated_because {} + | Message_unit_sums_up_to_the_non_null_amount + {message_Unit :: Unit + ,message_Amount :: Amount} + | Message_year_or_day_is_missing {} + | Message_invalid_date + {message_Year :: Integer + ,message_Month :: Int + ,message_Day :: Int + } + | Message_invalid_time_of_day + { message_Hour :: Int + , message_Month :: Int + , message_Second :: Integer + } + | Message_unexpect {message_Doc :: W.Doc} + | Message_sysunexpect {message_Msg :: String} + | Message_expect {message_Doc :: W.Doc} + | Message_message {message_Msg :: String} + | Message_sysunexpect_end_of_input {} + | Message_unknown {} + | Message_or {} + | Message_Balance_total {} + | Message_Balance_debit {} + | Message_Balance_credit {} + | Message_Account {} +instance ToDoc Lang Message where + toDoc EN msg = + case msg of + Message_ERROR -> + "ERROR" + Message_no_ledger_file_given -> + "no ledger file given, please use:" <> W.line <> + "- either -i FILE parameter" <> W.line <> + "- or LEDGER_FILE environment variable." + Message_failed_to_read_file path -> + "failed to read file: " <> (#)path + Message_failed_to_include_file path -> + "failed to include file: " <> (#)path + Message_the_following_transaction_is_not_equilibrated_because -> + "the following transaction is not equilibrated, because:" + Message_the_following_virtual_transaction_is_not_equilibrated_because -> + "the following virtual transaction is not equilibrated, because:" + Message_unit_sums_up_to_the_non_null_amount unit amount -> + " - unit " <> (#)unit <> " sums up to the non-null amount: " <> (#)amount + Message_year_or_day_is_missing -> + "year or day is missing" + Message_invalid_date year month day -> + "invalid date (year " <> (#)year <> ", month " <> (#)month <> ", day " <> (#)day <> ")" + Message_invalid_time_of_day hour minute second -> + "invalid time of day (hour " <> (#)hour <> ", minute " <> (#)minute <> ", second " <> (#)second <> ")" + Message_unexpect doc -> + "found : " <> (#)doc + Message_sysunexpect doc -> + "is written : " <> (#)doc + Message_expect doc -> + "but expect : " <> (#)doc + Message_message doc -> + (#)doc + Message_sysunexpect_end_of_input -> + "end of file unexpected" + Message_unknown -> + "unkown" + Message_or -> + "or" + Message_Balance_total -> + "Balance" + Message_Balance_debit -> + "Debit" + Message_Balance_credit -> + "Credit" + Message_Account -> + "Account" + toDoc FR msg = + case msg of + Message_ERROR -> + "ERREUR" + Message_no_ledger_file_given -> + "aucun fichier indiqué, veuillez utiliser :" <> W.line <> + " - soit le paramètre -i FICHIER," <> W.line <> + " - soit la variable d’environnement LEDGER_FILE." + Message_failed_to_read_file path -> + "échec de la lecture du fichier : " <> (#)path + Message_failed_to_include_file path -> + "échec à l’inclusion du fichier : " <> (#)path + Message_the_following_transaction_is_not_equilibrated_because -> + "la transaction suivante n’est pas équilibrée, car :" + Message_the_following_virtual_transaction_is_not_equilibrated_because -> + "la transaction virtuelle suivante n’est pas équilibrée, car :" + Message_unit_sums_up_to_the_non_null_amount unit amount -> + " - l’unité " <> (#)unit <> " a le solde non-nul : " <> (#)amount + Message_year_or_day_is_missing -> + "l’année ou le jour est manquant-e" + Message_invalid_date year month day -> + "date incorrecte (année " <> (#)year <> ", mois " <> (#)month <> ", jour " <> (#)day <> ")" + Message_invalid_time_of_day hour minute second -> + "heure incorrecte (heure " <> (#)hour <> ", minute " <> (#)minute <> ", seconde " <> (#)second <> ")" + Message_unexpect doc -> + "trouve : " <> (#)doc + Message_sysunexpect doc -> + "est écrit : " <> (#)doc + Message_expect doc -> + "mais s’attend à : " <> (#)doc + Message_message doc -> + (#)doc + Message_sysunexpect_end_of_input -> + "fin de fichier inattendue" + Message_unknown -> + "inconnu" + Message_or -> + "ou" + Message_Balance_total -> + "Solde" + Message_Balance_debit -> + "Débit" + Message_Balance_credit -> + "Crédit" + Message_Account -> + "Compte" diff --git a/cli/Hcompta/CLI/Write.hs b/cli/Hcompta/CLI/Write.hs index b833d0a..7f2e50a 100644 --- a/cli/Hcompta/CLI/Write.hs +++ b/cli/Hcompta/CLI/Write.hs @@ -15,7 +15,8 @@ import qualified Hcompta.Lib.Leijen as W import Hcompta.Lib.Leijen ((<>), ToDoc(..)) import qualified Hcompta.CLI.Context as Context import Hcompta.CLI.Context (Context) -import qualified Hcompta.CLI.I18N as I18N +import qualified Hcompta.CLI.Lang as Lang +import Hcompta.CLI.Lang (Lang) with_color :: Context -> IO.Handle -> IO Bool with_color context h = @@ -36,7 +37,7 @@ debug context msg = do IO.hPutStr IO.stderr $ concat [": ", msg, "\n"] _ -> return () -error :: ToDoc Context d => Context -> d -> IO () +error :: ToDoc Lang d => Context -> d -> IO () error context msg = do case Context.verbosity context of v | v >= Context.Verbosity_Error -> do @@ -45,15 +46,15 @@ error context msg = do ANSI.hSetSGR IO.stderr [ANSI.SetColor ANSI.Foreground ANSI.Dull ANSI.Red] W.hPutDoc IO.stderr $ - I18N.render (Context.langs context) I18N.Message_ERROR + toDoc (Context.lang context) Lang.Message_ERROR when color $ ANSI.hSetSGR IO.stderr [ANSI.Reset] - let doc = toDoc context msg + let doc = toDoc (Context.lang context) msg W.hPutDoc IO.stderr $ W.string ":" <> W.space <> doc <> W.line _ -> return () -fatal :: ToDoc Context d => Context -> d -> IO a +fatal :: ToDoc Lang d => Context -> d -> IO a fatal context msg = do Hcompta.CLI.Write.error context msg exitWith $ ExitFailure 1 diff --git a/cli/hcompta-cli.cabal b/cli/hcompta-cli.cabal index 14beae0..71edea6 100644 --- a/cli/hcompta-cli.cabal +++ b/cli/hcompta-cli.cabal @@ -61,7 +61,7 @@ Library Hcompta.CLI.Command.Print Hcompta.CLI.Context Hcompta.CLI.Format.Ledger - Hcompta.CLI.I18N + Hcompta.CLI.Lang Hcompta.CLI.Write build-depends: base >= 4.3 && < 5 diff --git a/cli/i18n/en.msg b/cli/i18n/en.msg deleted file mode 100644 index d185b5a..0000000 --- a/cli/i18n/en.msg +++ /dev/null @@ -1,23 +0,0 @@ -ERROR: ERROR -no_ledger_file_given: no ledger file given, please use:#{W.line} - either -i FILE parameter#{W.line} - or LEDGER_FILE environment variable. -at line@Int col@Int: (line #{line}, column #{col}) -in_file path@FilePath line@Int col@Int: (line #{line}, column #{col}) in: #{path} -failed_to_read_file path@FilePath: failed to read file: #{path} -failed_to_include_file path@FilePath: failed to include file: #{path} -the_following_transaction_is_not_equilibrated_because: the following transaction is not equilibrated, because: -the_following_virtual_transaction_is_not_equilibrated_because: the following virtual transaction is not equilibrated, because: -unit_sums_up_to_the_non_null_amount unit@Unit amount@Amount: #{W.space}- unit #{unit} sums up to the non-null amount: #{amount} -year_or_day_is_missing: year or day is missing -invalid_date year@Integer month@Int day@Int: invalid date (year #{year}, month #{month}, day #{day}) -invalid_time_of_day hour@Int month@Int second@Integer: invalid hour (hour #{hour}, minute #{month}, second #{second}) -unexpect doc@W.Doc: is written: #{doc} -sysunexpect msg@String: sysunexpect: #{msg} -expect doc@W.Doc: but expect: #{doc} -message msg@String: message: #{msg} -sysunexpect_end_of_input: unexpected end of input -unknown: unknown -or: or -Balance_total: Balance -Balance_debit: Debit -Balance_credit: Credit -Account: Account diff --git a/cli/i18n/fr.msg b/cli/i18n/fr.msg deleted file mode 100644 index 1f27455..0000000 --- a/cli/i18n/fr.msg +++ /dev/null @@ -1,23 +0,0 @@ -ERROR: ERREUR -no_ledger_file_given: aucun fichier indiqué, veuillez utiliser :#{W.line} - soit le paramètre -i FICHIER,#{W.line} - soit la variable d’environnement LEDGER_FILE. -at line@Int col@Int: (ligne #{line}, colonne #{col}) -in_file path@FilePath line@Int col@Int: (ligne #{line}, colonne #{col}) dans : #{path} -failed_to_read_file path@FilePath: échec de la lecture du fichier : #{path} -failed_to_include_file path@FilePath: échec de l’inclusion du fichier : #{path} -the_following_transaction_is_not_equilibrated_because: la transaction suivante n’est pas équilibrée, car : -the_following_virtual_transaction_is_not_equilibrated_because: la transaction virtuelle suivante n’est pas équilibrée, car : -unit_sums_up_to_the_non_null_amount unit@Unit amount@Amount: #{W.space}- l’unité #{unit} a le solde non-nul : #{amount} -year_or_day_is_missing: l’année ou le jour est manquant-e -invalid_date year@Integer month@Int day@Int: date incorrecte (année #{year}, mois #{month}, jour #{day}) -invalid_time_of_day hour@Int month@Int second@Integer: heure incorrecte (heure #{hour}, minute #{month}, seconde #{second}) -unexpect doc@W.Doc: trouve : #{doc} -sysunexpect msg@String: est écrit : #{msg} -expect doc@W.Doc: mais s’attend à : #{doc} -message msg@String: #{msg} -sysunexpect_end_of_input: fin de fichier inattendue -unknown: inconnu -or: ou -Balance_total: Solde -Balance_debit: Débit -Balance_credit: Crédit -Account: Compte diff --git a/lib/Hcompta/Format/Ledger/Read.hs b/lib/Hcompta/Format/Ledger/Read.hs index cd00bd1..496cd6b 100644 --- a/lib/Hcompta/Format/Ledger/Read.hs +++ b/lib/Hcompta/Format/Ledger/Read.hs @@ -24,7 +24,6 @@ import Data.String (fromString) import qualified Data.Time.Calendar as Time import qualified Data.Time.Clock as Time import qualified Data.Time.LocalTime as Time -import Data.Time.LocalTime (TimeZone(..)) import Data.Typeable () import qualified Text.Parsec as R hiding ( char @@ -54,6 +53,7 @@ import qualified Hcompta.Model.Amount.Unit as Unit import Hcompta.Model.Amount.Unit (Unit) import qualified Hcompta.Model.Date as Date import Hcompta.Model.Date (Date) +import qualified Hcompta.Model.Date.Read as Date.Read import qualified Hcompta.Format.Ledger as Ledger import Hcompta.Format.Ledger ( Comment @@ -95,9 +95,7 @@ nil_Context = } data Error - = Error_year_or_day_is_missing - | Error_invalid_date (Integer, Int, Int) - | Error_invalid_time_of_day (Int, Int, Integer) + = Error_date Date.Read.Error | Error_transaction_not_equilibrated Transaction [Balance.Unit_Sum (Balance.Posting_Amount Ledger.Posting)] | Error_virtual_transaction_not_equilibrated Transaction [Balance.Unit_Sum (Balance.Posting_Amount Ledger.Posting)] | Error_reading_file FilePath Exception.IOException @@ -111,7 +109,7 @@ sign = <|> (R.char '+' >> return id) <|> return id --- * Parsing 'Account' +-- * Read 'Account' account_name_sep :: Char account_name_sep = ':' @@ -173,7 +171,7 @@ account_pattern = do , Account.Pattern_Regex <$> (R.option '~' (R.char '~') >> account_regex) ] --- * Parsing 'Amount' +-- * Read 'Amount' -- | Parse an 'Amount'. amount :: Stream s m Char => ParsecT s u m Amount @@ -344,134 +342,8 @@ directive_alias = do (regx, repl):context_aliases_regex ctx} return () --- | Parse the year, month and day separator: '/' or '-'. -date_separator :: Stream s m Char => ParsecT s u m Char -date_separator = R.satisfy (\c -> c == '/' || c == '-') --- | Parse the hour, minute and second separator: ':'. -hour_separator :: Stream s m Char => ParsecT s u m Char -hour_separator = R.char ':' - --- * Parsing 'Date' - --- | Parse a 'Date' in [YYYY/]MM/DD [HH:MM[:SS][TZ]] format. -date - :: (Stream s (R.Error_State Error m) Char, Monad m) - => Maybe Integer -> ParsecT s u (R.Error_State Error m) Date -date def_year = (do - n0 <- R.many1 R.digit - day_sep <- date_separator - n1 <- R.try (R.count 2 R.digit) <|> R.count 1 R.digit - n2 <- R.option Nothing $ R.try $ do - _ <- R.char day_sep - Just <$> do R.try (R.count 2 R.digit) <|> R.count 1 R.digit - (year, m, d) <- - case (n2, def_year) of - (Nothing, Nothing) -> R.fail_with "date" (Error_year_or_day_is_missing) - (Nothing, Just year) -> return (year, n0, n1) - (Just d, _) -> return (R.integer_of_digits 10 n0, n1, d) - let month = fromInteger $ R.integer_of_digits 10 m - let day = fromInteger $ R.integer_of_digits 10 d - guard $ month >= 1 && month <= 12 - guard $ day >= 1 && day <= 31 - day_ <- case Time.fromGregorianValid year month day of - Nothing -> R.fail_with "date" (Error_invalid_date (year, month, day)) - Just day_ -> return day_ - (hour, minu, sec, tz) <- - R.option (0, 0, 0, Time.utc) $ R.try $ do - R.skipMany1 $ R.space_horizontal - hour <- R.try (R.count 2 R.digit) <|> R.count 1 R.digit - sep <- hour_separator - minu <- R.try (R.count 2 R.digit) <|> R.count 1 R.digit - sec <- R.option Nothing $ R.try $ do - _ <- R.char sep - Just <$> (R.try (R.count 2 R.digit) <|> R.count 1 R.digit) - tz <- R.option Time.utc $ R.try $ do - R.skipMany $ R.space_horizontal - time_zone - return - ( fromInteger $ R.integer_of_digits 10 hour - , fromInteger $ R.integer_of_digits 10 minu - , maybe 0 (R.integer_of_digits 10) sec - , tz ) - tod <- case Time.makeTimeOfDayValid hour minu (fromInteger sec) of - Nothing -> R.fail_with "date" (Error_invalid_time_of_day (hour, minu, sec)) - Just tod -> return tod - return $ - Time.ZonedTime - (Time.LocalTime day_ tod) - tz - ) "date" - -time_zone :: Stream s m Char => ParsecT s u m TimeZone -time_zone = - -- DOC: http://www.timeanddate.com/time/zones/ - -- TODO: only a few time zones are suported below. - -- TODO: check the timeZoneSummerOnly values - R.choice - [ R.char 'A' >> R.choice - [ R.string "ST" >> return (TimeZone ((-4) * 60) False "AST") - , R.string "DT" >> return (TimeZone ((-3) * 60) True "ADT") - , return (TimeZone ((-1) * 60) False "A") - ] - , R.char 'B' >> R.choice - [ R.string "ST" >> return (TimeZone ((-11) * 60) False "BST") - , R.string "DT" >> return (TimeZone ((-10) * 60) True "BDT") - ] - , R.char 'C' >> R.choice - [ R.char 'E' >> R.choice - [ R.string "T" >> return (TimeZone ((1) * 60) True "CET") - , R.string "ST" >> return (TimeZone ((2) * 60) False "CEST") - ] - , R.string "ST" >> return (TimeZone ((-6) * 60) False "CST") - , R.string "DT" >> return (TimeZone ((-5) * 60) True "CDT") - ] - , R.char 'E' >> R.choice - [ R.string "ST" >> return (TimeZone ((-5) * 60) False "EST") - , R.string "DT" >> return (TimeZone ((-4) * 60) True "EDT") - ] - , R.string "GMT" >> return (TimeZone 0 False "GMT") - , R.char 'H' >> R.choice - [ R.string "ST" >> return (TimeZone ((-10) * 60) False "HST") - , R.string "DT" >> return (TimeZone (( -9) * 60) True "HDT") - ] - , R.char 'M' >> R.choice - [ R.string "ST" >> return (TimeZone ((-7) * 60) False "MST") - , R.string "DT" >> return (TimeZone ((-6) * 60) True "MDT") - , return (TimeZone ((-12) * 60) False "M") - ] - , R.char 'N' >> R.choice - [ R.string "ST" >> return (TimeZone ((-3) * 60 - 30) False "NST") - , return (TimeZone (1 * 60) False "N") - ] - , R.char 'P' >> R.choice - [ R.string "ST" >> return (TimeZone ((-8) * 60) False "PST") - , R.string "DT" >> return (TimeZone ((-7) * 60) True "PDT") - ] - , R.char 'Y' >> R.choice - [ R.string "ST" >> return (TimeZone ((-9) * 60) False "YST") - , R.string "DT" >> return (TimeZone ((-8) * 60) True "YDT") - , return (TimeZone (12 * 60) False "Y") - ] - , R.char 'Z' >> return (TimeZone 0 False "Z") - , time_zone_digits - ] - -time_zone_digits :: Stream s m Char => ParsecT s u m TimeZone -{-# INLINEABLE time_zone_digits #-} -time_zone_digits = do - sign_ <- sign - hour <- R.integer_of_digits 10 <$> R.count 2 R.digit - _ <- R.option ':' (R.char ':') - minute <- R.integer_of_digits 10 <$> R.count 2 R.digit - let tz = TimeZone - { timeZoneMinutes = sign_ (fromInteger hour * 60 + fromInteger minute) - , timeZoneSummerOnly = False - , timeZoneName = Time.timeZoneOffsetString tz - } - return tz - --- * Parsing 'Comment' +-- * Read 'Comment' comment_begin :: Char comment_begin = ';' @@ -491,7 +363,7 @@ comments = (do <|> return [] ) "comments" --- * Parsing 'Tag' +-- * Read 'Tag' tag_value_sep :: Char tag_value_sep = ':' @@ -538,7 +410,7 @@ not_tag = do && not (Data.Char.isSpace c)) R.space_horizontal --- * Parsing 'Posting' +-- * Read 'Posting' -- | Parse a 'Posting'. posting @@ -583,10 +455,10 @@ posting = (do Nothing -> return [] Just dates -> do let date2s = Data.Map.lookup "date2" tags_ -- NOTE: support hledger's date2 - do + do (flip mapM) (dates ++ fromMaybe [] date2s) $ \s -> - R.runParserT_with_Error_fail "tag date" - (date (Just $ context_year ctx) <* R.eof) () + R.runParserT_with_Error_fail "tag date" id + (Date.Read.date Error_date (Just $ context_year ctx) <* R.eof) () (Text.unpack s) s >>= \dates_ -> case (dates, date2s) of -- NOTE: put hledger's date2 at least in second position ([], Just (_:_)) -> @@ -687,7 +559,7 @@ posting_type_virtual_end = ')' posting_type_virtual_balanced_end :: Char posting_type_virtual_balanced_end = ']' --- * Parsing 'Transaction' +-- * Read 'Transaction' transaction :: (Stream s (R.Error_State Error m) Char, Monad m) @@ -700,14 +572,14 @@ transaction = (do >>= \x -> case x of [] -> return [] _ -> return x <* R.new_line - date_ <- date (Just $ context_year ctx) + date_ <- Date.Read.date Error_date (Just $ context_year ctx) dates_ <- R.option [] $ R.try $ do R.skipMany $ R.space_horizontal _ <- R.char date_sep R.skipMany $ R.space_horizontal R.many_separated - (date (Just $ context_year ctx)) $ + (Date.Read.date Error_date (Just $ context_year ctx)) $ R.try $ do R.many $ R.space_horizontal >> R.char date_sep @@ -790,7 +662,7 @@ description = (do _ | not (Data.Char.isSpace c) -> return c _ -> R.parserZero --- * Parsing directives +-- * Read directives default_year :: Stream s m Char => ParsecT s Context m () default_year = (do @@ -841,7 +713,7 @@ include = (do : journal_includes journal_}} ) "include" --- * Parsing 'Journal' +-- * Read 'Journal' journal :: Stream s (R.Error_State Error IO) Char @@ -896,7 +768,7 @@ journal_rec file_ = do , journal_includes = reverse $ journal_includes journal_ } --- ** Parsing 'Journal' from a file +-- ** Read 'Journal' from a file file :: FilePath -> ExceptT [R.Error Error] IO Journal file path = do diff --git a/lib/Hcompta/Format/Ledger/Write.hs b/lib/Hcompta/Format/Ledger/Write.hs index 6c31692..ec89094 100644 --- a/lib/Hcompta/Format/Ledger/Write.hs +++ b/lib/Hcompta/Format/Ledger/Write.hs @@ -52,7 +52,6 @@ import Hcompta.Model.Date (Date) -- import Hcompta.Format.Ledger.Journal as Journal import qualified Hcompta.Format.Ledger.Read as Read import qualified Hcompta.Lib.Parsec as R -import qualified Hcompta.Lib.Foldable as Lib.Foldable -- * Printing 'Account' diff --git a/lib/Hcompta/Lib/Parsec.hs b/lib/Hcompta/Lib/Parsec.hs index 8456c65..7e59d45 100644 --- a/lib/Hcompta/Lib/Parsec.hs +++ b/lib/Hcompta/Lib/Parsec.hs @@ -1,16 +1,18 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Hcompta.Lib.Parsec where import Control.Monad.Trans.State (StateT(..), get, put) -import Control.Monad.Trans.Class (lift, MonadTrans(..)) +-- import Control.Monad.Trans.Class (lift, MonadTrans(..)) import qualified Data.Char import Data.Functor.Identity (Identity(..)) import qualified Data.List import qualified Text.Parsec as R hiding (satisfy, string, char, space, newline, crlf) import Text.Parsec (Stream, ParsecT, (<|>), ()) import qualified Text.Parsec.Pos as R +import Control.Monad.Trans.Class (lift) -- * Combinators @@ -102,6 +104,11 @@ data Error e | Error_At R.SourcePos [Error e] -- ^ 'Error' raised by 'runParserT_with_Error_fail'. deriving (Show) +instance Functor Error where + fmap _ (Error_Parser e) = Error_Parser e + fmap f (Error_Custom pos e) = Error_Custom pos (f e) + fmap f (Error_At pos es) = Error_At pos $ map (fmap f) es + -- | Like 'R.parserFail' -- but fail with given custom error. fail_with :: (Stream s (Error_State e m) Char, Monad m) @@ -158,14 +165,15 @@ runParser_with_Error p u sn s = -- | Like 'R.runParserT_with_Error' -- but propagate any failure to a calling 'ParsecT' monad. runParserT_with_Error_fail :: - ( Stream s1 (Error_State e m) Char - , Stream s (Error_State e (ParsecT s1 u1 (Error_State e m))) Char - , Monad m, Show r, Show e ) + ( Stream s1 (Error_State ee m) Char + , Stream s (Error_State e (ParsecT s1 u1 (Error_State ee m))) Char + , Monad m, Show r, Show e, Show ee ) => String - -> ParsecT s u (Error_State e (ParsecT s1 u1 (Error_State e m))) r + -> (Error e -> Error ee) + -> ParsecT s u (Error_State e (ParsecT s1 u1 (Error_State ee m))) r -> u -> R.SourceName -> s - -> ParsecT s1 u1 (Error_State e m) r -runParserT_with_Error_fail msg p u sn s = do + -> ParsecT s1 u1 (Error_State ee m) r +runParserT_with_Error_fail msg map_ko p u sn s = do r <- runParserT_with_Error p u sn s case r of Right ok -> return ok @@ -173,10 +181,38 @@ runParserT_with_Error_fail msg p u sn s = do rpos <- R.getPosition _ <- commit_position pos <- R.getPosition - lift $ put (pos, Error_At rpos ko:[]) + lift $ put (pos, Error_At rpos (map map_ko ko):[]) fail msg where commit_position = (R.anyChar >> return ()) <|> R.eof +-- ** Mapping inner monad + +-- | Like an instance Control.Functor.Morph.'MFunctor' of @R.ParsecT s u@ +-- but also requiring a second 'Monad' constraint +-- on the returned base container. +-- +-- NOTE: This code is not used by Hcompta, still is left here +-- because it was not trivial to write it, +-- so eventually it may help others. + +hoist :: (Monad m, Monad n) => (forall a. m a -> n a) -> ParsecT s u m b -> ParsecT s u n b +hoist nat m = R.mkPT $ \s -> do + c <- nat $ R.runParsecT m s + return $ case c of + R.Consumed mrep -> R.Consumed $ nat mrep + R.Empty mrep -> R.Empty $ nat mrep + +-- | Map the type of a 'StateT'. +-- +-- NOTE: This code is not used by Hcompta, still is left here +-- because it was not trivial to write it, +-- so eventually it may help others. +smap :: Monad m => (s1 -> s0) -> (s0 -> s1) -> StateT s0 m a -> StateT s1 m a +smap s1_to_s0 s0_to_s1 st = + StateT (\s1_begin -> do + (a, s0_end) <- runStateT st (s1_to_s0 s1_begin) + return (a, s0_to_s1 s0_end)) + -- * Numbers -- | Return the 'Integer' obtained by multiplying the given digits diff --git a/lib/Hcompta/Model/Date.hs b/lib/Hcompta/Model/Date.hs index 117a98b..4244de6 100644 --- a/lib/Hcompta/Model/Date.hs +++ b/lib/Hcompta/Model/Date.hs @@ -56,3 +56,4 @@ type UTC = Time.UTCTime to_UTC :: Date -> UTC to_UTC = Time.zonedTimeToUTC + diff --git a/lib/Hcompta/Model/Date/Read.hs b/lib/Hcompta/Model/Date/Read.hs new file mode 100644 index 0000000..f88967d --- /dev/null +++ b/lib/Hcompta/Model/Date/Read.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +module Hcompta.Model.Date.Read where + +import Control.Applicative ((<$>)) +import Control.Monad (guard) +import qualified Data.Time.Calendar as Time +import qualified Data.Time.LocalTime as Time +import Data.Time.LocalTime (TimeZone(..)) +import Data.Typeable () +import qualified Text.Parsec as R hiding + ( char + , anyChar + , crlf + , newline + , noneOf + , oneOf + , satisfy + , space + , spaces + , string + ) +import Text.Parsec (Stream, ParsecT, (<|>), ()) + +import Hcompta.Model.Date (Date) +import qualified Hcompta.Lib.Parsec as R + +data Error + = Error_year_or_day_is_missing + | Error_invalid_date (Integer, Int, Int) + | Error_invalid_time_of_day (Int, Int, Integer) + deriving (Show) + +-- | Read a 'Date' in [YYYY/]MM/DD [HH:MM[:SS][TZ]] format. +date + :: (Stream s (R.Error_State e m) Char, Monad m) + => (Error -> e) -> Maybe Integer -> ParsecT s u (R.Error_State e m) Date +date err def_year = (do + n0 <- R.many1 R.digit + day_sep <- date_separator + n1 <- R.try (R.count 2 R.digit) <|> R.count 1 R.digit + n2 <- R.option Nothing $ R.try $ do + _ <- R.char day_sep + Just <$> do R.try (R.count 2 R.digit) <|> R.count 1 R.digit + (year, m, d) <- + case (n2, def_year) of + (Nothing, Nothing) -> R.fail_with "date" (err $ Error_year_or_day_is_missing) + (Nothing, Just year) -> return (year, n0, n1) + (Just d, _) -> return (R.integer_of_digits 10 n0, n1, d) + let month = fromInteger $ R.integer_of_digits 10 m + let day = fromInteger $ R.integer_of_digits 10 d + guard $ month >= 1 && month <= 12 + guard $ day >= 1 && day <= 31 + day_ <- case Time.fromGregorianValid year month day of + Nothing -> R.fail_with "date" (err $ Error_invalid_date (year, month, day)) + Just day_ -> return day_ + (hour, minu, sec, tz) <- + R.option (0, 0, 0, Time.utc) $ R.try $ do + R.skipMany1 $ R.space_horizontal + hour <- R.try (R.count 2 R.digit) <|> R.count 1 R.digit + sep <- hour_separator + minu <- R.try (R.count 2 R.digit) <|> R.count 1 R.digit + sec <- R.option Nothing $ R.try $ do + _ <- R.char sep + Just <$> (R.try (R.count 2 R.digit) <|> R.count 1 R.digit) + tz <- R.option Time.utc $ R.try $ do + R.skipMany $ R.space_horizontal + time_zone + return + ( fromInteger $ R.integer_of_digits 10 hour + , fromInteger $ R.integer_of_digits 10 minu + , maybe 0 (R.integer_of_digits 10) sec + , tz ) + tod <- case Time.makeTimeOfDayValid hour minu (fromInteger sec) of + Nothing -> R.fail_with "date" (err $ Error_invalid_time_of_day (hour, minu, sec)) + Just tod -> return tod + return $ + Time.ZonedTime + (Time.LocalTime day_ tod) + tz + ) "date" + +-- | Parse the year, month and day separator: '/' or '-'. +date_separator :: Stream s m Char => ParsecT s u m Char +date_separator = R.satisfy (\c -> c == '/' || c == '-') + +-- | Parse the hour, minute and second separator: ':'. +hour_separator :: Stream s m Char => ParsecT s u m Char +hour_separator = R.char ':' + +-- | Parse either '-' into 'negate', or '+' or '' into 'id'. +sign :: (Stream s m Char, Num i) => ParsecT s u m (i -> i) +sign = + (R.char '-' >> return negate) + <|> (R.char '+' >> return id) + <|> return id + +time_zone :: Stream s m Char => ParsecT s u m TimeZone +time_zone = + -- DOC: http://www.timeanddate.com/time/zones/ + -- TODO: only a few time zones are suported below. + -- TODO: check the timeZoneSummerOnly values + R.choice + [ R.char 'A' >> R.choice + [ R.string "ST" >> return (TimeZone ((-4) * 60) False "AST") + , R.string "DT" >> return (TimeZone ((-3) * 60) True "ADT") + , return (TimeZone ((-1) * 60) False "A") + ] + , R.char 'B' >> R.choice + [ R.string "ST" >> return (TimeZone ((-11) * 60) False "BST") + , R.string "DT" >> return (TimeZone ((-10) * 60) True "BDT") + ] + , R.char 'C' >> R.choice + [ R.char 'E' >> R.choice + [ R.string "T" >> return (TimeZone ((1) * 60) True "CET") + , R.string "ST" >> return (TimeZone ((2) * 60) False "CEST") + ] + , R.string "ST" >> return (TimeZone ((-6) * 60) False "CST") + , R.string "DT" >> return (TimeZone ((-5) * 60) True "CDT") + ] + , R.char 'E' >> R.choice + [ R.string "ST" >> return (TimeZone ((-5) * 60) False "EST") + , R.string "DT" >> return (TimeZone ((-4) * 60) True "EDT") + ] + , R.string "GMT" >> return (TimeZone 0 False "GMT") + , R.char 'H' >> R.choice + [ R.string "ST" >> return (TimeZone ((-10) * 60) False "HST") + , R.string "DT" >> return (TimeZone (( -9) * 60) True "HDT") + ] + , R.char 'M' >> R.choice + [ R.string "ST" >> return (TimeZone ((-7) * 60) False "MST") + , R.string "DT" >> return (TimeZone ((-6) * 60) True "MDT") + , return (TimeZone ((-12) * 60) False "M") + ] + , R.char 'N' >> R.choice + [ R.string "ST" >> return (TimeZone ((-3) * 60 - 30) False "NST") + , return (TimeZone (1 * 60) False "N") + ] + , R.char 'P' >> R.choice + [ R.string "ST" >> return (TimeZone ((-8) * 60) False "PST") + , R.string "DT" >> return (TimeZone ((-7) * 60) True "PDT") + ] + , R.char 'Y' >> R.choice + [ R.string "ST" >> return (TimeZone ((-9) * 60) False "YST") + , R.string "DT" >> return (TimeZone ((-8) * 60) True "YDT") + , return (TimeZone (12 * 60) False "Y") + ] + , R.char 'Z' >> return (TimeZone 0 False "Z") + , time_zone_digits + ] + +time_zone_digits :: Stream s m Char => ParsecT s u m TimeZone +{-# INLINEABLE time_zone_digits #-} +time_zone_digits = do + sign_ <- sign + hour <- R.integer_of_digits 10 <$> R.count 2 R.digit + _ <- R.option ':' (R.char ':') + minute <- R.integer_of_digits 10 <$> R.count 2 R.digit + let tz = TimeZone + { timeZoneMinutes = sign_ (fromInteger hour * 60 + fromInteger minute) + , timeZoneSummerOnly = False + , timeZoneName = Time.timeZoneOffsetString tz + } + return tz diff --git a/lib/Hcompta/Model/Filter/Read.hs b/lib/Hcompta/Model/Filter/Read.hs index b856862..c52eebd 100644 --- a/lib/Hcompta/Model/Filter/Read.hs +++ b/lib/Hcompta/Model/Filter/Read.hs @@ -66,9 +66,9 @@ data Error = Error_Unknown deriving (Eq, Show) --- * Parsers +-- * Reading --- ** Parse 'Test_Text' +-- ** Read 'Test_Text' test_text :: (Stream s m Char, Monad r) => ParsecT s u m (String -> r Test_Text) @@ -79,7 +79,7 @@ test_text = , return (\s -> return (Test_Text_Exact $ Text.pack s)) ] --- ** Parse 'Test_Ord' +-- ** Read 'Test_Ord' test_ord :: (Stream s m Char, Ord o) => ParsecT s u m (o -> m (Test_Ord o)) @@ -92,7 +92,7 @@ test_ord = , R.string ">" >> return (return . Test_Ord_Gt) ] --- ** Parse 'Test_Num_Abs' +-- ** Read 'Test_Num_Abs' test_num_abs :: (Stream s m Char, Num n) => ParsecT s u m (Test_Ord n -> m (Either (Test_Ord n) (Test_Num_Abs n))) @@ -114,7 +114,7 @@ text none_of = inside = liftM concat $ R.many (R.choice_try [borders preserve_inside, R.many1 $ R.noneOf "()"]) preserve_inside = inside >>= (\x -> return $ '(':(x++')':[])) --- ** Parse 'Test_Bool' +-- ** Read 'Test_Bool' test_bool :: (Stream s m Char) @@ -205,7 +205,7 @@ bool = do ] >> return False ] --- ** Parse Account.'Account.Name' +-- ** Read Account.'Account.Name' account_name :: Stream s m Char => ParsecT s u m Account.Name account_name = do fromString <$> do @@ -226,7 +226,7 @@ account_name = do _ | not (Data.Char.isSpace c) -> return c _ -> R.parserZero --- ** Parse 'Test_Account_Section' +-- ** Read 'Test_Account_Section' test_account_section :: (Stream s m Char) => (String -> ParsecT s u m Test_Text) @@ -250,7 +250,7 @@ test_account_section make_test_text = do , R.eof ] --- ** Parse 'Test_Account' +-- ** Read 'Test_Account' account_name_sep :: Char account_name_sep = ':' @@ -263,7 +263,7 @@ test_account = do R.many1_separated (test_account_section make_test_text) $ R.char account_name_sep --- ** Parse 'Test_Posting' +-- ** Read 'Test_Posting' test_posting :: (Stream s m Char, Filter.Posting t) => ParsecT s Context m (Test_Bool (Test_Posting t)) @@ -283,7 +283,7 @@ test_posting_terms = <$> test_account ) ] --- ** Parse 'Test_Transaction' +-- ** Read 'Test_Transaction' test_transaction :: (Stream s m Char, Filter.Transaction t) => ParsecT s Context m (Test_Bool (Test_Transaction t)) @@ -324,7 +324,7 @@ test_transaction_terms = -- (map (\s -> R.string s >> return r) l) -- <* R.lookAhead next --- ** Parse 'Test_Balance' +-- ** Read 'Test_Balance' test_balance :: (Stream s m Char, Filter.Balance t) => ParsecT s Context m (Test_Bool (Test_Balance t)) @@ -425,7 +425,7 @@ parseFilterReal = do R.char '=' liftM Real bool --- | Parse the boolean value part of a "status:" query, allowing "*" as +-- | Read the boolean value part of a "status:" query, allowing "*" as -- another way to spell True, similar to the journal file format. parseFilterStatus :: Stream s m Char => ParsecT s Context m Filter parseFilterStatus = do diff --git a/lib/Test/Main.hs b/lib/Test/Main.hs index 6094a95..288d7d1 100644 --- a/lib/Test/Main.hs +++ b/lib/Test/Main.hs @@ -17,7 +17,7 @@ import qualified Data.Map.Strict as Data.Map import Data.Text (Text) import qualified Data.Time.Calendar as Time import qualified Data.Time.LocalTime as Time -import qualified Text.Parsec as P hiding (char, string, space) +import qualified Text.Parsec as P hiding (char, space, string) import qualified Text.Parsec.Pos as P -- import qualified Text.PrettyPrint.Leijen.Text as PP @@ -27,6 +27,7 @@ import qualified Hcompta.Model.Amount as Amount import Hcompta.Model.Amount (Amount) import qualified Hcompta.Model.Amount.Style as Amount.Style import qualified Hcompta.Model.Date as Date +import qualified Hcompta.Model.Date.Read as Date.Read import qualified Hcompta.Model.Filter as Filter import qualified Hcompta.Model.Filter.Read as Filter.Read import qualified Hcompta.Calc.Balance as Calc.Balance @@ -2402,7 +2403,7 @@ test_Hcompta = [ "2000/01/01" ~: (Data.Either.rights $ [P.runParser_with_Error - (Format.Ledger.Read.date Nothing <* P.eof) + (Date.Read.date id Nothing <* P.eof) () "" ("2000/01/01"::Text)]) ~?= [ Time.ZonedTime @@ -2413,7 +2414,7 @@ test_Hcompta = , "2000/01/01 some text" ~: (Data.Either.rights $ [P.runParser_with_Error - (Format.Ledger.Read.date Nothing) + (Date.Read.date id Nothing) () "" ("2000/01/01 some text"::Text)]) ~?= [ Time.ZonedTime @@ -2424,7 +2425,7 @@ test_Hcompta = , "2000/01/01 12:34" ~: (Data.Either.rights $ [P.runParser_with_Error - (Format.Ledger.Read.date Nothing <* P.eof) + (Date.Read.date id Nothing <* P.eof) () "" ("2000/01/01 12:34"::Text)]) ~?= [ Time.ZonedTime @@ -2435,7 +2436,7 @@ test_Hcompta = , "2000/01/01 12:34:56" ~: (Data.Either.rights $ [P.runParser_with_Error - (Format.Ledger.Read.date Nothing <* P.eof) + (Date.Read.date id Nothing <* P.eof) () "" ("2000/01/01 12:34:56"::Text)]) ~?= [ Time.ZonedTime @@ -2446,7 +2447,7 @@ test_Hcompta = , "2000/01/01 12:34 CET" ~: (Data.Either.rights $ [P.runParser_with_Error - (Format.Ledger.Read.date Nothing <* P.eof) + (Date.Read.date id Nothing <* P.eof) () "" ("2000/01/01 12:34 CET"::Text)]) ~?= [ Time.ZonedTime @@ -2457,7 +2458,7 @@ test_Hcompta = , "2000/01/01 12:34 +0130" ~: (Data.Either.rights $ [P.runParser_with_Error - (Format.Ledger.Read.date Nothing <* P.eof) + (Date.Read.date id Nothing <* P.eof) () "" ("2000/01/01 12:34 +0130"::Text)]) ~?= [ Time.ZonedTime @@ -2468,7 +2469,7 @@ test_Hcompta = , "2000/01/01 12:34:56 CET" ~: (Data.Either.rights $ [P.runParser_with_Error - (Format.Ledger.Read.date Nothing <* P.eof) + (Date.Read.date id Nothing <* P.eof) () "" ("2000/01/01 12:34:56 CET"::Text)]) ~?= [ Time.ZonedTime @@ -2479,14 +2480,14 @@ test_Hcompta = , "2001/02/29" ~: (Data.Either.rights $ [P.runParser_with_Error - (Format.Ledger.Read.date Nothing <* P.eof) + (Date.Read.date id Nothing <* P.eof) () "" ("2001/02/29"::Text)]) ~?= [] , "01/01" ~: (Data.Either.rights $ [P.runParser_with_Error - (Format.Ledger.Read.date (Just 2000) <* P.eof) + (Date.Read.date id (Just 2000) <* P.eof) () "" ("01/01"::Text)]) ~?= [ Time.ZonedTime diff --git a/lib/hcompta-lib.cabal b/lib/hcompta-lib.cabal index 0848f8d..aaabd53 100644 --- a/lib/hcompta-lib.cabal +++ b/lib/hcompta-lib.cabal @@ -76,6 +76,7 @@ Library Hcompta.Model.Amount.Style Hcompta.Model.Amount.Unit Hcompta.Model.Date + Hcompta.Model.Date.Read Hcompta.Model.Filter Hcompta.Model.Filter.Read build-depends: @@ -92,6 +93,7 @@ Library , HUnit , integer-gmp -- , lens + -- , mmorph -- , mtl >= 2.0 , parsec >= 3.1.2 && < 4 -- NOTE: needed for Text.Parsec.Text -- 2.47.2 From 263c967edf298e832c95726f99ccc0b770d6c33f Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Thu, 18 Jun 2015 11:22:19 +0200 Subject: [PATCH 06/16] Ajout : Model.Filter : Test_Date. --- cli/Hcompta/CLI/Command/Balance.hs | 13 +- cli/Hcompta/CLI/Command/Print.hs | 5 +- cli/Hcompta/CLI/Lang.hs | 34 +++-- lib/Hcompta/Format/Ledger.hs | 4 +- lib/Hcompta/Format/Ledger/Read.hs | 2 +- lib/Hcompta/Format/Ledger/Write.hs | 10 +- lib/Hcompta/Model/Date.hs | 46 ++++-- lib/Hcompta/Model/Date/Read.hs | 31 ++--- lib/Hcompta/Model/Filter.hs | 78 +++++++++-- lib/Hcompta/Model/Filter/Read.hs | 217 ++++++++++++++++++++++------- lib/Test/Main.hs | 59 +++++--- 11 files changed, 359 insertions(+), 140 deletions(-) diff --git a/cli/Hcompta/CLI/Command/Balance.hs b/cli/Hcompta/CLI/Command/Balance.hs index fd776ae..efd49a5 100644 --- a/cli/Hcompta/CLI/Command/Balance.hs +++ b/cli/Hcompta/CLI/Command/Balance.hs @@ -89,16 +89,18 @@ options = "read data from given file, can be use multiple times" , Option "t" ["transaction-filter"] (ReqArg (\s context ctx -> do - ctx_transaction_filter <- do - case Filter.Read.read Filter.Read.test_transaction s of + ctx_transaction_filter <- + liftIO $ Filter.Read.read Filter.Read.test_transaction s + >>= \f -> case f of Left ko -> Write.fatal context $ ko Right ok -> return ok return $ ctx{ctx_transaction_filter}) "FILTER") "filter on posting" , Option "p" ["posting-filter"] (ReqArg (\s context ctx -> do - ctx_posting_filter <- do - case Filter.Read.read Filter.Read.test_posting s of + ctx_posting_filter <- + liftIO $ Filter.Read.read Filter.Read.test_posting s + >>= \f -> case f of Left ko -> Write.fatal context $ ko Right ok -> return ok return $ ctx{ctx_posting_filter}) "FILTER") @@ -138,7 +140,8 @@ run context args = do (Account, Balance.Amount_Sum Amount))) <- foldr Filter.And Filter.Any <$> do (flip mapM) text_filters $ \s -> - case Filter.Read.read Filter.Read.test_balance s of + liftIO $ Filter.Read.read Filter.Read.test_balance s + >>= \f -> case f of Left ko -> Write.fatal context $ ko Right ok -> return ok Write.debug context $ "balance_filter: " ++ show balance_filter diff --git a/cli/Hcompta/CLI/Command/Print.hs b/cli/Hcompta/CLI/Command/Print.hs index 3f3a32b..0562c5c 100644 --- a/cli/Hcompta/CLI/Command/Print.hs +++ b/cli/Hcompta/CLI/Command/Print.hs @@ -97,10 +97,11 @@ run context args = do ([], journals) -> do (filters::[Filter.Test_Bool (Filter.Test_Transaction Ledger.Transaction)]) <- (flip mapM) text_filters $ \s -> - case Filter.Read.read Filter.Read.test_transaction s of + liftIO $ Filter.Read.read Filter.Read.test_transaction s + >>= \f -> case f of Left ko -> Write.fatal context $ ko Right ok -> return ok - Write.debug context $ show filters + Write.debug context $ "transaction_filter: " ++ show filters style_color <- Write.with_color context IO.stdout let sty = Ledger.Write.Style { Ledger.Write.style_align = ctx_align ctx diff --git a/cli/Hcompta/CLI/Lang.hs b/cli/Hcompta/CLI/Lang.hs index 9d122f4..69e64c3 100644 --- a/cli/Hcompta/CLI/Lang.hs +++ b/cli/Hcompta/CLI/Lang.hs @@ -77,18 +77,22 @@ instance ToDoc m Unit where instance ToDoc m Amount where toDoc _ = Ledger.Write.amount instance ToDoc Lang Date.Read.Error where - toDoc FR Date.Read.Error_year_or_day_is_missing = - "l’année ou le jour est manquant·e" - toDoc FR (Date.Read.Error_invalid_date (year, month, day)) = - "date incorrecte (année " <> (#)year <> ", mois " <> (#)month <> ", jour " <> (#)day <> ")" - toDoc FR (Date.Read.Error_invalid_time_of_day (hour, minute, second)) = - "heure incorrecte (heure " <> (#)hour <> ", minute " <> (#)minute <> ", seconde " <> (#)second <> ")" - toDoc EN Date.Read.Error_year_or_day_is_missing = - "year or day is missing" - toDoc EN (Date.Read.Error_invalid_date (year, month, day)) = - "invalid date (year " <> (#)year <> ", month " <> (#)month <> ", day " <> (#)day <> ")" - toDoc EN (Date.Read.Error_invalid_time_of_day (hour, minute, second)) = - "invalid time of day (hour " <> (#)hour <> ", minute " <> (#)minute <> ", second " <> (#)second <> ")" + toDoc FR e = + case e of + Date.Read.Error_year_or_day_is_missing -> + "l’année ou le jour est manquant·e" + Date.Read.Error_invalid_date (year, month, day) -> + "date incorrecte (année " <> (#)year <> ", mois " <> (#)month <> ", jour " <> (#)day <> ")" + Date.Read.Error_invalid_time_of_day (hour, minute, second) -> + "heure incorrecte (heure " <> (#)hour <> ", minute " <> (#)minute <> ", seconde " <> (#)second <> ")" + toDoc EN e = + case e of + Date.Read.Error_year_or_day_is_missing -> + "year or day is missing" + Date.Read.Error_invalid_date (year, month, day) -> + "invalid date (year " <> (#)year <> ", month " <> (#)month <> ", day " <> (#)day <> ")" + Date.Read.Error_invalid_time_of_day (hour, minute, second) -> + "invalid time of day (hour " <> (#)hour <> ", minute " <> (#)minute <> ", second " <> (#)second <> ")" instance ToDoc Lang Parsec.SourcePos where toDoc EN pos = do let line = Parsec.sourceLine pos @@ -167,12 +171,14 @@ instance ToDoc Lang e clean = Data.List.nub . filter (not . null) instance ToDoc Lang Filter.Read.Error where - toDoc FR err = + toDoc lang@FR err = case err of Filter.Read.Error_Unknown -> "erreur" - toDoc EN err = + Filter.Read.Error_Test_Date d -> toDoc lang d + toDoc lang@EN err = case err of Filter.Read.Error_Unknown -> "error" + Filter.Read.Error_Test_Date d -> toDoc lang d data Message = Message_ERROR diff --git a/lib/Hcompta/Format/Ledger.hs b/lib/Hcompta/Format/Ledger.hs index 6d41af5..3a931af 100644 --- a/lib/Hcompta/Format/Ledger.hs +++ b/lib/Hcompta/Format/Ledger.hs @@ -90,14 +90,14 @@ instance Model.Filter.Transaction Transaction where transaction_postings = transaction_postings type Transaction_by_Date - = Data.Map.Map Date.UTC [Transaction] + = Data.Map.Map Date [Transaction] -- | Return a 'Data.Map.Map' associating -- the given 'Transaction's with their respective 'Date'. transaction_by_Date :: [Transaction] -> Transaction_by_Date transaction_by_Date = Data.Map.fromListWith (flip (++)) . - Data.List.map (\t -> (Date.to_UTC $ fst $ transaction_dates t, [t])) + Data.List.map (\t -> (fst $ transaction_dates t, [t])) -- * The 'Posting' type diff --git a/lib/Hcompta/Format/Ledger/Read.hs b/lib/Hcompta/Format/Ledger/Read.hs index 496cd6b..dad9358 100644 --- a/lib/Hcompta/Format/Ledger/Read.hs +++ b/lib/Hcompta/Format/Ledger/Read.hs @@ -754,7 +754,7 @@ journal_rec file_ = do Data.Map.insertWith (flip (++)) -- NOTE: flip-ing preserves order but slows down -- when many transactions have the very same date. - (Date.to_UTC $ fst $ transaction_dates t) [t] + (fst $ transaction_dates t) [t] (journal_transactions j)}} R.new_line <|> R.eof)) , R.try (comment >> return ()) diff --git a/lib/Hcompta/Format/Ledger/Write.hs b/lib/Hcompta/Format/Ledger/Write.hs index ec89094..ef74bd3 100644 --- a/lib/Hcompta/Format/Ledger/Write.hs +++ b/lib/Hcompta/Format/Ledger/Write.hs @@ -21,7 +21,7 @@ import Data.Maybe (fromMaybe) import qualified Data.Text.Lazy as TL import qualified Data.Text as Text import qualified Data.Time.Calendar as Time (toGregorian) -import qualified Data.Time.LocalTime as Time (LocalTime(..), TimeOfDay(..), TimeZone(..), timeZoneOffsetString, ZonedTime(..)) +import qualified Data.Time.LocalTime as Time import qualified Hcompta.Lib.Leijen as W import Hcompta.Lib.Leijen (Doc, (<>)) import System.IO (Handle) @@ -239,9 +239,7 @@ quantity_length Amount.Style.Style -- * Printing 'Date' date :: Date -> Doc -date (Time.ZonedTime - (Time.LocalTime day tod) - tz@(Time.TimeZone tz_min _ tz_name)) = do +date utc = do let (y, mo, d) = Time.toGregorian day (if y == 0 then W.empty else W.integer y <> sep '/') <> do int2 mo <> do @@ -261,6 +259,10 @@ date (Time.ZonedTime _ | tz_name /= "" -> W.space <> do W.strict_text $ Text.pack tz_name _ -> W.space <> do W.strict_text $ Text.pack $ Time.timeZoneOffsetString tz) where + Time.ZonedTime + (Time.LocalTime day tod) + tz@(Time.TimeZone tz_min _ tz_name) = + Time.utcToZonedTime Time.utc utc int2 :: Int -> Doc int2 i = if i < 10 then W.char '0' <> W.int i else W.int i sep :: Char -> Doc diff --git a/lib/Hcompta/Model/Date.hs b/lib/Hcompta/Model/Date.hs index 4244de6..d1faec5 100644 --- a/lib/Hcompta/Model/Date.hs +++ b/lib/Hcompta/Model/Date.hs @@ -5,21 +5,44 @@ module Hcompta.Model.Date where import Data.Data -import qualified Data.Time.LocalTime as Time (ZonedTime(..), utc, utcToZonedTime, zonedTimeToUTC) -import qualified Data.Time.Calendar as Time (Day) -import qualified Data.Time.Format as Time () +import qualified Data.Fixed +import qualified Data.Time.Calendar as Time +import qualified Data.Time.Clock as Time import qualified Data.Time.Clock.POSIX as Time (posixSecondsToUTCTime) -import qualified Data.Time.Clock as Time (UTCTime) +import qualified Data.Time.Format as Time () +import qualified Data.Time.LocalTime as Time import Data.Typeable () -- * The 'Date' type -type Date - = Time.ZonedTime -deriving instance Eq Date +type Date = Time.UTCTime nil :: Date -nil = Time.utcToZonedTime Time.utc $ Time.posixSecondsToUTCTime 0 +nil = Time.posixSecondsToUTCTime 0 + +gregorian :: Date -> (Integer, Int, Int) +gregorian = Time.toGregorian . Time.utctDay + +year :: Date -> Integer +year = (\(x, _, _) -> x) . gregorian + +month :: Date -> Int +month = (\(_, x, _) -> x) . gregorian + +dom :: Date -> Int +dom = (\(_, _, x) -> x) . gregorian + +tod :: Date -> Time.TimeOfDay +tod = Time.timeToTimeOfDay . Time.utctDayTime + +hour :: Date -> Int +hour = (\(Time.TimeOfDay x _ _) -> x) . tod + +minute :: Date -> Int +minute = (\(Time.TimeOfDay _ x _) -> x) . tod + +second :: Date -> Data.Fixed.Pico +second = (\(Time.TimeOfDay _ _ x) -> x) . tod data Interval = Interval_None @@ -50,10 +73,3 @@ data Which type Year = Integer --- * The 'UTC' type - -type UTC = Time.UTCTime - -to_UTC :: Date -> UTC -to_UTC = Time.zonedTimeToUTC - diff --git a/lib/Hcompta/Model/Date/Read.hs b/lib/Hcompta/Model/Date/Read.hs index f88967d..3cde424 100644 --- a/lib/Hcompta/Model/Date/Read.hs +++ b/lib/Hcompta/Model/Date/Read.hs @@ -8,7 +8,6 @@ module Hcompta.Model.Date.Read where import Control.Applicative ((<$>)) -import Control.Monad (guard) import qualified Data.Time.Calendar as Time import qualified Data.Time.LocalTime as Time import Data.Time.LocalTime (TimeZone(..)) @@ -34,55 +33,51 @@ data Error = Error_year_or_day_is_missing | Error_invalid_date (Integer, Int, Int) | Error_invalid_time_of_day (Int, Int, Integer) - deriving (Show) + deriving (Eq, Show) -- | Read a 'Date' in [YYYY/]MM/DD [HH:MM[:SS][TZ]] format. date :: (Stream s (R.Error_State e m) Char, Monad m) => (Error -> e) -> Maybe Integer -> ParsecT s u (R.Error_State e m) Date date err def_year = (do + let read_2_or_1_digits = R.try (R.count 2 R.digit) <|> R.count 1 R.digit n0 <- R.many1 R.digit day_sep <- date_separator - n1 <- R.try (R.count 2 R.digit) <|> R.count 1 R.digit + n1 <- read_2_or_1_digits n2 <- R.option Nothing $ R.try $ do _ <- R.char day_sep - Just <$> do R.try (R.count 2 R.digit) <|> R.count 1 R.digit + Just <$> read_2_or_1_digits (year, m, d) <- case (n2, def_year) of (Nothing, Nothing) -> R.fail_with "date" (err $ Error_year_or_day_is_missing) (Nothing, Just year) -> return (year, n0, n1) (Just d, _) -> return (R.integer_of_digits 10 n0, n1, d) let month = fromInteger $ R.integer_of_digits 10 m - let day = fromInteger $ R.integer_of_digits 10 d - guard $ month >= 1 && month <= 12 - guard $ day >= 1 && day <= 31 - day_ <- case Time.fromGregorianValid year month day of - Nothing -> R.fail_with "date" (err $ Error_invalid_date (year, month, day)) - Just day_ -> return day_ + let dom = fromInteger $ R.integer_of_digits 10 d + day <- case Time.fromGregorianValid year month dom of + Nothing -> R.fail_with "date" (err $ Error_invalid_date (year, month, dom)) + Just day -> return day (hour, minu, sec, tz) <- R.option (0, 0, 0, Time.utc) $ R.try $ do R.skipMany1 $ R.space_horizontal - hour <- R.try (R.count 2 R.digit) <|> R.count 1 R.digit + hour <- read_2_or_1_digits sep <- hour_separator - minu <- R.try (R.count 2 R.digit) <|> R.count 1 R.digit + minu <- read_2_or_1_digits sec <- R.option Nothing $ R.try $ do _ <- R.char sep - Just <$> (R.try (R.count 2 R.digit) <|> R.count 1 R.digit) + Just <$> read_2_or_1_digits tz <- R.option Time.utc $ R.try $ do R.skipMany $ R.space_horizontal time_zone return ( fromInteger $ R.integer_of_digits 10 hour , fromInteger $ R.integer_of_digits 10 minu - , maybe 0 (R.integer_of_digits 10) sec + , maybe 0 (R.integer_of_digits 10) sec , tz ) tod <- case Time.makeTimeOfDayValid hour minu (fromInteger sec) of Nothing -> R.fail_with "date" (err $ Error_invalid_time_of_day (hour, minu, sec)) Just tod -> return tod - return $ - Time.ZonedTime - (Time.LocalTime day_ tod) - tz + return $ Time.localTimeToUTC tz (Time.LocalTime day tod) ) "date" -- | Parse the year, month and day separator: '/' or '-'. diff --git a/lib/Hcompta/Model/Filter.hs b/lib/Hcompta/Model/Filter.hs index 6a7298f..3ff61c8 100644 --- a/lib/Hcompta/Model/Filter.hs +++ b/lib/Hcompta/Model/Filter.hs @@ -9,6 +9,7 @@ module Hcompta.Model.Filter where import Prelude hiding (filter) import Control.Applicative (pure, (<$>), (<*>)) import Data.Data +import qualified Data.Fixed import qualified Data.Foldable import Data.Foldable (Foldable(..)) import qualified Data.Functor.Compose @@ -27,7 +28,7 @@ import qualified Data.List.NonEmpty as NonEmpty -- import Data.List.NonEmpty (NonEmpty(..)) import qualified Hcompta.Lib.Regex as Regex import Hcompta.Lib.Regex (Regex) -import qualified Hcompta.Model.Date as Date () +import qualified Hcompta.Model.Date as Date import Hcompta.Model.Date (Date) import qualified Hcompta.Model.Account as Account import Hcompta.Model.Account (Account) @@ -120,24 +121,48 @@ instance Test Test_Text Text where -- ** Type 'Test_Ord' -data Ord o - => Test_Ord o - = Test_Ord_Lt o - | Test_Ord_Lt_Eq o - | Test_Ord_Gt o - | Test_Ord_Gt_Eq o - | Test_Ord_Eq o +data Ord o + => Test_Ord o + = Test_Ord_Lt o + | Test_Ord_Le o + | Test_Ord_Gt o + | Test_Ord_Ge o + | Test_Ord_Eq o deriving (Data, Eq, Show, Typeable) instance (Ord o, o ~ x) => Test (Test_Ord o) x where test p x = case p of - Test_Ord_Lt o -> (<) o x - Test_Ord_Lt_Eq o -> (<=) o x - Test_Ord_Gt o -> (>) o x - Test_Ord_Gt_Eq o -> (>=) o x - Test_Ord_Eq o -> (==) o x + Test_Ord_Lt o -> (<) x o + Test_Ord_Le o -> (<=) x o + Test_Ord_Gt o -> (>) x o + Test_Ord_Ge o -> (>=) x o + Test_Ord_Eq o -> (==) x o + +-- ** Type 'Test_Range' + +data Test_Range a + = Test_Range_Eq a + | Test_Range_In (Maybe a) (Maybe a) + deriving (Show) + +test_range_all :: Test_Range a +test_range_all = + Test_Range_In Nothing Nothing + +instance (Ord o, o ~ x) + => Test (Test_Range o) x where + test p x = + case p of + Test_Range_Eq o -> (==) x o + Test_Range_In (Just a0) (Just a1) -> (<=) a0 x && (<=) x a1 + Test_Range_In Nothing (Just a1) -> (<=) x a1 + Test_Range_In (Just a0) Nothing -> (<=) a0 x + Test_Range_In Nothing Nothing -> True +instance Functor Test_Range where + fmap f (Test_Range_Eq a) = Test_Range_Eq (f a) + fmap f (Test_Range_In a0 a1) = Test_Range_In (fmap f a0) (fmap f a1) -- ** Type 'Test_Num_Abs' @@ -253,6 +278,28 @@ instance Amount a test fu (amount_unit amt) && test fq (amount_quantity amt) +-- ** Type 'Test_Date' + +data Test_Date + = Test_Date_UTC (Test_Ord Date) + | Test_Date_Year (Test_Range Integer) + | Test_Date_Month (Test_Range Int) + | Test_Date_DoM (Test_Range Int) + | Test_Date_Hour (Test_Range Int) + | Test_Date_Minute (Test_Range Int) + | Test_Date_Second (Test_Range Data.Fixed.Pico) + deriving (Typeable) +deriving instance Show (Test_Date) + +instance Test Test_Date Date where + test (Test_Date_UTC f) d = test f d + test (Test_Date_Year f) d = test f $ Date.year d + test (Test_Date_Month f) d = test f $ Date.month d + test (Test_Date_DoM f) d = test f $ Date.dom d + test (Test_Date_Hour f) d = test f $ Date.hour d + test (Test_Date_Minute f) d = test f $ Date.minute d + test (Test_Date_Second f) d = test f $ Date.second d + -- ** Type 'Test_Posting' data Posting posting @@ -290,6 +337,7 @@ instance (Transaction t, Transaction_Posting t ~ p, Posting p) case pr of (Test_Transaction_Description _) -> True (Test_Transaction_Posting f) -> test f p + (Test_Transaction_Date _) -> True -- TODO: use posting_date -- ** Type 'Test_Transaction' @@ -297,8 +345,8 @@ data Transaction t => Test_Transaction t = Test_Transaction_Description Test_Text | Test_Transaction_Posting (Test_Posting (Transaction_Posting t)) + | Test_Transaction_Date (Test_Bool Test_Date) deriving (Typeable) -deriving instance Transaction t => Eq (Test_Transaction t) deriving instance Transaction t => Show (Test_Transaction t) instance Transaction t @@ -309,6 +357,8 @@ instance Transaction t Data.Foldable.any (test f) $ Data.Functor.Compose.Compose $ transaction_postings t + test (Test_Transaction_Date f) t = + test f $ transaction_date t -- ** Type 'Test_Balance' diff --git a/lib/Hcompta/Model/Filter/Read.hs b/lib/Hcompta/Model/Filter/Read.hs index c52eebd..4dd51a1 100644 --- a/lib/Hcompta/Model/Filter/Read.hs +++ b/lib/Hcompta/Model/Filter/Read.hs @@ -1,15 +1,21 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} module Hcompta.Model.Filter.Read where import Prelude hiding (filter) -import Control.Applicative ((<$>){-, (<*>)-}, (<*)) +import Control.Applicative ((<$>), (<*)) +import Control.Exception (assert) import Control.Monad (liftM) -- import Control.Monad.Trans.Except (ExceptT(..), throwE) import qualified Data.Char import Data.Data import qualified Data.Foldable import Data.Functor.Identity (Identity) +import Data.Maybe (catMaybes) +import qualified Data.Time.Calendar as Time +import qualified Data.Time.Clock as Time import qualified Text.Parsec.Expr as R import qualified Text.Parsec as R hiding ( char @@ -33,19 +39,11 @@ import Data.Typeable () import qualified Hcompta.Lib.Regex as Regex -- import Hcompta.Lib.Regex (Regex) import qualified Hcompta.Model.Account as Account +import qualified Hcompta.Model.Date as Date +import Hcompta.Model.Date (Date) +import qualified Hcompta.Model.Date.Read as Date.Read import qualified Hcompta.Model.Filter as Filter import Hcompta.Model.Filter - ( -- Filter(..) - Test_Account - , Test_Account_Section(..) - , Test_Bool(..) - , Test_Num_Abs(..) - , Test_Ord(..) - , Test_Posting(..) - , Test_Text(..) - , Test_Transaction(..) - , Test_Balance(..) - ) import qualified Hcompta.Lib.Parsec as R -- * Parsers' types @@ -54,19 +52,34 @@ import qualified Hcompta.Lib.Parsec as R data Context = Context - { + { context_date :: Date } deriving (Data, Eq, Show, Typeable) context :: Context -context = Context +context = + Context + { context_date = Date.nil + } -- ** Type 'Error' data Error = Error_Unknown - deriving (Eq, Show) + | Error_Test_Date Date.Read.Error + deriving (Show) --- * Reading +-- * Read + +read :: + ( Stream s (R.Error_State Error Identity) Char + , Show t + ) + => ParsecT s Context (R.Error_State Error Identity) (Test_Bool t) + -> s -> IO (Either [R.Error Error] (Test_Bool t)) +read t s = do + context_date <- Time.getCurrentTime + return $ + R.runParser_with_Error t context{context_date} "" s -- ** Read 'Test_Text' test_text @@ -82,14 +95,26 @@ test_text = -- ** Read 'Test_Ord' test_ord :: (Stream s m Char, Ord o) - => ParsecT s u m (o -> m (Test_Ord o)) + => ParsecT s u m (o -> Test_Ord o) test_ord = R.choice_try - [ R.string "=" >> return (return . Test_Ord_Eq) - , R.string "<=" >> return (return . Test_Ord_Lt_Eq) - , R.string ">=" >> return (return . Test_Ord_Gt_Eq) - , R.string "<" >> return (return . Test_Ord_Lt) - , R.string ">" >> return (return . Test_Ord_Gt) + [ R.string "=" >> return Test_Ord_Eq + , R.string "<=" >> return Test_Ord_Le + , R.string ">=" >> return Test_Ord_Ge + , R.string "<" >> return Test_Ord_Lt + , R.string ">" >> return Test_Ord_Gt + ] + +test_ord_operator + :: Stream s m Char + => ParsecT s u m String +test_ord_operator = + R.choice_try + [ R.string "=" + , R.string "<=" + , R.string ">=" + , R.string "<" + , R.string ">" ] -- ** Read 'Test_Num_Abs' @@ -263,6 +288,108 @@ test_account = do R.many1_separated (test_account_section make_test_text) $ R.char account_name_sep +-- ** Read 'Test_Date' +test_date + :: (Stream s (R.Error_State Error m) Char, Monad m) + => ParsecT s Context (R.Error_State Error m) (Test_Bool Test_Date) +test_date = do + R.choice_try + [ R.char '=' >> + (return $ read_date_pattern) + , test_ord >>= \tst -> + return $ do + ctx <- R.getState + let (year, _, _) = Date.gregorian $ context_date ctx + Date.Read.date Error_Test_Date (Just year) + >>= return . Bool . Test_Date_UTC . tst + ] >>= id + where + read_date_pattern + :: (Stream s (R.Error_State e m) Char, Monad m) + => ParsecT s u (R.Error_State e m) (Test_Bool Test_Date) + read_date_pattern = (do + let read2 = R.try (R.count 2 R.digit) <|> R.count 1 R.digit + n0 <- read_range $ R.many1 R.digit + n1 <- R.option Nothing $ R.try $ do + _ <- R.char '/' + Just <$> read_range read2 + n2 <- R.option Nothing $ R.try $ do + _ <- R.char '/' + Just <$> read_range read2 + let (year, month, dom) = + case (n1, n2) of + (Nothing, Nothing) -> + ( test_range_all + , of_digits <$> n0 + , test_range_all ) + (Just d1, Nothing) -> + ( test_range_all + , of_digits <$> n0 + , of_digits <$> d1 ) + (Nothing, Just _d2) -> assert False undefined + (Just d1, Just d2) -> + ( R.integer_of_digits 10 <$> n0 + , of_digits <$> d1 + , of_digits <$> d2 ) + (hour, minute, second) <- + R.option (test_range_all, test_range_all, test_range_all) $ R.try $ do + R.skipMany1 $ R.space_horizontal + hour <- read_range read2 + sep <- Date.Read.hour_separator + minute <- read_range read2 + second <- R.option test_range_all $ R.try $ do + _ <- R.char sep + read_range $ R.many1 R.digit + -- tz <- R.option Time.utc $ R.try $ do + -- R.skipMany $ R.space_horizontal + -- Date.Read.time_zone + return + ( of_digits <$> hour + , of_digits <$> minute + , of_digits <$> second + ) + return $ + foldr And Any $ + catMaybes $ + [ just_when_bounded Test_Date_Year year + , just_when_bounded Test_Date_Month month + , just_when_bounded Test_Date_DoM dom + , just_when_bounded Test_Date_Hour hour + , just_when_bounded Test_Date_Minute minute + , just_when_bounded Test_Date_Second second + ] + ) "date-filter" + where + of_digits :: Num n => [Char] -> n + of_digits = fromInteger . R.integer_of_digits 10 + just_when_bounded f x = + case x of + Test_Range_In Nothing Nothing -> Nothing + _ -> Just $ Bool $ f x + +read_range :: Stream s m Char + => ParsecT s u m a + -> ParsecT s u m (Test_Range a) +read_range read_digits = do + a0 <- R.choice_try + [ R.char '*' >> return Nothing + , Just <$> read_digits + ] + R.choice_try + [ R.char '-' >> + (Test_Range_In a0 <$> R.choice_try + [ R.char '*' >> return Nothing + , Just <$> read_digits + ]) + , return $ maybe test_range_all Test_Range_Eq a0 + ] + +test_date_operator + :: Stream s m Char + => ParsecT s u m String +test_date_operator = + test_ord_operator + -- ** Read 'Test_Posting' test_posting :: (Stream s m Char, Filter.Posting t) @@ -285,8 +412,8 @@ test_posting_terms = -- ** Read 'Test_Transaction' test_transaction - :: (Stream s m Char, Filter.Transaction t) - => ParsecT s Context m (Test_Bool (Test_Transaction t)) + :: (Stream s (R.Error_State Error m) Char, Monad m, Filter.Transaction t) + => ParsecT s Context (R.Error_State Error m) (Test_Bool (Test_Transaction t)) test_transaction = Data.Foldable.foldr Filter.And Filter.Any <$> do R.many $ @@ -295,19 +422,17 @@ test_transaction = >> test_bool test_transaction_terms test_transaction_terms - :: (Stream s m Char, Filter.Transaction t) - => [ParsecT s Context m (ParsecT s Context m (Test_Transaction t))] + :: (Stream s (R.Error_State Error m) Char, Filter.Transaction t, Monad m) + => [ParsecT s Context (R.Error_State Error m) + (ParsecT s Context (R.Error_State Error m) (Test_Transaction t))] test_transaction_terms = - [ return - ( Filter.Test_Transaction_Posting - . Filter.Test_Posting_Account - <$> test_account ) -- , jump [ "account","acct" ] comp_text test_account -- , jump [ "amount", "amt" ] comp_num parseFilterAmount -- , jump [ "atag" ] comp_text parseFilterATag -- , jump [ "balance", "bal" ] comp_num parseFilterBalance -- , jump [ "code" ] comp_text parseFilterCode - -- , jump [ "date" ] (R.char '=') parseFilterDate + [ jump [ "date" ] test_date_operator + (Filter.Test_Transaction_Date <$> test_date) -- , jump [ "date2", "edate" ] (R.char '=') parseFilterDate2 -- , jump [ "depth" ] comp_num parseFilterDepth -- , jump [ "description","descr","desc" ] comp_text parseFilterDesc @@ -316,13 +441,21 @@ test_transaction_terms = -- , jump [ "sym" ] comp_text parseFilterSym -- , jump [ "tag" ] comp_text parseFilterTag -- , R.lookAhead comp_num >> return parseFilterAmount + , return + ( Filter.Test_Transaction_Posting + . Filter.Test_Posting_Account + <$> test_account ) ] - -- where - -- jump :: Stream s m Char => [String] -> ParsecT s u m b -> a -> ParsecT s u m a - -- jump l next r = - -- R.choice_try - -- (map (\s -> R.string s >> return r) l) - -- <* R.lookAhead next + where + jump :: Stream s m Char + => [String] + -> ParsecT s u m b + -> a + -> ParsecT s u m a + jump prefixes next r = + R.choice_try + (map (\s -> R.string s >> return r) prefixes) + <* R.lookAhead (R.try next) -- ** Read 'Test_Balance' test_balance @@ -344,16 +477,6 @@ test_balance_terms = <$> test_account ) ] --- * Parsing -read :: - ( Stream s (R.Error_State Error Identity) Char - , Show t - ) - => ParsecT s Context (R.Error_State Error Identity) (Test_Bool t) - -> s -> Either [R.Error Error] (Test_Bool t) -read t s = - R.runParser_with_Error t context "" s - {- account :: Stream s m Char => ParsecT s Context m Filter diff --git a/lib/Test/Main.hs b/lib/Test/Main.hs index 288d7d1..6c756f0 100644 --- a/lib/Test/Main.hs +++ b/lib/Test/Main.hs @@ -2406,7 +2406,8 @@ test_Hcompta = (Date.Read.date id Nothing <* P.eof) () "" ("2000/01/01"::Text)]) ~?= - [ Time.ZonedTime + [ Time.zonedTimeToUTC $ + Time.ZonedTime (Time.LocalTime (Time.fromGregorian 2000 01 01) (Time.TimeOfDay 0 0 0)) @@ -2417,7 +2418,8 @@ test_Hcompta = (Date.Read.date id Nothing) () "" ("2000/01/01 some text"::Text)]) ~?= - [ Time.ZonedTime + [ Time.zonedTimeToUTC $ + Time.ZonedTime (Time.LocalTime (Time.fromGregorian 2000 01 01) (Time.TimeOfDay 0 0 0)) @@ -2428,7 +2430,8 @@ test_Hcompta = (Date.Read.date id Nothing <* P.eof) () "" ("2000/01/01 12:34"::Text)]) ~?= - [ Time.ZonedTime + [ Time.zonedTimeToUTC $ + Time.ZonedTime (Time.LocalTime (Time.fromGregorian 2000 01 01) (Time.TimeOfDay 12 34 0)) @@ -2439,7 +2442,8 @@ test_Hcompta = (Date.Read.date id Nothing <* P.eof) () "" ("2000/01/01 12:34:56"::Text)]) ~?= - [ Time.ZonedTime + [ Time.zonedTimeToUTC $ + Time.ZonedTime (Time.LocalTime (Time.fromGregorian 2000 01 01) (Time.TimeOfDay 12 34 56)) @@ -2450,7 +2454,8 @@ test_Hcompta = (Date.Read.date id Nothing <* P.eof) () "" ("2000/01/01 12:34 CET"::Text)]) ~?= - [ Time.ZonedTime + [ Time.zonedTimeToUTC $ + Time.ZonedTime (Time.LocalTime (Time.fromGregorian 2000 01 01) (Time.TimeOfDay 12 34 0)) @@ -2461,7 +2466,8 @@ test_Hcompta = (Date.Read.date id Nothing <* P.eof) () "" ("2000/01/01 12:34 +0130"::Text)]) ~?= - [ Time.ZonedTime + [ Time.zonedTimeToUTC $ + Time.ZonedTime (Time.LocalTime (Time.fromGregorian 2000 01 01) (Time.TimeOfDay 12 34 0)) @@ -2472,7 +2478,8 @@ test_Hcompta = (Date.Read.date id Nothing <* P.eof) () "" ("2000/01/01 12:34:56 CET"::Text)]) ~?= - [ Time.ZonedTime + [ Time.zonedTimeToUTC $ + Time.ZonedTime (Time.LocalTime (Time.fromGregorian 2000 01 01) (Time.TimeOfDay 12 34 56)) @@ -2490,7 +2497,8 @@ test_Hcompta = (Date.Read.date id (Just 2000) <* P.eof) () "" ("01/01"::Text)]) ~?= - [ Time.ZonedTime + [ Time.zonedTimeToUTC $ + Time.ZonedTime (Time.LocalTime (Time.fromGregorian 2000 01 01) (Time.TimeOfDay 0 0 0)) @@ -2941,7 +2949,8 @@ test_Hcompta = [ (Format.Ledger.posting ("A":|["B", "C"])) { Format.Ledger.posting_comments = [" date:2001/01/01"] , Format.Ledger.posting_dates = - [ Time.ZonedTime + [ Time.zonedTimeToUTC $ + Time.ZonedTime (Time.LocalTime (Time.fromGregorian 2001 01 01) (Time.TimeOfDay 0 0 0)) @@ -2987,7 +2996,8 @@ test_Hcompta = ~?= [ Format.Ledger.transaction { Format.Ledger.transaction_dates= - ( Time.ZonedTime + ( Time.zonedTimeToUTC $ + Time.ZonedTime (Time.LocalTime (Time.fromGregorian 2000 01 01) (Time.TimeOfDay 0 0 0)) @@ -3033,7 +3043,8 @@ test_Hcompta = ~?= [ Format.Ledger.transaction { Format.Ledger.transaction_dates= - ( Time.ZonedTime + ( Time.zonedTimeToUTC $ + Time.ZonedTime (Time.LocalTime (Time.fromGregorian 2000 01 01) (Time.TimeOfDay 0 0 0)) @@ -3085,7 +3096,8 @@ test_Hcompta = , " some last comment" ] , Format.Ledger.transaction_dates= - ( Time.ZonedTime + ( Time.zonedTimeToUTC $ + Time.ZonedTime (Time.LocalTime (Time.fromGregorian 2000 01 01) (Time.TimeOfDay 0 0 0)) @@ -3143,7 +3155,8 @@ test_Hcompta = Format.Ledger.transaction_by_Date [ Format.Ledger.transaction { Format.Ledger.transaction_dates= - ( Time.ZonedTime + ( Time.zonedTimeToUTC $ + Time.ZonedTime (Time.LocalTime (Time.fromGregorian 2000 01 01) (Time.TimeOfDay 0 0 0)) @@ -3182,7 +3195,8 @@ test_Hcompta = } , Format.Ledger.transaction { Format.Ledger.transaction_dates= - ( Time.ZonedTime + ( Time.zonedTimeToUTC $ + Time.ZonedTime (Time.LocalTime (Time.fromGregorian 2000 01 02) (Time.TimeOfDay 0 0 0)) @@ -3621,13 +3635,14 @@ test_Hcompta = , Format.Ledger.Write.style_align=True } $ Format.Ledger.Write.date $ + Time.zonedTimeToUTC $ Time.ZonedTime (Time.LocalTime (Time.fromGregorian 2000 01 01) (Time.TimeOfDay 12 34 51)) (Time.TimeZone 60 False "CET")) ~?= - "2000/01/01 12:34:51 CET" + "2000/01/01 11:34:51" , "2000/01/01 12:34:51 +0100" ~: (Format.Ledger.Write.show Format.Ledger.Write.Style @@ -3635,13 +3650,14 @@ test_Hcompta = , Format.Ledger.Write.style_align=True } $ Format.Ledger.Write.date $ + Time.zonedTimeToUTC $ Time.ZonedTime (Time.LocalTime (Time.fromGregorian 2000 01 01) (Time.TimeOfDay 12 34 51)) (Time.TimeZone 60 False "")) ~?= - "2000/01/01 12:34:51 +0100" + "2000/01/01 11:34:51" , "2000/01/01 01:02:03" ~: (Format.Ledger.Write.show Format.Ledger.Write.Style @@ -3649,6 +3665,7 @@ test_Hcompta = , Format.Ledger.Write.style_align=True } $ Format.Ledger.Write.date $ + Time.zonedTimeToUTC $ Time.ZonedTime (Time.LocalTime (Time.fromGregorian 2000 01 01) @@ -3663,6 +3680,7 @@ test_Hcompta = , Format.Ledger.Write.style_align=True } $ Format.Ledger.Write.date $ + Time.zonedTimeToUTC $ Time.ZonedTime (Time.LocalTime (Time.fromGregorian 0 01 01) @@ -3677,6 +3695,7 @@ test_Hcompta = , Format.Ledger.Write.style_align=True } $ Format.Ledger.Write.date $ + Time.zonedTimeToUTC $ Time.ZonedTime (Time.LocalTime (Time.fromGregorian 0 01 01) @@ -3691,6 +3710,7 @@ test_Hcompta = , Format.Ledger.Write.style_align=True } $ Format.Ledger.Write.date $ + Time.zonedTimeToUTC $ Time.ZonedTime (Time.LocalTime (Time.fromGregorian 0 01 01) @@ -3705,6 +3725,7 @@ test_Hcompta = , Format.Ledger.Write.style_align=True } $ Format.Ledger.Write.date $ + Time.zonedTimeToUTC $ Time.ZonedTime (Time.LocalTime (Time.fromGregorian 0 01 01) @@ -3733,7 +3754,8 @@ test_Hcompta = Format.Ledger.Write.transaction $ Format.Ledger.transaction { Format.Ledger.transaction_dates= - ( Time.ZonedTime + ( Time.zonedTimeToUTC $ + Time.ZonedTime (Time.LocalTime (Time.fromGregorian 2000 01 01) (Time.TimeOfDay 0 0 0)) @@ -3769,7 +3791,8 @@ test_Hcompta = Format.Ledger.Write.transaction $ Format.Ledger.transaction { Format.Ledger.transaction_dates= - ( Time.ZonedTime + ( Time.zonedTimeToUTC $ + Time.ZonedTime (Time.LocalTime (Time.fromGregorian 2000 01 01) (Time.TimeOfDay 0 0 0)) -- 2.47.2 From 4a7b9eb9a4ebc272eeea2a41c708115635bd0067 Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Fri, 19 Jun 2015 23:32:03 +0200 Subject: [PATCH 07/16] Ajout : Model.Filter : Test_Tag. --- lib/Hcompta/Format/Ledger.hs | 1 + lib/Hcompta/Model/Filter.hs | 33 ++++++++- lib/Hcompta/Model/Filter/Read.hs | 117 +++++++++++++++++++++++++------ lib/Test/Main.hs | 46 +++++++++++- 4 files changed, 169 insertions(+), 28 deletions(-) diff --git a/lib/Hcompta/Format/Ledger.hs b/lib/Hcompta/Format/Ledger.hs index 3a931af..7e235ea 100644 --- a/lib/Hcompta/Format/Ledger.hs +++ b/lib/Hcompta/Format/Ledger.hs @@ -88,6 +88,7 @@ instance Model.Filter.Transaction Transaction where transaction_date = fst . transaction_dates transaction_description = transaction_description transaction_postings = transaction_postings + transaction_tags = transaction_tags type Transaction_by_Date = Data.Map.Map Date [Transaction] diff --git a/lib/Hcompta/Model/Filter.hs b/lib/Hcompta/Model/Filter.hs index 3ff61c8..48ecd58 100644 --- a/lib/Hcompta/Model/Filter.hs +++ b/lib/Hcompta/Model/Filter.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} module Hcompta.Model.Filter where @@ -14,11 +15,12 @@ import qualified Data.Foldable import Data.Foldable (Foldable(..)) import qualified Data.Functor.Compose import Data.Traversable (Traversable(..)) +import qualified Data.Monoid import Data.Monoid (Monoid(..)) import Data.Typeable () import Data.Text (Text) -- import qualified Data.Text as Text --- import qualified Data.Map.Strict as Data.Map +import qualified Data.Map.Strict as Data.Map import Data.Map.Strict (Map) import Text.Regex.TDFA () import Text.Regex.Base () @@ -79,6 +81,7 @@ class Posting (Transaction_Posting t) transaction_date :: t -> Date transaction_description :: t -> Text transaction_postings :: t -> Map Account [Transaction_Posting t] + transaction_tags :: t -> Map Text [Text] -- ** Class 'Balance' @@ -109,13 +112,15 @@ filter p = -- ** Type 'Test_Text' data Test_Text - = Test_Text_Exact Text + = Test_Text_Any + | Test_Text_Exact Text | Test_Text_Regex Regex deriving (Eq, Show, Typeable) instance Test Test_Text Text where test p x = case p of + Test_Text_Any -> True Test_Text_Exact m -> (==) m x Test_Text_Regex m -> Regex.match m x @@ -184,6 +189,7 @@ data Test_Bool p | And (Test_Bool p) (Test_Bool p) | Or (Test_Bool p) (Test_Bool p) deriving (Show) +deriving instance Eq p => Eq (Test_Bool p) instance Functor Test_Bool where fmap _ Any = Any fmap f (Bool x) = Bool (f x) @@ -300,6 +306,18 @@ instance Test Test_Date Date where test (Test_Date_Minute f) d = test f $ Date.minute d test (Test_Date_Second f) d = test f $ Date.second d +-- ** Type 'Test_Tag' + +data Test_Tag + = Test_Tag_Name Test_Text + | Test_Tag_Value Test_Text + deriving (Typeable) +deriving instance Show (Test_Tag) + +instance Test Test_Tag (Text, Text) where + test (Test_Tag_Name f) (x, _) = test f x + test (Test_Tag_Value f) (_, x) = test f x + -- ** Type 'Test_Posting' data Posting posting @@ -337,7 +355,8 @@ instance (Transaction t, Transaction_Posting t ~ p, Posting p) case pr of (Test_Transaction_Description _) -> True (Test_Transaction_Posting f) -> test f p - (Test_Transaction_Date _) -> True -- TODO: use posting_date + (Test_Transaction_Date _) -> True -- TODO: use posting_date + (Test_Transaction_Tag _) -> False -- TODO: use posting_tags -- ** Type 'Test_Transaction' @@ -346,6 +365,7 @@ data Transaction t = Test_Transaction_Description Test_Text | Test_Transaction_Posting (Test_Posting (Transaction_Posting t)) | Test_Transaction_Date (Test_Bool Test_Date) + | Test_Transaction_Tag (Test_Bool Test_Tag) deriving (Typeable) deriving instance Transaction t => Show (Test_Transaction t) @@ -359,6 +379,13 @@ instance Transaction t transaction_postings t test (Test_Transaction_Date f) t = test f $ transaction_date t + test (Test_Transaction_Tag f) t = + Data.Monoid.getAny $ + Data.Map.foldrWithKey + (\n -> mappend . Data.Monoid.Any . + Data.Foldable.any (test f . (n,))) + (Data.Monoid.Any False) $ + transaction_tags t -- ** Type 'Test_Balance' diff --git a/lib/Hcompta/Model/Filter/Read.hs b/lib/Hcompta/Model/Filter/Read.hs index 4dd51a1..3f9c285 100644 --- a/lib/Hcompta/Model/Filter/Read.hs +++ b/lib/Hcompta/Model/Filter/Read.hs @@ -14,7 +14,6 @@ import Data.Data import qualified Data.Foldable import Data.Functor.Identity (Identity) import Data.Maybe (catMaybes) -import qualified Data.Time.Calendar as Time import qualified Data.Time.Clock as Time import qualified Text.Parsec.Expr as R import qualified Text.Parsec as R hiding @@ -92,6 +91,15 @@ test_text = , return (\s -> return (Test_Text_Exact $ Text.pack s)) ] +test_text_operator + :: Stream s m Char + => ParsecT s u m String +test_text_operator = + R.choice_try + [ R.string "=" + , R.string "~" + ] + -- ** Read 'Test_Ord' test_ord :: (Stream s m Char, Ord o) @@ -143,8 +151,8 @@ text none_of = test_bool :: (Stream s m Char) - => [ParsecT s Context m (ParsecT s Context m t)] - -> ParsecT s Context m (Test_Bool t) + => [ParsecT s u m (ParsecT s u m t)] + -> ParsecT s u m (Test_Bool t) test_bool terms = R.buildExpressionParser test_bool_operators @@ -188,17 +196,17 @@ test_bool_operator_letter = test_bool_term :: Stream s m Char - => [ParsecT s Context m (ParsecT s Context m t)] - -> ParsecT s Context m (Test_Bool t) + => [ParsecT s u m (ParsecT s u m t)] + -> ParsecT s u m (Test_Bool t) test_bool_term terms = do - r <- R.choice_try - ( (R.lookAhead (R.try $ R.char '(') + R.choice_try + ( (R.lookAhead (R.try (R.spaces >> R.char '(')) >> (return $ parens $ Data.Foldable.foldr Filter.And Filter.Any <$> - R.many (R.spaces >> expr) )) + R.many (R.try (R.spaces >> expr)) )) : map ((Filter.Bool <$>) <$>) terms - ) <* R.spaces "filter expression" - r + ) <* R.spaces "boolean-expression" + >>= id where expr = R.lookAhead (R.try R.anyToken) @@ -207,13 +215,18 @@ test_bool_term terms = do lexeme :: Stream s m Char - => ParsecT s u m a -> ParsecT s u m a + => ParsecT s u m a + -> ParsecT s u m a lexeme p = p <* R.spaces parens :: Stream s m Char - => ParsecT s u m a -> ParsecT s u m a -parens = R.between (lexeme $ R.char '(') (lexeme $ R.char ')') + => ParsecT s u m a + -> ParsecT s u m a +parens = + R.between + (R.spaces >> R.char '(') + (R.spaces >> R.char ')') bool :: Stream s m Char => ParsecT s u m Bool bool = do @@ -241,11 +254,11 @@ account_name = do c <- R.anyChar case c of -- _ | c == comment_begin -> R.parserZero - -- _ | c == account_name_sep -> R.parserZero + -- _ | c == account_section_sep -> R.parserZero _ | R.is_space_horizontal c -> do _ <- R.notFollowedBy $ R.space_horizontal return c <* (R.lookAhead $ R.try $ - ( R.try (R.char account_name_sep) + ( R.try (R.char account_section_sep) <|> account_name_char )) _ | not (Data.Char.isSpace c) -> return c @@ -261,23 +274,23 @@ test_account_section make_test_text = do [ R.char '*' <* R.lookAhead account_section_end >> return Test_Account_Section_Any - , R.many1 (R.satisfy (\c -> c /= account_name_sep && not (Data.Char.isSpace c))) + , R.many1 (R.satisfy (\c -> c /= account_section_sep && not (Data.Char.isSpace c))) >>= (liftM Test_Account_Section_Text . make_test_text) , R.lookAhead account_section_end - >> R.many (R.try (R.char account_name_sep >> R.lookAhead (R.try account_section_end))) + >> R.many (R.try (R.char account_section_sep >> R.lookAhead (R.try account_section_end))) >> return Test_Account_Section_Many ] where account_section_end = R.choice_try - [ R.char account_name_sep >> return () + [ R.char account_section_sep >> return () , R.space_horizontal >> return () , R.eof ] -- ** Read 'Test_Account' -account_name_sep :: Char -account_name_sep = ':' +account_section_sep :: Char +account_section_sep = ':' test_account :: Stream s m Char @@ -286,7 +299,7 @@ test_account = do R.notFollowedBy $ R.space_horizontal make_test_text <- test_text R.many1_separated (test_account_section make_test_text) $ - R.char account_name_sep + R.char account_section_sep -- ** Read 'Test_Date' test_date @@ -390,6 +403,65 @@ test_date_operator test_date_operator = test_ord_operator +-- ** Read 'Test_Tag' +tag_name_sep :: Char +tag_name_sep = ':' + +test_tag_name + :: Stream s m Char + => ParsecT s u m Test_Tag +test_tag_name = do + make_test_text <- test_text + R.choice_try + [ R.char '*' + <* R.lookAhead test_tag_name_end + >> return (Test_Tag_Name Test_Text_Any) + , R.many1 (R.notFollowedBy (R.try test_tag_name_end) >> R.anyChar) + >>= (liftM Test_Tag_Name . make_test_text) + ] + where + test_tag_name_end = + R.choice_try + [ test_text_operator >> return () + , R.space_horizontal >> return () + , R.eof + ] +test_tag_value + :: Stream s m Char + => ParsecT s u m Test_Tag +test_tag_value = do + make_test_text <- test_text + R.choice_try + [ R.char '*' + <* R.lookAhead test_tag_value_end + >> return (Test_Tag_Value Test_Text_Any) + , R.many1 (R.notFollowedBy (R.try test_tag_value_end) >> R.anyChar) + >>= (liftM Test_Tag_Value . make_test_text) + ] + where + test_tag_value_end = + R.choice_try + [ R.space_horizontal >> return () + , R.eof + ] + +test_tag + :: Stream s m Char + => ParsecT s u m (Test_Bool Test_Tag) +test_tag = do + n <- test_tag_name + R.choice_try + [ R.lookAhead (R.try $ test_tag_operator) + >> And (Bool n) . Bool <$> test_tag_value + , return $ Bool n + ] + +test_tag_operator + :: Stream s m Char + => ParsecT s u m String +test_tag_operator = + test_text_operator + -- ** Read 'Test_Posting' test_posting :: (Stream s m Char, Filter.Posting t) @@ -433,13 +505,14 @@ test_transaction_terms = -- , jump [ "code" ] comp_text parseFilterCode [ jump [ "date" ] test_date_operator (Filter.Test_Transaction_Date <$> test_date) + , jump [ "tag" ] test_tag_operator + (Filter.Test_Transaction_Tag <$> test_tag) -- , jump [ "date2", "edate" ] (R.char '=') parseFilterDate2 -- , jump [ "depth" ] comp_num parseFilterDepth -- , jump [ "description","descr","desc" ] comp_text parseFilterDesc -- , jump [ "real" ] (R.char '=') parseFilterReal -- , jump [ "status" ] (R.char '=') parseFilterStatus -- , jump [ "sym" ] comp_text parseFilterSym - -- , jump [ "tag" ] comp_text parseFilterTag -- , R.lookAhead comp_num >> return parseFilterAmount , return ( Filter.Test_Transaction_Posting diff --git a/lib/Test/Main.hs b/lib/Test/Main.hs index 6c756f0..ac3519a 100644 --- a/lib/Test/Main.hs +++ b/lib/Test/Main.hs @@ -17,7 +17,7 @@ import qualified Data.Map.Strict as Data.Map import Data.Text (Text) import qualified Data.Time.Calendar as Time import qualified Data.Time.LocalTime as Time -import qualified Text.Parsec as P hiding (char, space, string) +import qualified Text.Parsec as P hiding (char, space, spaces, string) import qualified Text.Parsec.Pos as P -- import qualified Text.PrettyPrint.Leijen.Text as PP @@ -223,7 +223,7 @@ test_Hcompta = ] ] , "Filter" ~: TestList - [ "filter" ~: TestList + [ "test" ~: TestList [ "Test_Account" ~: TestList [ "A A" ~? Filter.test @@ -295,9 +295,15 @@ test_Hcompta = ] (("A":|"B":"C":[]::Account)) ] + , "Test_Bool" ~: TestList + [ "Any A" ~? + Filter.test + (Filter.Any::Filter.Test_Bool Filter.Test_Account) + (("A":|[]::Account)) + ] ] , "Read" ~: TestList - [ "filter_account_section" ~: TestList + [ "test_account_section" ~: TestList [ "*" ~: (Data.Either.rights $ [P.runParser @@ -404,6 +410,40 @@ test_Hcompta = ] ] ] + , "test_bool" ~: TestList + [ "( E )" ~: + (Data.Either.rights $ + [P.runParser + (Filter.Read.test_bool + [ P.char 'E' >> return (return True) ] + <* P.eof) + () "" ("( E )"::Text)]) + ~?= + [ Filter.And (Filter.Bool True) Filter.Any + ] + , "( ( E ) )" ~: + (Data.Either.rights $ + [P.runParser + (Filter.Read.test_bool + [ P.char 'E' >> return (return True) ] + <* P.eof) + () "" ("( ( E ) )"::Text)]) + ~?= + [ Filter.And (Filter.And (Filter.Bool True) Filter.Any) Filter.Any + ] + , "( E ) & ( E )" ~: + (Data.Either.rights $ + [P.runParser + (Filter.Read.test_bool + [ P.char 'E' >> return (return True) ] + <* P.eof) + () "" ("( E ) & ( E )"::Text)]) + ~?= + [ Filter.And + (Filter.And (Filter.Bool True) Filter.Any) + (Filter.And (Filter.Bool True) Filter.Any) + ] + ] ] ] ] -- 2.47.2 From 23cfa15698d38c65ad89e342966acd165e280ca4 Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Sat, 20 Jun 2015 00:38:39 +0200 Subject: [PATCH 08/16] =?utf8?q?Polissage=20:=20utilise=20Control.Monad.jo?= =?utf8?q?in=20plut=C3=B4t=20que=20>>=3D=20id?= MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit --- lib/Hcompta/Format/Ledger/Read.hs | 3 +-- lib/Hcompta/Model/Filter/Read.hs | 11 +++++------ 2 files changed, 6 insertions(+), 8 deletions(-) diff --git a/lib/Hcompta/Format/Ledger/Read.hs b/lib/Hcompta/Format/Ledger/Read.hs index dad9358..9fce12e 100644 --- a/lib/Hcompta/Format/Ledger/Read.hs +++ b/lib/Hcompta/Format/Ledger/Read.hs @@ -694,10 +694,9 @@ include = (do let cwd = Path.takeDirectory (R.sourceName sourcepos) file_path <- liftIO $ Path.abs cwd filename content <- do - liftIO $ Exception.catch + join $ liftIO $ Exception.catch (liftM return $ readFile file_path) (return . R.fail_with "include reading" . Error_reading_file file_path) - >>= id (journal_included, context_included) <- do liftIO $ R.runParserT_with_Error (R.and_state $ journal_rec file_path) diff --git a/lib/Hcompta/Model/Filter/Read.hs b/lib/Hcompta/Model/Filter/Read.hs index 3f9c285..50e1a4b 100644 --- a/lib/Hcompta/Model/Filter/Read.hs +++ b/lib/Hcompta/Model/Filter/Read.hs @@ -7,7 +7,7 @@ module Hcompta.Model.Filter.Read where import Prelude hiding (filter) import Control.Applicative ((<$>), (<*)) import Control.Exception (assert) -import Control.Monad (liftM) +import Control.Monad (liftM, join) -- import Control.Monad.Trans.Except (ExceptT(..), throwE) import qualified Data.Char import Data.Data @@ -199,14 +199,13 @@ test_bool_term => [ParsecT s u m (ParsecT s u m t)] -> ParsecT s u m (Test_Bool t) test_bool_term terms = do - R.choice_try + join (R.choice_try ( (R.lookAhead (R.try (R.spaces >> R.char '(')) >> (return $ parens $ Data.Foldable.foldr Filter.And Filter.Any <$> R.many (R.try (R.spaces >> expr)) )) : map ((Filter.Bool <$>) <$>) terms - ) <* R.spaces "boolean-expression" - >>= id + ) <* R.spaces "boolean-expression") where expr = R.lookAhead (R.try R.anyToken) @@ -306,7 +305,7 @@ test_date :: (Stream s (R.Error_State Error m) Char, Monad m) => ParsecT s Context (R.Error_State Error m) (Test_Bool Test_Date) test_date = do - R.choice_try + join $ R.choice_try [ R.char '=' >> (return $ read_date_pattern) , test_ord >>= \tst -> @@ -315,7 +314,7 @@ test_date = do let (year, _, _) = Date.gregorian $ context_date ctx Date.Read.date Error_Test_Date (Just year) >>= return . Bool . Test_Date_UTC . tst - ] >>= id + ] where read_date_pattern :: (Stream s (R.Error_State e m) Char, Monad m) -- 2.47.2 From ff4b28323f1140a4e6e2603991c0abf4f859ace3 Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Sat, 20 Jun 2015 04:18:12 +0200 Subject: [PATCH 09/16] =?utf8?q?Correction=20:=20Model.Filter=20:=20Test?= =?utf8?q?=5FBool=20:=20op=C3=A9rateurs.?= MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit --- lib/Hcompta/Model/Filter/Read.hs | 21 ++++++-------------- lib/Test/Main.hs | 34 ++++++++++++++++++++++++++++++++ 2 files changed, 40 insertions(+), 15 deletions(-) diff --git a/lib/Hcompta/Model/Filter/Read.hs b/lib/Hcompta/Model/Filter/Read.hs index 50e1a4b..7c3d164 100644 --- a/lib/Hcompta/Model/Filter/Read.hs +++ b/lib/Hcompta/Model/Filter/Read.hs @@ -164,15 +164,11 @@ test_bool_operators => R.OperatorTable s u m (Filter.Test_Bool t) test_bool_operators = [ [ prefix "- " Filter.Not - , prefix "not " Filter.Not ] - , [ binary " & " Filter.And R.AssocLeft - , binary " and " Filter.And R.AssocLeft - , binary " - " (flip Filter.And . Filter.Not) R.AssocLeft - , binary " but " (flip Filter.And . Filter.Not) R.AssocLeft + , [ binary " & " Filter.And R.AssocLeft ] , [ binary " + " Filter.Or R.AssocLeft - , binary " or " Filter.Or R.AssocLeft + , binary " - " (\x -> Filter.And x . Filter.Not) R.AssocLeft ] ] where @@ -184,15 +180,16 @@ test_bool_operator :: Stream s m Char => String -> ParsecT s u m () test_bool_operator name = - lexeme $ R.try $ + R.try $ (R.string name >> R.notFollowedBy test_bool_operator_letter - ("end of " ++ show name)) + -- <* R.spaces + name) test_bool_operator_letter :: Stream s m Char => ParsecT s u m Char test_bool_operator_letter = - R.oneOf ['+', '-', '&'] + R.oneOf ['-', '&', '+'] test_bool_term :: Stream s m Char @@ -212,12 +209,6 @@ test_bool_term terms = do >> R.notFollowedBy (R.char ')') >> test_bool terms -lexeme - :: Stream s m Char - => ParsecT s u m a - -> ParsecT s u m a -lexeme p = p <* R.spaces - parens :: Stream s m Char => ParsecT s u m a diff --git a/lib/Test/Main.hs b/lib/Test/Main.hs index ac3519a..64af369 100644 --- a/lib/Test/Main.hs +++ b/lib/Test/Main.hs @@ -443,6 +443,40 @@ test_Hcompta = (Filter.And (Filter.Bool True) Filter.Any) (Filter.And (Filter.Bool True) Filter.Any) ] + , "( E ) + ( E )" ~: + (Data.Either.rights $ + [P.runParser + (Filter.Read.test_bool + [ P.char 'E' >> return (return True) ] + <* P.eof) + () "" ("( E ) + ( E )"::Text)]) + ~?= + [ Filter.Or + (Filter.And (Filter.Bool True) Filter.Any) + (Filter.And (Filter.Bool True) Filter.Any) + ] + , "( E ) - ( E )" ~: + (Data.Either.rights $ + [P.runParser + (Filter.Read.test_bool + [ P.char 'E' >> return (return True) ] + <* P.eof) + () "" ("( E ) - ( E )"::Text)]) + ~?= + [ Filter.And + (Filter.And (Filter.Bool True) Filter.Any) + (Filter.Not (Filter.And (Filter.Bool True) Filter.Any)) + ] + , "(- E )" ~: + (Data.Either.rights $ + [P.runParser + (Filter.Read.test_bool + [ P.char 'E' >> return (return True) ] + <* P.eof) + () "" ("(- E )"::Text)]) + ~?= + [ Filter.And (Filter.Not (Filter.Bool True)) Filter.Any + ] ] ] ] -- 2.47.2 From 9508f40557aef701bcd943b335e0d029c0667aba Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Sat, 20 Jun 2015 07:13:39 +0200 Subject: [PATCH 10/16] Ajout : Model.Filter : Test_Amount. --- lib/Hcompta/Format/Ledger/Read.hs | 180 ++---------------------------- lib/Hcompta/Model/Amount.hs | 7 -- lib/Hcompta/Model/Amount/Read.hs | 179 +++++++++++++++++++++++++++++ lib/Hcompta/Model/Amount/Unit.hs | 5 - lib/Hcompta/Model/Date/Read.hs | 6 - lib/Hcompta/Model/Filter.hs | 42 +++++-- lib/Hcompta/Model/Filter/Read.hs | 168 +++++++++------------------- lib/hcompta-lib.cabal | 1 + 8 files changed, 279 insertions(+), 309 deletions(-) create mode 100644 lib/Hcompta/Model/Amount/Read.hs diff --git a/lib/Hcompta/Format/Ledger/Read.hs b/lib/Hcompta/Format/Ledger/Read.hs index 9fce12e..00e9eb1 100644 --- a/lib/Hcompta/Format/Ledger/Read.hs +++ b/lib/Hcompta/Format/Ledger/Read.hs @@ -14,7 +14,6 @@ import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Except (ExceptT(..), throwE) import Control.Monad.Trans.Class (lift) import qualified Data.Char -import qualified Data.Decimal import qualified Data.Either import qualified Data.List import Data.List.NonEmpty (NonEmpty(..)) @@ -47,10 +46,9 @@ import qualified Hcompta.Calc.Balance as Balance import qualified Hcompta.Model.Account as Account import Hcompta.Model.Account (Account) import qualified Hcompta.Model.Amount as Amount -import Hcompta.Model.Amount (Amount) import qualified Hcompta.Model.Amount.Style as Style +import qualified Hcompta.Model.Amount.Read as Amount.Read import qualified Hcompta.Model.Amount.Unit as Unit -import Hcompta.Model.Amount.Unit (Unit) import qualified Hcompta.Model.Date as Date import Hcompta.Model.Date (Date) import qualified Hcompta.Model.Date.Read as Date.Read @@ -102,26 +100,19 @@ data Error | Error_including_file FilePath [R.Error Error] deriving (Show) --- | Parse either '-' into 'negate', or '+' or '' into 'id'. -sign :: (Stream s m Char, Num i) => ParsecT s u m (i -> i) -sign = - (R.char '-' >> return negate) - <|> (R.char '+' >> return id) - <|> return id - -- * Read 'Account' account_name_sep :: Char account_name_sep = ':' --- | Parse an 'Account'. +-- | Read an 'Account'. account :: Stream s m Char => ParsecT s u m Account account = do R.notFollowedBy $ R.space_horizontal Account.from_List <$> do R.many1_separated account_name $ R.char account_name_sep --- | Parse an Account.'Account.Name'. +-- | Read an Account.'Account.Name'. account_name :: Stream s m Char => ParsecT s u m Account.Name account_name = do fromString <$> do @@ -142,7 +133,7 @@ account_name = do _ | not (Data.Char.isSpace c) -> return c _ -> R.parserZero --- | Parse an Account.'Account.Joker_Name'. +-- | Read an Account.'Account.Joker_Name'. account_joker_name :: Stream s m Char => ParsecT s u m Account.Joker_Name account_joker_name = do n <- R.option Nothing $ (Just <$> account_name) @@ -150,19 +141,19 @@ account_joker_name = do Nothing -> R.char account_name_sep >> (return $ Account.Joker_Any) Just n' -> return $ Account.Joker_Name n' --- | Parse an Account.'Account.Joker'. +-- | Read an Account.'Account.Joker'. account_joker :: Stream s m Char => ParsecT s u m Account.Joker account_joker = do R.notFollowedBy $ R.space_horizontal R.many1_separated account_joker_name $ R.char account_name_sep --- | Parse a 'Regex'. +-- | Read a 'Regex'. account_regex :: Stream s m Char => ParsecT s u m Regex account_regex = do re <- R.many1 $ R.satisfy (not . R.is_space_horizontal) Regex.of_StringM re --- | Parse an Account.'Account.Filter'. +-- | Read an Account.'Account.Filter'. account_pattern :: Stream s m Char => ParsecT s u m Account.Pattern account_pattern = do R.choice_try @@ -171,156 +162,6 @@ account_pattern = do , Account.Pattern_Regex <$> (R.option '~' (R.char '~') >> account_regex) ] --- * Read 'Amount' - --- | Parse an 'Amount'. -amount :: Stream s m Char => ParsecT s u m Amount -amount = do - left_signing <- sign - left_unit <- - R.option Nothing $ do - u <- unit - s <- R.many $ R.space_horizontal - return $ Just $ (u, not $ null s) - (quantity_, style) <- do - signing <- sign - Quantity - { integral - , fractional - , fractioning - , grouping_integral - , grouping_fractional - } <- - R.choice_try - [ quantity '_' ',' '_' <* (R.notFollowedBy $ R.oneOf ",._") - , quantity '_' '.' '_' <* (R.notFollowedBy $ R.oneOf ",._") - , quantity ',' '.' '_' <* (R.notFollowedBy $ R.oneOf ",._") - , quantity '.' ',' '_' <* (R.notFollowedBy $ R.oneOf ",._") - ] "quantity" - let int = Data.List.concat integral - let frac_flat = Data.List.concat fractional - let frac = reverse $ Data.List.dropWhile (== '0') $ reverse $ frac_flat - let place = length frac - guard (place <= 255) - let mantissa = R.integer_of_digits 10 $ int ++ frac - return $ - ( Data.Decimal.Decimal - (fromIntegral place) - (signing mantissa) - , Style.nil - { Style.fractioning - , Style.grouping_integral - , Style.grouping_fractional - , Style.precision = fromIntegral $ length frac_flat - } - ) - (unit_, unit_side, unit_spaced) <- - case left_unit of - Just (u, s) -> - return (u, Just Style.Side_Left, Just s) - Nothing -> - R.option (Unit.nil, Nothing, Nothing) $ R.try $ do - s <- R.many $ R.space_horizontal - u <- unit - return $ (u, Just Style.Side_Right, Just $ not $ null s) - return $ - Amount.Amount - { Amount.quantity = left_signing $ quantity_ - , Amount.style = style - { Style.unit_side - , Style.unit_spaced - } - , Amount.unit = unit_ - } - -data Quantity - = Quantity - { integral :: [String] - , fractional :: [String] - , fractioning :: Maybe Style.Fractioning - , grouping_integral :: Maybe Style.Grouping - , grouping_fractional :: Maybe Style.Grouping - } - --- | Parse a 'Quantity'. -quantity - :: Stream s m Char - => Char -- ^ Integral grouping separator. - -> Char -- ^ Fractioning separator. - -> Char -- ^ Fractional grouping separator. - -> ParsecT s u m Quantity -quantity int_group_sep frac_sep frac_group_sep = do - (integral, grouping_integral) <- do - h <- R.many R.digit - case h of - [] -> return ([], Nothing) - _ -> do - t <- R.many $ R.char int_group_sep >> R.many1 R.digit - let digits = h:t - return (digits, grouping_of_digits int_group_sep digits) - (fractional, fractioning, grouping_fractional) <- - (case integral of - [] -> id - _ -> R.option ([], Nothing, Nothing)) $ do - fractioning <- R.char frac_sep - h <- R.many R.digit - t <- R.many $ R.char frac_group_sep >> R.many1 R.digit - let digits = h:t - return (digits, Just fractioning - , grouping_of_digits frac_group_sep $ reverse digits) - return $ - Quantity - { integral - , fractional - , fractioning - , grouping_integral - , grouping_fractional - } - where - grouping_of_digits :: Char -> [String] -> Maybe Style.Grouping - grouping_of_digits group_sep digits = - case digits of - [] -> Nothing - [_] -> Nothing - _ -> Just $ - Style.Grouping group_sep $ - canonicalize_grouping $ - map length $ digits - canonicalize_grouping :: [Int] -> [Int] - canonicalize_grouping groups = - Data.List.foldl -- NOTE: remove duplicates at beginning and reverse. - (\acc l0 -> case acc of - l1:_ -> if l0 == l1 then acc else l0:acc - _ -> l0:acc) [] $ - case groups of -- NOTE: keep only longer at beginning. - l0:l1:t -> if l0 > l1 then groups else l1:t - _ -> groups - --- | Parse an 'Unit'. -unit :: Stream s m Char => ParsecT s u m Unit -unit = - (quoted <|> unquoted) "unit" - where - unquoted :: Stream s m Char => ParsecT s u m Unit - unquoted = - fromString <$> do - R.many1 $ - R.satisfy $ \c -> - case Data.Char.generalCategory c of - Data.Char.CurrencySymbol -> True - Data.Char.LowercaseLetter -> True - Data.Char.ModifierLetter -> True - Data.Char.OtherLetter -> True - Data.Char.TitlecaseLetter -> True - Data.Char.UppercaseLetter -> True - _ -> False - quoted :: Stream s m Char => ParsecT s u m Unit - quoted = - fromString <$> do - R.between (R.char '"') (R.char '"') $ - R.many1 $ - R.noneOf ";\n\"" - -- * Directives directive_alias :: Stream s m Char => ParsecT s Context m () @@ -371,7 +212,7 @@ tag_value_sep = ':' tag_sep :: Char tag_sep = ',' --- | Parse a 'Tag'. +-- | Read a 'Tag'. tag :: Stream s m Char => ParsecT s u m Tag tag = (do n <- tag_name @@ -412,7 +253,6 @@ not_tag = do -- * Read 'Posting' --- | Parse a 'Posting'. posting :: (Stream s (R.Error_State Error m) Char, Monad m) => ParsecT s Context (R.Error_State Error m) (Posting, Posting_Type) @@ -438,7 +278,7 @@ posting = (do Unit.nil) (context_unit_and_style ctx) . Amount.from_List <$> do - R.many_separated amount $ do + R.many_separated Amount.Read.amount $ do R.skipMany $ R.space_horizontal _ <- R.char amount_sep R.skipMany $ R.space_horizontal @@ -674,7 +514,7 @@ default_year = (do default_unit_and_style :: Stream s m Char => ParsecT s Context m () default_unit_and_style = (do - amount_ <- amount + amount_ <- Amount.Read.amount R.skipMany R.space_horizontal >> R.new_line context_ <- R.getState R.setState context_{context_unit_and_style = diff --git a/lib/Hcompta/Model/Amount.hs b/lib/Hcompta/Model/Amount.hs index 15e1b2c..1d70e69 100644 --- a/lib/Hcompta/Model/Amount.hs +++ b/lib/Hcompta/Model/Amount.hs @@ -16,7 +16,6 @@ import qualified Hcompta.Calc.Balance as Balance import qualified Hcompta.Model.Amount.Quantity as Quantity import qualified Hcompta.Model.Amount.Style as Style import qualified Hcompta.Model.Amount.Unit as Unit -import qualified Hcompta.Model.Filter as Model.Filter -- * Type synonyms to submodules @@ -67,12 +66,6 @@ instance Balance.Amount Amount where EQ -> Nothing _ -> Just a -instance Model.Filter.Amount Amount where - type Amount_Quantity Amount = Quantity - type Amount_Unit Amount = Unit - amount_quantity = quantity - amount_unit = unit - -- | An 'Amount' is a partially valid 'Num' instance: -- -- * (+) operator requires both operand to have the same 'Unit' (homogeneity constraint). diff --git a/lib/Hcompta/Model/Amount/Read.hs b/lib/Hcompta/Model/Amount/Read.hs new file mode 100644 index 0000000..9fb4be8 --- /dev/null +++ b/lib/Hcompta/Model/Amount/Read.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +module Hcompta.Model.Amount.Read where + +import Control.Monad (guard) +import Control.Applicative ((<$>), (<|>), (<*)) +import qualified Data.Char +import qualified Data.Decimal +import qualified Data.List +import Data.String (fromString) +import Data.Typeable () +import qualified Text.Parsec as R hiding + ( char + , noneOf + , oneOf + , satisfy + ) +import Text.Parsec (Stream, ParsecT, ()) + +import qualified Hcompta.Model.Amount as Amount +import Hcompta.Model.Amount (Amount, Unit) +import qualified Hcompta.Model.Amount.Style as Style +import qualified Hcompta.Model.Amount.Unit as Unit +import qualified Hcompta.Lib.Parsec as R + +-- * Read 'Quantity' +data Quantity + = Quantity + { integral :: [String] + , fractional :: [String] + , fractioning :: Maybe Style.Fractioning + , grouping_integral :: Maybe Style.Grouping + , grouping_fractional :: Maybe Style.Grouping + } + +quantity + :: Stream s m Char + => Char -- ^ Integral grouping separator. + -> Char -- ^ Fractioning separator. + -> Char -- ^ Fractional grouping separator. + -> ParsecT s u m Quantity +quantity int_group_sep frac_sep frac_group_sep = do + (integral, grouping_integral) <- do + h <- R.many R.digit + case h of + [] -> return ([], Nothing) + _ -> do + t <- R.many $ R.char int_group_sep >> R.many1 R.digit + let digits = h:t + return (digits, grouping_of_digits int_group_sep digits) + (fractional, fractioning, grouping_fractional) <- + (case integral of + [] -> id + _ -> R.option ([], Nothing, Nothing)) $ do + fractioning <- R.char frac_sep + h <- R.many R.digit + t <- R.many $ R.char frac_group_sep >> R.many1 R.digit + let digits = h:t + return (digits, Just fractioning + , grouping_of_digits frac_group_sep $ reverse digits) + return $ + Quantity + { integral + , fractional + , fractioning + , grouping_integral + , grouping_fractional + } + where + grouping_of_digits :: Char -> [String] -> Maybe Style.Grouping + grouping_of_digits group_sep digits = + case digits of + [] -> Nothing + [_] -> Nothing + _ -> Just $ + Style.Grouping group_sep $ + canonicalize_grouping $ + map length $ digits + canonicalize_grouping :: [Int] -> [Int] + canonicalize_grouping groups = + foldl -- NOTE: remove duplicates at beginning and reverse. + (\acc l0 -> case acc of + l1:_ -> if l0 == l1 then acc else l0:acc + _ -> l0:acc) [] $ + case groups of -- NOTE: keep only longer at beginning. + l0:l1:t -> if l0 > l1 then groups else l1:t + _ -> groups + +-- * Read 'Unit' +unit :: Stream s m Char => ParsecT s u m Unit +unit = + (quoted <|> unquoted) "unit" + where + unquoted :: Stream s m Char => ParsecT s u m Unit + unquoted = + fromString <$> do + R.many1 $ + R.satisfy $ \c -> + case Data.Char.generalCategory c of + Data.Char.CurrencySymbol -> True + Data.Char.LowercaseLetter -> True + Data.Char.ModifierLetter -> True + Data.Char.OtherLetter -> True + Data.Char.TitlecaseLetter -> True + Data.Char.UppercaseLetter -> True + _ -> False + quoted :: Stream s m Char => ParsecT s u m Unit + quoted = + fromString <$> do + R.between (R.char '"') (R.char '"') $ + R.many1 $ + R.noneOf ";\n\"" + +-- * Read 'Amount' +amount :: Stream s m Char => ParsecT s u m Amount +amount = do + left_signing <- sign + left_unit <- + R.option Nothing $ do + u <- unit + s <- R.many $ R.space_horizontal + return $ Just $ (u, not $ null s) + (quantity_, style) <- do + signing <- sign + Quantity + { integral + , fractional + , fractioning + , grouping_integral + , grouping_fractional + } <- + R.choice_try + [ quantity '_' ',' '_' <* (R.notFollowedBy $ R.oneOf ",._") + , quantity '_' '.' '_' <* (R.notFollowedBy $ R.oneOf ",._") + , quantity ',' '.' '_' <* (R.notFollowedBy $ R.oneOf ",._") + , quantity '.' ',' '_' <* (R.notFollowedBy $ R.oneOf ",._") + ] "quantity" + let int = Data.List.concat integral + let frac_flat = Data.List.concat fractional + let frac = reverse $ Data.List.dropWhile (== '0') $ reverse $ frac_flat + let place = length frac + guard (place <= 255) + let mantissa = R.integer_of_digits 10 $ int ++ frac + return $ + ( Data.Decimal.Decimal + (fromIntegral place) + (signing mantissa) + , Style.nil + { Style.fractioning + , Style.grouping_integral + , Style.grouping_fractional + , Style.precision = fromIntegral $ length frac_flat + } + ) + (unit_, unit_side, unit_spaced) <- + case left_unit of + Just (u, s) -> + return (u, Just Style.Side_Left, Just s) + Nothing -> + R.option (Unit.nil, Nothing, Nothing) $ R.try $ do + s <- R.many $ R.space_horizontal + u <- unit + return $ (u, Just Style.Side_Right, Just $ not $ null s) + return $ + Amount.Amount + { Amount.quantity = left_signing $ quantity_ + , Amount.style = style + { Style.unit_side + , Style.unit_spaced + } + , Amount.unit = unit_ + } + +-- | Parse either '-' into 'negate', or '+' or '' into 'id'. +sign :: (Stream s m Char, Num i) => ParsecT s u m (i -> i) +sign = + (R.char '-' >> return negate) + <|> (R.char '+' >> return id) + <|> return id diff --git a/lib/Hcompta/Model/Amount/Unit.hs b/lib/Hcompta/Model/Amount/Unit.hs index a5ca65c..932f287 100644 --- a/lib/Hcompta/Model/Amount/Unit.hs +++ b/lib/Hcompta/Model/Amount/Unit.hs @@ -9,15 +9,10 @@ import qualified Data.Text as Text import Data.Text (Text) import Data.Typeable () -import qualified Hcompta.Model.Filter as Model.Filter - newtype Unit = Unit Text deriving (Data, Eq, IsString, Ord, Show, Typeable) -instance Model.Filter.Unit Unit where - unit_text = text - -- NOTE: maybe consider using text-show package text :: Unit -> Text text (Unit t) = t diff --git a/lib/Hcompta/Model/Date/Read.hs b/lib/Hcompta/Model/Date/Read.hs index 3cde424..8711d5f 100644 --- a/lib/Hcompta/Model/Date/Read.hs +++ b/lib/Hcompta/Model/Date/Read.hs @@ -1,10 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} - module Hcompta.Model.Date.Read where import Control.Applicative ((<$>)) diff --git a/lib/Hcompta/Model/Filter.hs b/lib/Hcompta/Model/Filter.hs index 48ecd58..a6400be 100644 --- a/lib/Hcompta/Model/Filter.hs +++ b/lib/Hcompta/Model/Filter.hs @@ -30,6 +30,8 @@ import qualified Data.List.NonEmpty as NonEmpty -- import Data.List.NonEmpty (NonEmpty(..)) import qualified Hcompta.Lib.Regex as Regex import Hcompta.Lib.Regex (Regex) +import qualified Hcompta.Model.Amount as Amount +import qualified Hcompta.Model.Amount.Unit as Amount.Unit import qualified Hcompta.Model.Date as Date import Hcompta.Model.Date (Date) import qualified Hcompta.Model.Account as Account @@ -44,6 +46,12 @@ import qualified Hcompta.Calc.Balance as Calc.Balance class Unit a where unit_text :: a -> Text +instance Unit Amount.Unit where + unit_text = Amount.Unit.text + +instance Unit Text where + unit_text = id + -- ** Class 'Amount' class @@ -52,16 +60,22 @@ class , Show (Amount_Unit a) , Unit (Amount_Unit a) ) - => Amount a where - type Amount_Quantity a + => Amount a where type Amount_Unit a + type Amount_Quantity a amount_unit :: a -> Amount_Unit a amount_quantity :: a -> Amount_Quantity a +instance Amount Amount.Amount where + type Amount_Unit Amount.Amount = Amount.Unit + type Amount_Quantity Amount.Amount = Amount.Quantity + amount_quantity = Amount.quantity + amount_unit = Amount.unit + instance (Amount a, Calc.Balance.Amount a) => Amount (Calc.Balance.Amount_Sum a) where + type Amount_Unit (Calc.Balance.Amount_Sum a) = Amount_Unit a type Amount_Quantity (Calc.Balance.Amount_Sum a) = Amount_Quantity a - type Amount_Unit (Calc.Balance.Amount_Sum a) = Amount_Unit a amount_quantity = amount_quantity . Calc.Balance.amount_sum_balance amount_unit = amount_unit . Calc.Balance.amount_sum_balance @@ -88,14 +102,18 @@ class Posting (Transaction_Posting t) class Amount (Balance_Amount b) => Balance b where type Balance_Amount b - balance_account :: b -> Account - balance_amount :: b -> Balance_Amount b + balance_account :: b -> Account + balance_amount :: b -> Balance_Amount b + balance_positive :: b -> Maybe (Balance_Amount b) + balance_negative :: b -> Maybe (Balance_Amount b) instance (Amount a, Calc.Balance.Amount a) => Balance (Account, Calc.Balance.Amount_Sum a) where type Balance_Amount (Account, Calc.Balance.Amount_Sum a) = a balance_account = fst - balance_amount = Calc.Balance.amount_sum_balance . snd + balance_amount = Calc.Balance.amount_sum_balance . snd + balance_positive = Calc.Balance.amount_sum_positive . snd + balance_negative = Calc.Balance.amount_sum_negative . snd -- * Class 'Test' @@ -391,8 +409,10 @@ instance Transaction t data Balance b => Test_Balance b - = Test_Balance_Account Test_Account - | Test_Balance_Amount (Test_Amount (Balance_Amount b)) + = Test_Balance_Account Test_Account + | Test_Balance_Amount (Test_Amount (Balance_Amount b)) + | Test_Balance_Positive (Test_Amount (Balance_Amount b)) + | Test_Balance_Negative (Test_Amount (Balance_Amount b)) deriving (Typeable) deriving instance Balance b => Eq (Test_Balance b) deriving instance Balance b => Show (Test_Balance b) @@ -403,3 +423,9 @@ instance Balance b test f $ balance_account b test (Test_Balance_Amount f) b = test f $ balance_amount b + test (Test_Balance_Positive f) b = + Data.Foldable.any (test f) $ + balance_positive b + test (Test_Balance_Negative f) b = + Data.Foldable.any (test f) $ + balance_negative b diff --git a/lib/Hcompta/Model/Filter/Read.hs b/lib/Hcompta/Model/Filter/Read.hs index 7c3d164..4d4906f 100644 --- a/lib/Hcompta/Model/Filter/Read.hs +++ b/lib/Hcompta/Model/Filter/Read.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} module Hcompta.Model.Filter.Read where import Prelude hiding (filter) @@ -14,7 +15,7 @@ import Data.Data import qualified Data.Foldable import Data.Functor.Identity (Identity) import Data.Maybe (catMaybes) -import qualified Data.Time.Clock as Time +import qualified Data.Time.Clock as Time import qualified Text.Parsec.Expr as R import qualified Text.Parsec as R hiding ( char @@ -38,11 +39,15 @@ import Data.Typeable () import qualified Hcompta.Lib.Regex as Regex -- import Hcompta.Lib.Regex (Regex) import qualified Hcompta.Model.Account as Account +import qualified Hcompta.Model.Amount as Amount +import Hcompta.Model.Amount (Amount) +import qualified Hcompta.Model.Amount.Read as Amount.Read +import qualified Hcompta.Model.Amount.Unit as Unit import qualified Hcompta.Model.Date as Date import Hcompta.Model.Date (Date) import qualified Hcompta.Model.Date.Read as Date.Read import qualified Hcompta.Model.Filter as Filter -import Hcompta.Model.Filter +import Hcompta.Model.Filter hiding (Amount) import qualified Hcompta.Lib.Parsec as R -- * Parsers' types @@ -233,6 +238,16 @@ bool = do ] >> return False ] +jump :: Stream s m Char + => [String] + -> ParsecT s u m b + -> a + -> ParsecT s u m a +jump prefixes next r = + R.choice_try + (map (\s -> R.string s >> return r) prefixes) + <* R.lookAhead (R.try next) + -- ** Read Account.'Account.Name' account_name :: Stream s m Char => ParsecT s u m Account.Name account_name = do @@ -291,6 +306,24 @@ test_account = do R.many1_separated (test_account_section make_test_text) $ R.char account_section_sep +-- ** Read 'Test_Amount' +test_amount + :: Stream s m Char + => ParsecT s u m (Test_Amount Amount) +test_amount = do + R.notFollowedBy $ R.space_horizontal + tst <- test_ord + amt <- Amount.Read.amount + return $ Test_Amount + (tst $ Amount.quantity amt) + (Test_Unit $ Test_Text_Exact $ Unit.text $ Amount.unit amt) + +test_amount_operator + :: Stream s m Char + => ParsecT s u m String +test_amount_operator = + test_ord_operator + -- ** Read 'Test_Date' test_date :: (Stream s (R.Error_State Error m) Char, Monad m) @@ -474,7 +507,8 @@ test_posting_terms = -- ** Read 'Test_Transaction' test_transaction - :: (Stream s (R.Error_State Error m) Char, Monad m, Filter.Transaction t) + :: (Stream s (R.Error_State Error m) Char, Monad m, Filter.Transaction t + , Posting_Amount (Transaction_Posting t) ~ Amount) => ParsecT s Context (R.Error_State Error m) (Test_Bool (Test_Transaction t)) test_transaction = Data.Foldable.foldr Filter.And Filter.Any <$> @@ -484,21 +518,22 @@ test_transaction = >> test_bool test_transaction_terms test_transaction_terms - :: (Stream s (R.Error_State Error m) Char, Filter.Transaction t, Monad m) + :: (Stream s (R.Error_State Error m) Char, Filter.Transaction t, Monad m + , Posting_Amount (Transaction_Posting t) ~ Amount) => [ParsecT s Context (R.Error_State Error m) (ParsecT s Context (R.Error_State Error m) (Test_Transaction t))] test_transaction_terms = - -- , jump [ "account","acct" ] comp_text test_account - -- , jump [ "amount", "amt" ] comp_num parseFilterAmount -- , jump [ "atag" ] comp_text parseFilterATag - -- , jump [ "balance", "bal" ] comp_num parseFilterBalance -- , jump [ "code" ] comp_text parseFilterCode [ jump [ "date" ] test_date_operator (Filter.Test_Transaction_Date <$> test_date) , jump [ "tag" ] test_tag_operator (Filter.Test_Transaction_Tag <$> test_tag) + , jump [ "amount" ] test_amount_operator + (( Filter.Test_Transaction_Posting + . Filter.Test_Posting_Amount + ) <$> test_amount) -- , jump [ "date2", "edate" ] (R.char '=') parseFilterDate2 - -- , jump [ "depth" ] comp_num parseFilterDepth -- , jump [ "description","descr","desc" ] comp_text parseFilterDesc -- , jump [ "real" ] (R.char '=') parseFilterReal -- , jump [ "status" ] (R.char '=') parseFilterStatus @@ -509,20 +544,10 @@ test_transaction_terms = . Filter.Test_Posting_Account <$> test_account ) ] - where - jump :: Stream s m Char - => [String] - -> ParsecT s u m b - -> a - -> ParsecT s u m a - jump prefixes next r = - R.choice_try - (map (\s -> R.string s >> return r) prefixes) - <* R.lookAhead (R.try next) -- ** Read 'Test_Balance' test_balance - :: (Stream s m Char, Filter.Balance t) + :: (Stream s m Char, Filter.Balance t, Balance_Amount t ~ Amount) => ParsecT s Context m (Test_Bool (Test_Balance t)) test_balance = Data.Foldable.foldr Filter.And Filter.Any <$> @@ -532,102 +557,19 @@ test_balance = >> test_bool test_balance_terms test_balance_terms - :: (Stream s m Char, Filter.Balance t) + :: (Stream s m Char, Filter.Balance t, Balance_Amount t ~ Amount) => [ParsecT s Context m (ParsecT s Context m (Test_Balance t))] test_balance_terms = - [ return + [ jump [ "amount" ] test_amount_operator + ( Filter.Test_Balance_Amount + <$> test_amount ) + , jump [ "debit" ] test_amount_operator + ( Filter.Test_Balance_Positive + <$> test_amount ) + , jump [ "credit" ] test_amount_operator + ( Filter.Test_Balance_Negative + <$> test_amount ) + , return ( Filter.Test_Balance_Account <$> test_account ) ] - -{- - -account :: Stream s m Char => ParsecT s Context m Filter -account = do - o <- R.optionMaybe comp_text - liftM (Filter.Account $ fromMaybe Comp_Text_Exact o) - (liftM (accountNameComponents) $ string (" \t"++"+-&")) - -parseFilterAmount :: Stream s m Char => ParsecT s Context m Filter -parseFilterAmount = do - Filter.Amount - <$> comp_num - <*> comp_num_abs - <*> amount - -parseFilterATag :: Stream s m Char => ParsecT s Context m Filter -parseFilterATag = do - c <- comp_text - liftM (uncurry (ATag c)) - parseTag - ---parseFilterCode :: Stream s m Char => ParsecT s Context m Filter ---parseFilterCode = do --- string "code=" --- liftM Code $ --- try (do { - -- choice - -- [ inparen - -- , R.many nonspace - -- ] - -- return $ strip $ reverse $ dropWhile (==',') $ reverse $ strip v - -- }) - -parseFilterBalance :: Stream s m Char => ParsecT s Context m Filter -parseFilterBalance = do - nc <- comp_num - absc <- comp_num_abs - a <- parseAmount Nothing - return $ Bal (nc, absc) a - -parseFilterDate :: Stream s m Char => ParsecT s Context m Filter -parseFilterDate = do - R.char '=' - ctx <- getState - liftM Date $ - periodexprdatespan (qCtxDay ctx) - -parseFilterDate2 :: Stream s m Char => ParsecT s Context m Filter -parseFilterDate2 = do - R.char '=' - ctx <- getState - liftM Date2 $ - periodexprdatespan (qCtxDay ctx) - -parseFilterDesc :: Stream s m Char => ParsecT s Context m Filter -parseFilterDesc = do - c <- comp_text - liftM (Desc c) - (string "") - -parseFilterDepth :: Stream s m Char => ParsecT s Context m Filter -parseFilterDepth = do - c <- comp_num - liftM (Depth c . fromIntegral) $ - parseDecimal - -parseFilterReal :: Stream s m Char => ParsecT s Context m Filter -parseFilterReal = do - R.char '=' - liftM Real bool - --- | Read the boolean value part of a "status:" query, allowing "*" as --- another way to spell True, similar to the journal file format. -parseFilterStatus :: Stream s m Char => ParsecT s Context m Filter -parseFilterStatus = do - R.char '=' - liftM Status $ - try (R.char '*' >> return True) <|> bool - ---parseFilterSym :: Stream s m Char => ParsecT s Context m Filter ---parseFilterSym = do --- string "cur=" --- liftM Sym --- commoditysymbol - -parseFilterTag :: Stream s m Char => ParsecT s Context m Filter -parseFilterTag = do - c <- comp_text - liftM (uncurry (Tag c)) - parseTag --} diff --git a/lib/hcompta-lib.cabal b/lib/hcompta-lib.cabal index aaabd53..4ec436c 100644 --- a/lib/hcompta-lib.cabal +++ b/lib/hcompta-lib.cabal @@ -74,6 +74,7 @@ Library Hcompta.Model.Amount Hcompta.Model.Amount.Quantity Hcompta.Model.Amount.Style + Hcompta.Model.Amount.Read Hcompta.Model.Amount.Unit Hcompta.Model.Date Hcompta.Model.Date.Read -- 2.47.2 From 2639d5da3d3296040e90e639d2fbf5add1b4a3bb Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Sat, 20 Jun 2015 20:29:51 +0200 Subject: [PATCH 11/16] Modif : aplatit Hcompta.{Format => } et Hcompta.{Calc => }. --- cli/Hcompta/CLI/Command/Balance.hs | 16 +- cli/Hcompta/CLI/Command/Print.hs | 4 +- cli/Hcompta/CLI/Format/Ledger.hs | 8 +- cli/Hcompta/CLI/Lang.hs | 8 +- lib/Hcompta/{Model => }/Account.hs | 4 +- lib/Hcompta/{Model => }/Amount.hs | 10 +- lib/Hcompta/{Model => }/Amount/Quantity.hs | 4 +- lib/Hcompta/{Model => }/Amount/Read.hs | 10 +- lib/Hcompta/{Model => }/Amount/Style.hs | 4 +- lib/Hcompta/{Model => }/Amount/Unit.hs | 2 +- lib/Hcompta/{Calc => }/Balance.hs | 112 +- lib/Hcompta/Calc.hs | 7 - lib/Hcompta/Calc/Print.hs | 1 - lib/Hcompta/Calc/Register.hs | 1 - lib/Hcompta/Calc/Stats.hs | 1 - lib/Hcompta/{Model => }/Date.hs | 2 +- lib/Hcompta/{Model => }/Date/Read.hs | 6 +- lib/Hcompta/{Calc => }/Diff.hs | 0 lib/Hcompta/{Model => }/Filter.hs | 42 +- lib/Hcompta/{Model => }/Filter/Read.hs | 22 +- lib/Hcompta/Format/Ledger.hs | 20 +- lib/Hcompta/Format/Ledger/Read.hs | 20 +- lib/Hcompta/Format/Ledger/Write.hs | 22 +- lib/Hcompta/Model.hs | 2 - lib/Hcompta/Model/Conversion.hs | 26 - lib/Hcompta/Model/Conversion/Historical.hs | 3 - lib/Hcompta/Util.hs | 1 - lib/Test/Main.hs | 3879 ++++++++++---------- lib/hcompta-lib.cabal | 28 +- 29 files changed, 2119 insertions(+), 2146 deletions(-) rename lib/Hcompta/{Model => }/Account.hs (95%) rename lib/Hcompta/{Model => }/Amount.hs (97%) rename lib/Hcompta/{Model => }/Amount/Quantity.hs (91%) rename lib/Hcompta/{Model => }/Amount/Read.hs (95%) rename lib/Hcompta/{Model => }/Amount/Style.hs (96%) rename lib/Hcompta/{Model => }/Amount/Unit.hs (93%) rename lib/Hcompta/{Calc => }/Balance.hs (92%) delete mode 100644 lib/Hcompta/Calc.hs delete mode 100644 lib/Hcompta/Calc/Print.hs delete mode 100644 lib/Hcompta/Calc/Register.hs delete mode 100644 lib/Hcompta/Calc/Stats.hs rename lib/Hcompta/{Model => }/Date.hs (98%) rename lib/Hcompta/{Model => }/Date/Read.hs (97%) rename lib/Hcompta/{Calc => }/Diff.hs (100%) rename lib/Hcompta/{Model => }/Filter.hs (91%) rename lib/Hcompta/{Model => }/Filter/Read.hs (96%) delete mode 100644 lib/Hcompta/Model.hs delete mode 100644 lib/Hcompta/Model/Conversion.hs delete mode 100644 lib/Hcompta/Model/Conversion/Historical.hs delete mode 100644 lib/Hcompta/Util.hs diff --git a/cli/Hcompta/CLI/Command/Balance.hs b/cli/Hcompta/CLI/Command/Balance.hs index efd49a5..5d1b2c4 100644 --- a/cli/Hcompta/CLI/Command/Balance.hs +++ b/cli/Hcompta/CLI/Command/Balance.hs @@ -26,7 +26,7 @@ import System.Exit (exitWith, ExitCode(..)) import qualified System.IO as IO -- import Text.Show.Pretty (ppShow) -import qualified Hcompta.Calc.Balance as Balance +import qualified Hcompta.Balance as Balance import qualified Hcompta.CLI.Args as Args import qualified Hcompta.CLI.Context as Context import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger @@ -41,13 +41,13 @@ import qualified Hcompta.Lib.TreeMap as Lib.TreeMap -- import qualified Hcompta.Lib.Foldable as Lib.Foldable import qualified Hcompta.Lib.Leijen as W import Hcompta.Lib.Leijen (toDoc, ToDoc(..)) --- import qualified Hcompta.Model.Account as Account -import Hcompta.Model.Account (Account) -import qualified Hcompta.Model.Amount as Amount -import Hcompta.Model.Amount (Amount) -import Hcompta.Model.Amount.Unit (Unit) -import qualified Hcompta.Model.Filter as Filter -import qualified Hcompta.Model.Filter.Read as Filter.Read +-- import qualified Hcompta.Account as Account +import Hcompta.Account (Account) +import qualified Hcompta.Amount as Amount +import Hcompta.Amount (Amount) +import Hcompta.Amount.Unit (Unit) +import qualified Hcompta.Filter as Filter +import qualified Hcompta.Filter.Read as Filter.Read data Ctx = Ctx diff --git a/cli/Hcompta/CLI/Command/Print.hs b/cli/Hcompta/CLI/Command/Print.hs index 0562c5c..7936119 100644 --- a/cli/Hcompta/CLI/Command/Print.hs +++ b/cli/Hcompta/CLI/Command/Print.hs @@ -28,8 +28,8 @@ import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal import qualified Hcompta.Format.Ledger.Read as Ledger.Read import qualified Hcompta.Format.Ledger.Write as Ledger.Write import qualified Hcompta.Lib.Leijen as W -import qualified Hcompta.Model.Filter as Filter -import qualified Hcompta.Model.Filter.Read as Filter.Read +import qualified Hcompta.Filter as Filter +import qualified Hcompta.Filter.Read as Filter.Read data Ctx = Ctx diff --git a/cli/Hcompta/CLI/Format/Ledger.hs b/cli/Hcompta/CLI/Format/Ledger.hs index da5dd4c..9819025 100644 --- a/cli/Hcompta/CLI/Format/Ledger.hs +++ b/cli/Hcompta/CLI/Format/Ledger.hs @@ -15,14 +15,14 @@ import System.IO.Error (isDoesNotExistError) import qualified Hcompta.Lib.Leijen as W import Hcompta.Lib.Leijen (ToDoc(..)) -import qualified Hcompta.Calc.Balance as Calc.Balance +import qualified Hcompta.Balance as Balance import qualified Hcompta.CLI.Context as Context import qualified Hcompta.CLI.Lang as Lang import Hcompta.CLI.Lang (Lang) import qualified Hcompta.CLI.Write as Write import qualified Hcompta.Format.Ledger.Read as Ledger.Read import qualified Hcompta.Format.Ledger.Write as Ledger.Write -import qualified Hcompta.Model.Amount as Amount +import qualified Hcompta.Amount as Amount -- | Return 'FilePath's containing 'Hcompta.Format.Ledger.Journal's: -- @@ -69,8 +69,8 @@ instance ToDoc Lang Ledger.Read.Error where W.vsep $ [ toDoc lang msg , W.vsep $ Data.List.map - (\Calc.Balance.Unit_Sum{Calc.Balance.unit_sum_amount} -> - let amt = Calc.Balance.amount_sum_balance unit_sum_amount in + (\Balance.Unit_Sum{Balance.unit_sum_amount} -> + let amt = Balance.amount_sum_balance unit_sum_amount in toDoc lang $ Lang.Message_unit_sums_up_to_the_non_null_amount (Amount.unit amt) amt diff --git a/cli/Hcompta/CLI/Lang.hs b/cli/Hcompta/CLI/Lang.hs index 69e64c3..fb13dc1 100644 --- a/cli/Hcompta/CLI/Lang.hs +++ b/cli/Hcompta/CLI/Lang.hs @@ -18,10 +18,10 @@ import qualified Text.Parsec as Parsec import qualified Text.Parsec.Error as Parsec.Error import qualified Hcompta.Format.Ledger.Write as Ledger.Write -import Hcompta.Model.Amount.Unit (Unit) -import Hcompta.Model.Amount (Amount) -import qualified Hcompta.Model.Date.Read as Date.Read -import qualified Hcompta.Model.Filter.Read as Filter.Read +import Hcompta.Amount.Unit (Unit) +import Hcompta.Amount (Amount) +import qualified Hcompta.Date.Read as Date.Read +import qualified Hcompta.Filter.Read as Filter.Read import qualified Hcompta.Lib.Leijen as W import Hcompta.Lib.Leijen (ToDoc(..), (<>)) import qualified Hcompta.Lib.Parsec as Lib.Parsec diff --git a/lib/Hcompta/Model/Account.hs b/lib/Hcompta/Account.hs similarity index 95% rename from lib/Hcompta/Model/Account.hs rename to lib/Hcompta/Account.hs index 48bbbff..7d79867 100644 --- a/lib/Hcompta/Model/Account.hs +++ b/lib/Hcompta/Account.hs @@ -1,5 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} -module Hcompta.Model.Account where +module Hcompta.Account where import Data.Data (Data) import qualified Data.List @@ -11,7 +11,7 @@ import Data.Typeable (Typeable) -- import Text.Parsec (Stream, ParsecT, (<|>), ()) import Data.Text (Text) --- import qualified Hcompta.Model.Account.Path as Path +-- import qualified Hcompta.Account.Path as Path import Hcompta.Lib.Regex (Regex) import qualified Hcompta.Lib.TreeMap as Lib.TreeMap diff --git a/lib/Hcompta/Model/Amount.hs b/lib/Hcompta/Amount.hs similarity index 97% rename from lib/Hcompta/Model/Amount.hs rename to lib/Hcompta/Amount.hs index 1d70e69..529fe1c 100644 --- a/lib/Hcompta/Model/Amount.hs +++ b/lib/Hcompta/Amount.hs @@ -4,7 +4,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module Hcompta.Model.Amount where +module Hcompta.Amount where import Data.Data import qualified Data.List @@ -12,10 +12,10 @@ import qualified Data.Map.Strict as Data.Map import qualified Data.Foldable import Data.Typeable () -import qualified Hcompta.Calc.Balance as Balance -import qualified Hcompta.Model.Amount.Quantity as Quantity -import qualified Hcompta.Model.Amount.Style as Style -import qualified Hcompta.Model.Amount.Unit as Unit +import qualified Hcompta.Balance as Balance +import qualified Hcompta.Amount.Quantity as Quantity +import qualified Hcompta.Amount.Style as Style +import qualified Hcompta.Amount.Unit as Unit -- * Type synonyms to submodules diff --git a/lib/Hcompta/Model/Amount/Quantity.hs b/lib/Hcompta/Amount/Quantity.hs similarity index 91% rename from lib/Hcompta/Model/Amount/Quantity.hs rename to lib/Hcompta/Amount/Quantity.hs index f7b9132..f6ce5b5 100644 --- a/lib/Hcompta/Model/Amount/Quantity.hs +++ b/lib/Hcompta/Amount/Quantity.hs @@ -4,7 +4,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module Hcompta.Model.Amount.Quantity where +module Hcompta.Amount.Quantity where import Data.Data #ifdef DOUBLE @@ -49,6 +49,6 @@ round = Data.Decimal.roundTo is_zero = (== 0) . decimalMantissa --is_zero decimal_places quantity = -- (== 0) $ decimalMantissa $ --- Hcompta.Model.Amount.Quantity.round decimal_places quantity +-- Hcompta.Amount.Quantity.round decimal_places quantity #endif diff --git a/lib/Hcompta/Model/Amount/Read.hs b/lib/Hcompta/Amount/Read.hs similarity index 95% rename from lib/Hcompta/Model/Amount/Read.hs rename to lib/Hcompta/Amount/Read.hs index 9fb4be8..e0f9c1f 100644 --- a/lib/Hcompta/Model/Amount/Read.hs +++ b/lib/Hcompta/Amount/Read.hs @@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} -module Hcompta.Model.Amount.Read where +module Hcompta.Amount.Read where import Control.Monad (guard) import Control.Applicative ((<$>), (<|>), (<*)) @@ -17,10 +17,10 @@ import qualified Text.Parsec as R hiding ) import Text.Parsec (Stream, ParsecT, ()) -import qualified Hcompta.Model.Amount as Amount -import Hcompta.Model.Amount (Amount, Unit) -import qualified Hcompta.Model.Amount.Style as Style -import qualified Hcompta.Model.Amount.Unit as Unit +import qualified Hcompta.Amount as Amount +import Hcompta.Amount (Amount, Unit) +import qualified Hcompta.Amount.Style as Style +import qualified Hcompta.Amount.Unit as Unit import qualified Hcompta.Lib.Parsec as R -- * Read 'Quantity' diff --git a/lib/Hcompta/Model/Amount/Style.hs b/lib/Hcompta/Amount/Style.hs similarity index 96% rename from lib/Hcompta/Model/Amount/Style.hs rename to lib/Hcompta/Amount/Style.hs index 52e5998..9762a4d 100644 --- a/lib/Hcompta/Model/Amount/Style.hs +++ b/lib/Hcompta/Amount/Style.hs @@ -1,11 +1,11 @@ {-# LANGUAGE DeriveDataTypeable #-} -module Hcompta.Model.Amount.Style where +module Hcompta.Amount.Style where import Data.Data import Data.Word (Word8) import Data.Typeable () --- * The 'Style' type +-- * Type 'Style' data Style = Style diff --git a/lib/Hcompta/Model/Amount/Unit.hs b/lib/Hcompta/Amount/Unit.hs similarity index 93% rename from lib/Hcompta/Model/Amount/Unit.hs rename to lib/Hcompta/Amount/Unit.hs index 932f287..a182257 100644 --- a/lib/Hcompta/Model/Amount/Unit.hs +++ b/lib/Hcompta/Amount/Unit.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} -module Hcompta.Model.Amount.Unit where +module Hcompta.Amount.Unit where import Data.Data import Data.String (IsString) diff --git a/lib/Hcompta/Calc/Balance.hs b/lib/Hcompta/Balance.hs similarity index 92% rename from lib/Hcompta/Calc/Balance.hs rename to lib/Hcompta/Balance.hs index 5499e58..732b5cd 100644 --- a/lib/Hcompta/Calc/Balance.hs +++ b/lib/Hcompta/Balance.hs @@ -5,7 +5,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} -- FIXME: to be removed when dropping GHC-7.6 support -module Hcompta.Calc.Balance where +module Hcompta.Balance where import Control.Exception (assert) import Data.Data @@ -19,8 +19,8 @@ import Data.Typeable () import qualified Hcompta.Lib.Foldable as Lib.Foldable import qualified Hcompta.Lib.TreeMap as Lib.TreeMap import Hcompta.Lib.TreeMap (TreeMap) -import qualified Hcompta.Model.Account as Account -import Hcompta.Model.Account (Account) +import qualified Hcompta.Account as Account +import Hcompta.Account (Account) -- * Requirements' interface @@ -119,6 +119,41 @@ nil = , balance_by_unit = Data.Map.empty } +-- | Return the given 'Balance' +-- updated by the given 'Posting'. +balance :: + ( Posting posting + , balance ~ Balance (Posting_Amount posting) ) + => posting -> balance -> balance +balance post bal = + bal + { balance_by_account = by_account post (balance_by_account bal) + , balance_by_unit = by_unit post (balance_by_unit bal) + } + +-- | Return the given 'Balance' +-- updated by the given 'Posting's. +postings :: + ( Posting posting + , balance ~ Balance (Posting_Amount posting) + , Foldable foldable ) + => foldable posting -> balance -> balance +postings = flip (Data.Foldable.foldr balance) + +-- | Return the first given 'Balance' +-- updated by the second given 'Balance'. +union :: Amount amount + => Balance amount -> Balance amount -> Balance amount +union b0 b1 = + b0 + { balance_by_account = union_by_account + (balance_by_account b0) + (balance_by_account b1) + , balance_by_unit = union_by_unit + (balance_by_unit b0) + (balance_by_unit b1) + } + -- | Return the given 'Balance_by_Account' -- updated by the given 'Posting'. by_account :: @@ -176,52 +211,33 @@ by_unit_of_by_account :: by_unit_of_by_account = flip $ Lib.TreeMap.foldr_with_Path $ curry by_unit --- | Return the given 'Balance' --- updated by the given 'Posting'. -balance :: - ( Posting posting - , balance ~ Balance (Posting_Amount posting) ) - => posting -> balance -> balance -balance post bal = - bal - { balance_by_account = by_account post (balance_by_account bal) - , balance_by_unit = by_unit post (balance_by_unit bal) - } - --- | Return the given 'Balance' --- updated by the given 'Posting's. -postings :: - ( Posting posting - , balance ~ Balance (Posting_Amount posting) - , Foldable foldable ) - => foldable posting -> balance -> balance -postings = flip (Data.Foldable.foldr balance) +-- | Return the first given 'Balance_by_Account' +-- updated by the second given 'Balance_by_Account'. +union_by_account :: (Amount amount, unit ~ Amount_Unit amount) + => Balance_by_Account amount unit + -> Balance_by_Account amount unit + -> Balance_by_Account amount unit +union_by_account = + Lib.TreeMap.union + (Data.Map.unionWith (flip amount_add)) --- | Return the first given 'Balance' --- updated by the second given 'Balance'. -union :: Amount amount - => Balance amount -> Balance amount -> Balance amount -union b0 b1 = - b0 - { balance_by_account = - Lib.TreeMap.union - (Data.Map.unionWith (flip amount_add)) - (balance_by_account b0) - (balance_by_account b1) - , balance_by_unit = - Data.Map.unionWith - (\new old -> Unit_Sum - { unit_sum_amount = amount_add - (unit_sum_amount old) - (unit_sum_amount new) - , unit_sum_accounts = Data.Map.unionWith - (const::()->()->()) - (unit_sum_accounts old) - (unit_sum_accounts new) - }) - (balance_by_unit b0) - (balance_by_unit b1) - } +-- | Return the first given 'Balance_by_Unit' +-- updated by the second given 'Balance_by_Unit'. +union_by_unit :: (Amount amount, unit ~ Amount_Unit amount) + => Balance_by_Unit amount unit + -> Balance_by_Unit amount unit + -> Balance_by_Unit amount unit +union_by_unit = + Data.Map.unionWith + (\new old -> Unit_Sum + { unit_sum_amount = amount_add + (unit_sum_amount old) + (unit_sum_amount new) + , unit_sum_accounts = Data.Map.unionWith + (const::()->()->()) + (unit_sum_accounts old) + (unit_sum_accounts new) + }) -- * Type 'Deviation' diff --git a/lib/Hcompta/Calc.hs b/lib/Hcompta/Calc.hs deleted file mode 100644 index 47fd258..0000000 --- a/lib/Hcompta/Calc.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Hcompta.Calc - ( module Hcompta.Calc - ) where - -import qualified Hcompta.Calc.Balance as Balance - -type Balance = Balance.Balance diff --git a/lib/Hcompta/Calc/Print.hs b/lib/Hcompta/Calc/Print.hs deleted file mode 100644 index 10bb034..0000000 --- a/lib/Hcompta/Calc/Print.hs +++ /dev/null @@ -1 +0,0 @@ -module Hcompta.Calc.Print where diff --git a/lib/Hcompta/Calc/Register.hs b/lib/Hcompta/Calc/Register.hs deleted file mode 100644 index b9b2440..0000000 --- a/lib/Hcompta/Calc/Register.hs +++ /dev/null @@ -1 +0,0 @@ -module Hcompta.Calc.Register where diff --git a/lib/Hcompta/Calc/Stats.hs b/lib/Hcompta/Calc/Stats.hs deleted file mode 100644 index 8eb5920..0000000 --- a/lib/Hcompta/Calc/Stats.hs +++ /dev/null @@ -1 +0,0 @@ -module Hcompta.Calc.Stats where diff --git a/lib/Hcompta/Model/Date.hs b/lib/Hcompta/Date.hs similarity index 98% rename from lib/Hcompta/Model/Date.hs rename to lib/Hcompta/Date.hs index d1faec5..f8419b5 100644 --- a/lib/Hcompta/Model/Date.hs +++ b/lib/Hcompta/Date.hs @@ -2,7 +2,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module Hcompta.Model.Date where +module Hcompta.Date where import Data.Data import qualified Data.Fixed diff --git a/lib/Hcompta/Model/Date/Read.hs b/lib/Hcompta/Date/Read.hs similarity index 97% rename from lib/Hcompta/Model/Date/Read.hs rename to lib/Hcompta/Date/Read.hs index 8711d5f..07c8694 100644 --- a/lib/Hcompta/Model/Date/Read.hs +++ b/lib/Hcompta/Date/Read.hs @@ -1,5 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} -module Hcompta.Model.Date.Read where +module Hcompta.Date.Read where import Control.Applicative ((<$>)) import qualified Data.Time.Calendar as Time @@ -20,7 +20,7 @@ import qualified Text.Parsec as R hiding ) import Text.Parsec (Stream, ParsecT, (<|>), ()) -import Hcompta.Model.Date (Date) +import Hcompta.Date (Date) import qualified Hcompta.Lib.Parsec as R data Error @@ -29,7 +29,7 @@ data Error | Error_invalid_time_of_day (Int, Int, Integer) deriving (Eq, Show) --- | Read a 'Date' in [YYYY/]MM/DD [HH:MM[:SS][TZ]] format. +-- | Read a 'Date' in @[YYYY/]MM/DD [HH:MM[:SS][TZ]]@ format. date :: (Stream s (R.Error_State e m) Char, Monad m) => (Error -> e) -> Maybe Integer -> ParsecT s u (R.Error_State e m) Date diff --git a/lib/Hcompta/Calc/Diff.hs b/lib/Hcompta/Diff.hs similarity index 100% rename from lib/Hcompta/Calc/Diff.hs rename to lib/Hcompta/Diff.hs diff --git a/lib/Hcompta/Model/Filter.hs b/lib/Hcompta/Filter.hs similarity index 91% rename from lib/Hcompta/Model/Filter.hs rename to lib/Hcompta/Filter.hs index a6400be..fc85c20 100644 --- a/lib/Hcompta/Model/Filter.hs +++ b/lib/Hcompta/Filter.hs @@ -5,7 +5,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} -module Hcompta.Model.Filter where +module Hcompta.Filter where import Prelude hiding (filter) import Control.Applicative (pure, (<$>), (<*>)) @@ -30,14 +30,14 @@ import qualified Data.List.NonEmpty as NonEmpty -- import Data.List.NonEmpty (NonEmpty(..)) import qualified Hcompta.Lib.Regex as Regex import Hcompta.Lib.Regex (Regex) -import qualified Hcompta.Model.Amount as Amount -import qualified Hcompta.Model.Amount.Unit as Amount.Unit -import qualified Hcompta.Model.Date as Date -import Hcompta.Model.Date (Date) -import qualified Hcompta.Model.Account as Account -import Hcompta.Model.Account (Account) --- import qualified Hcompta.Model.Date as Date -import qualified Hcompta.Calc.Balance as Calc.Balance +import qualified Hcompta.Amount as Amount +import qualified Hcompta.Amount.Unit as Amount.Unit +import qualified Hcompta.Date as Date +import Hcompta.Date (Date) +import qualified Hcompta.Account as Account +import Hcompta.Account (Account) +-- import qualified Hcompta.Date as Date +import qualified Hcompta.Balance as Balance -- * Requirements' interface @@ -72,12 +72,12 @@ instance Amount Amount.Amount where amount_quantity = Amount.quantity amount_unit = Amount.unit -instance (Amount a, Calc.Balance.Amount a) - => Amount (Calc.Balance.Amount_Sum a) where - type Amount_Unit (Calc.Balance.Amount_Sum a) = Amount_Unit a - type Amount_Quantity (Calc.Balance.Amount_Sum a) = Amount_Quantity a - amount_quantity = amount_quantity . Calc.Balance.amount_sum_balance - amount_unit = amount_unit . Calc.Balance.amount_sum_balance +instance (Amount a, Balance.Amount a) + => Amount (Balance.Amount_Sum a) where + type Amount_Unit (Balance.Amount_Sum a) = Amount_Unit a + type Amount_Quantity (Balance.Amount_Sum a) = Amount_Quantity a + amount_quantity = amount_quantity . Balance.amount_sum_balance + amount_unit = amount_unit . Balance.amount_sum_balance -- ** Class 'Posting' @@ -107,13 +107,13 @@ class Amount (Balance_Amount b) balance_positive :: b -> Maybe (Balance_Amount b) balance_negative :: b -> Maybe (Balance_Amount b) -instance (Amount a, Calc.Balance.Amount a) - => Balance (Account, Calc.Balance.Amount_Sum a) where - type Balance_Amount (Account, Calc.Balance.Amount_Sum a) = a +instance (Amount a, Balance.Amount a) + => Balance (Account, Balance.Amount_Sum a) where + type Balance_Amount (Account, Balance.Amount_Sum a) = a balance_account = fst - balance_amount = Calc.Balance.amount_sum_balance . snd - balance_positive = Calc.Balance.amount_sum_positive . snd - balance_negative = Calc.Balance.amount_sum_negative . snd + balance_amount = Balance.amount_sum_balance . snd + balance_positive = Balance.amount_sum_positive . snd + balance_negative = Balance.amount_sum_negative . snd -- * Class 'Test' diff --git a/lib/Hcompta/Model/Filter/Read.hs b/lib/Hcompta/Filter/Read.hs similarity index 96% rename from lib/Hcompta/Model/Filter/Read.hs rename to lib/Hcompta/Filter/Read.hs index 4d4906f..ad2738d 100644 --- a/lib/Hcompta/Model/Filter/Read.hs +++ b/lib/Hcompta/Filter/Read.hs @@ -3,7 +3,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -module Hcompta.Model.Filter.Read where +module Hcompta.Filter.Read where import Prelude hiding (filter) import Control.Applicative ((<$>), (<*)) @@ -38,16 +38,16 @@ import Data.Typeable () import qualified Hcompta.Lib.Regex as Regex -- import Hcompta.Lib.Regex (Regex) -import qualified Hcompta.Model.Account as Account -import qualified Hcompta.Model.Amount as Amount -import Hcompta.Model.Amount (Amount) -import qualified Hcompta.Model.Amount.Read as Amount.Read -import qualified Hcompta.Model.Amount.Unit as Unit -import qualified Hcompta.Model.Date as Date -import Hcompta.Model.Date (Date) -import qualified Hcompta.Model.Date.Read as Date.Read -import qualified Hcompta.Model.Filter as Filter -import Hcompta.Model.Filter hiding (Amount) +import qualified Hcompta.Account as Account +import qualified Hcompta.Amount as Amount +import Hcompta.Amount (Amount) +import qualified Hcompta.Amount.Read as Amount.Read +import qualified Hcompta.Amount.Unit as Unit +import qualified Hcompta.Date as Date +import Hcompta.Date (Date) +import qualified Hcompta.Date.Read as Date.Read +import qualified Hcompta.Filter as Filter +import Hcompta.Filter hiding (Amount) import qualified Hcompta.Lib.Parsec as R -- * Parsers' types diff --git a/lib/Hcompta/Format/Ledger.hs b/lib/Hcompta/Format/Ledger.hs index 7e235ea..81b0e3e 100644 --- a/lib/Hcompta/Format/Ledger.hs +++ b/lib/Hcompta/Format/Ledger.hs @@ -14,14 +14,14 @@ import qualified Data.Time.Clock as Time import qualified Data.Time.Clock.POSIX as Time import Hcompta.Lib.Parsec () -import qualified Hcompta.Calc.Balance as Balance -import Hcompta.Model.Date (Date) -import qualified Hcompta.Model.Date as Date -import Hcompta.Model.Account (Account) --- import qualified Hcompta.Model.Account as Account -import Hcompta.Model.Amount (Amount) -import qualified Hcompta.Model.Amount as Amount -import qualified Hcompta.Model.Filter as Model.Filter +import qualified Hcompta.Balance as Balance +import Hcompta.Date (Date) +import qualified Hcompta.Date as Date +import Hcompta.Account (Account) +-- import qualified Hcompta.Account as Account +import Hcompta.Amount (Amount) +import qualified Hcompta.Amount as Amount +import qualified Hcompta.Filter as Filter import Data.Text (Text) type Code = Text @@ -83,7 +83,7 @@ transaction = , transaction_tags = Data.Map.empty } -instance Model.Filter.Transaction Transaction where +instance Filter.Transaction Transaction where type Transaction_Posting Transaction = Posting transaction_date = fst . transaction_dates transaction_description = transaction_description @@ -139,7 +139,7 @@ instance posting_set_amounts amounts p = p { posting_amounts=Data.Map.map Balance.amount_sum_balance amounts } -instance Model.Filter.Posting Posting where +instance Filter.Posting Posting where type Posting_Amount Posting = Amount posting_account = posting_account posting_amounts = posting_amounts diff --git a/lib/Hcompta/Format/Ledger/Read.hs b/lib/Hcompta/Format/Ledger/Read.hs index 00e9eb1..dcb9e09 100644 --- a/lib/Hcompta/Format/Ledger/Read.hs +++ b/lib/Hcompta/Format/Ledger/Read.hs @@ -42,16 +42,16 @@ import qualified Data.Text.IO as Text.IO (readFile) import qualified Data.Text as Text import qualified System.FilePath.Posix as Path -import qualified Hcompta.Calc.Balance as Balance -import qualified Hcompta.Model.Account as Account -import Hcompta.Model.Account (Account) -import qualified Hcompta.Model.Amount as Amount -import qualified Hcompta.Model.Amount.Style as Style -import qualified Hcompta.Model.Amount.Read as Amount.Read -import qualified Hcompta.Model.Amount.Unit as Unit -import qualified Hcompta.Model.Date as Date -import Hcompta.Model.Date (Date) -import qualified Hcompta.Model.Date.Read as Date.Read +import qualified Hcompta.Balance as Balance +import qualified Hcompta.Account as Account +import Hcompta.Account (Account) +import qualified Hcompta.Amount as Amount +import qualified Hcompta.Amount.Style as Style +import qualified Hcompta.Amount.Read as Amount.Read +import qualified Hcompta.Amount.Unit as Unit +import qualified Hcompta.Date as Date +import Hcompta.Date (Date) +import qualified Hcompta.Date.Read as Date.Read import qualified Hcompta.Format.Ledger as Ledger import Hcompta.Format.Ledger ( Comment diff --git a/lib/Hcompta/Format/Ledger/Write.hs b/lib/Hcompta/Format/Ledger/Write.hs index ef74bd3..2f203b5 100644 --- a/lib/Hcompta/Format/Ledger/Write.hs +++ b/lib/Hcompta/Format/Ledger/Write.hs @@ -30,15 +30,15 @@ import Text.Parsec (Stream, ParsecT) import GHC.Exts (Int(..)) import GHC.Integer.Logarithms (integerLogBase#) -import qualified Hcompta.Model.Account as Account -import Hcompta.Model.Account (Account) -import qualified Hcompta.Model.Amount as Amount -import Hcompta.Model.Amount (Amount) -import qualified Hcompta.Model.Amount.Quantity as Quantity -import Hcompta.Model.Amount.Quantity (Quantity) -import qualified Hcompta.Model.Amount.Style as Amount.Style -import qualified Hcompta.Model.Amount.Unit as Unit -import Hcompta.Model.Amount.Unit (Unit) +import qualified Hcompta.Account as Account +import Hcompta.Account (Account) +import qualified Hcompta.Amount as Amount +import Hcompta.Amount (Amount) +import qualified Hcompta.Amount.Quantity as Quantity +import Hcompta.Amount.Quantity (Quantity) +import qualified Hcompta.Amount.Style as Amount.Style +import qualified Hcompta.Amount.Unit as Unit +import Hcompta.Amount.Unit (Unit) import qualified Hcompta.Format.Ledger as Ledger import Hcompta.Format.Ledger ( Comment @@ -47,8 +47,8 @@ import Hcompta.Format.Ledger , Tag , Transaction(..) ) --- import qualified Hcompta.Model.Date as Date -import Hcompta.Model.Date (Date) +-- import qualified Hcompta.Date as Date +import Hcompta.Date (Date) -- import Hcompta.Format.Ledger.Journal as Journal import qualified Hcompta.Format.Ledger.Read as Read import qualified Hcompta.Lib.Parsec as R diff --git a/lib/Hcompta/Model.hs b/lib/Hcompta/Model.hs deleted file mode 100644 index 60eda56..0000000 --- a/lib/Hcompta/Model.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Hcompta.Model where - diff --git a/lib/Hcompta/Model/Conversion.hs b/lib/Hcompta/Model/Conversion.hs deleted file mode 100644 index 655abbb..0000000 --- a/lib/Hcompta/Model/Conversion.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -module Hcompta.Model.Conversion where -{- -import Data.Data -import Data.Typeable () - -import qualified Hcompta.Model.Amount as Amount () -import Hcompta.Model.Amount (Amount, Quantity, Style, Unit) -import qualified Hcompta.Model.Date as Date () -import Hcompta.Model.Date (Date) - -data Conversion - = Unit Quantity Unit Style - | Total Quantity Unit Style - deriving (Data, Eq, Ord, Read, Show, Typeable) - -data Historical - = Historical - { amount :: Amount - , commodity :: Unit - , date :: Date - } deriving (Data, Read, Show, Typeable) - -nil :: Maybe Conversion -nil = Nothing --} diff --git a/lib/Hcompta/Model/Conversion/Historical.hs b/lib/Hcompta/Model/Conversion/Historical.hs deleted file mode 100644 index 4481fe8..0000000 --- a/lib/Hcompta/Model/Conversion/Historical.hs +++ /dev/null @@ -1,3 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -module Hcompta.Model.Conversion.Historical where - diff --git a/lib/Hcompta/Util.hs b/lib/Hcompta/Util.hs deleted file mode 100644 index 7b15375..0000000 --- a/lib/Hcompta/Util.hs +++ /dev/null @@ -1 +0,0 @@ -module Hcompta.Util where diff --git a/lib/Test/Main.hs b/lib/Test/Main.hs index 64af369..551ae92 100644 --- a/lib/Test/Main.hs +++ b/lib/Test/Main.hs @@ -21,16 +21,17 @@ import qualified Text.Parsec as P hiding (char, space, spaces, string) import qualified Text.Parsec.Pos as P -- import qualified Text.PrettyPrint.Leijen.Text as PP -import qualified Hcompta.Model.Account as Account -import Hcompta.Model.Account (Account) -import qualified Hcompta.Model.Amount as Amount -import Hcompta.Model.Amount (Amount) -import qualified Hcompta.Model.Amount.Style as Amount.Style -import qualified Hcompta.Model.Date as Date -import qualified Hcompta.Model.Date.Read as Date.Read -import qualified Hcompta.Model.Filter as Filter -import qualified Hcompta.Model.Filter.Read as Filter.Read -import qualified Hcompta.Calc.Balance as Calc.Balance +import qualified Hcompta.Account as Account +import Hcompta.Account (Account) +import qualified Hcompta.Amount as Amount +import Hcompta.Amount (Amount) +import qualified Hcompta.Amount.Read as Amount.Read +import qualified Hcompta.Amount.Style as Amount.Style +import qualified Hcompta.Date as Date +import qualified Hcompta.Date.Read as Date.Read +import qualified Hcompta.Filter as Filter +import qualified Hcompta.Filter.Read as Filter.Read +import qualified Hcompta.Balance as Balance import qualified Hcompta.Format.Ledger as Format.Ledger import qualified Hcompta.Format.Ledger.Read as Format.Ledger.Read import qualified Hcompta.Format.Ledger.Write as Format.Ledger.Write @@ -146,1354 +147,2033 @@ test_Hcompta = ] ] ] - , "Model" ~: TestList - [ "Account" ~: TestList - [ "foldr" ~: TestList - [ "[A]" ~: - (reverse $ Account.foldr ("A":|[]) (:) []) ~?= ["A":|[]] - , "[A, B]" ~: - (reverse $ Account.foldr ("A":|["B"]) (:) []) ~?= ["A":|[], "A":|["B"]] - , "[A, B, C]" ~: - (reverse $ Account.foldr ("A":|["B", "C"]) (:) []) ~?= ["A":|[], "A":|["B"], "A":|["B", "C"]] + , "Account" ~: TestList + [ "foldr" ~: TestList + [ "[A]" ~: + (reverse $ Account.foldr ("A":|[]) (:) []) ~?= ["A":|[]] + , "[A, B]" ~: + (reverse $ Account.foldr ("A":|["B"]) (:) []) ~?= ["A":|[], "A":|["B"]] + , "[A, B, C]" ~: + (reverse $ Account.foldr ("A":|["B", "C"]) (:) []) ~?= ["A":|[], "A":|["B"], "A":|["B", "C"]] + ] + , "ascending" ~: TestList + [ "[A]" ~: + Account.ascending ("A":|[]) ~?= Nothing + , "[A, B]" ~: + Account.ascending ("A":|["B"]) ~?= Just ("A":|[]) + , "[A, B, C]" ~: + Account.ascending ("A":|["B", "C"]) ~?= Just ("A":|["B"]) + ] + ] + , "Amount" ~: TestList + [ "+" ~: TestList + [ "$1 + 1$ = $2" ~: + (+) + (Amount.nil + { Amount.quantity = Decimal 0 1 + , Amount.style = Amount.Style.nil + { Amount.Style.unit_side = Just $ Amount.Style.Side_Left + } + , Amount.unit = "$" + }) + (Amount.nil + { Amount.quantity = Decimal 0 1 + , Amount.style = Amount.Style.nil + { Amount.Style.unit_side = Just $ Amount.Style.Side_Right + } + , Amount.unit = "$" + }) + ~?= + (Amount.nil + { Amount.quantity = Decimal 0 2 + , Amount.style = Amount.Style.nil + { Amount.Style.unit_side = Just $ Amount.Style.Side_Left + } + , Amount.unit = "$" + }) + ] + , "from_List" ~: TestList + [ "from_List [$1, 1$] = $2" ~: + Amount.from_List + [ Amount.nil + { Amount.quantity = Decimal 0 1 + , Amount.style = Amount.Style.nil + { Amount.Style.unit_side = Just $ Amount.Style.Side_Left + } + , Amount.unit = "$" + } + , Amount.nil + { Amount.quantity = Decimal 0 1 + , Amount.style = Amount.Style.nil + { Amount.Style.unit_side = Just $ Amount.Style.Side_Right + } + , Amount.unit = "$" + } ] - , "ascending" ~: TestList - [ "[A]" ~: - Account.ascending ("A":|[]) ~?= Nothing - , "[A, B]" ~: - Account.ascending ("A":|["B"]) ~?= Just ("A":|[]) - , "[A, B, C]" ~: - Account.ascending ("A":|["B", "C"]) ~?= Just ("A":|["B"]) + ~?= + Data.Map.fromList + [ ("$", Amount.nil + { Amount.quantity = Decimal 0 2 + , Amount.style = Amount.Style.nil + { Amount.Style.unit_side = Just $ Amount.Style.Side_Left + } + , Amount.unit = "$" + }) ] ] - , "Amount" ~: TestList - [ "+" ~: TestList - [ "$1 + 1$ = $2" ~: - (+) - (Amount.nil + , "Read" ~: TestList + [ "amount" ~: TestList + [ "\"\" = Left" ~: + (Data.Either.rights $ + [P.runParser + (Amount.Read.amount <* P.eof) + () "" (""::Text)]) + ~?= + [] + , "\"0\" = Right 0" ~: + (Data.Either.rights $ + [P.runParser + (Amount.Read.amount <* P.eof) + () "" ("0"::Text)]) + ~?= + [Amount.nil + { Amount.quantity = Decimal 0 0 + }] + , "\"00\" = Right 0" ~: + (Data.Either.rights $ + [P.runParser + (Amount.Read.amount <* P.eof) + () "" ("00"::Text)]) + ~?= + [Amount.nil + { Amount.quantity = Decimal 0 0 + }] + , "\"0.\" = Right 0." ~: + (Data.Either.rights $ + [P.runParser + (Amount.Read.amount <* P.eof) + () "" ("0."::Text)]) + ~?= + [Amount.nil + { Amount.quantity = Decimal 0 0 + , Amount.style = + Amount.Style.nil + { Amount.Style.fractioning = Just '.' + } + }] + , "\".0\" = Right 0.0" ~: + (Data.Either.rights $ + [P.runParser + (Amount.Read.amount <* P.eof) + () "" (".0"::Text)]) + ~?= + [Amount.nil + { Amount.quantity = Decimal 0 0 + , Amount.style = + Amount.Style.nil + { Amount.Style.fractioning = Just '.' + , Amount.Style.precision = 1 + } + }] + , "\"0,\" = Right 0," ~: + (Data.Either.rights $ + [P.runParser + (Amount.Read.amount <* P.eof) + () "" ("0,"::Text)]) + ~?= + [Amount.nil + { Amount.quantity = Decimal 0 0 + , Amount.style = + Amount.Style.nil + { Amount.Style.fractioning = Just ',' + } + }] + , "\",0\" = Right 0,0" ~: + (Data.Either.rights $ + [P.runParser + (Amount.Read.amount <* P.eof) + () "" (",0"::Text)]) + ~?= + [Amount.nil + { Amount.quantity = Decimal 0 0 + , Amount.style = + Amount.Style.nil + { Amount.Style.fractioning = Just ',' + , Amount.Style.precision = 1 + } + }] + , "\"0_\" = Left" ~: + (Data.Either.rights $ + [P.runParser + (Amount.Read.amount <* P.eof) + () "" ("0_"::Text)]) + ~?= + [] + , "\"_0\" = Left" ~: + (Data.Either.rights $ + [P.runParser + (Amount.Read.amount <* P.eof) + () "" ("_0"::Text)]) + ~?= + [] + , "\"0.0\" = Right 0.0" ~: + (Data.Either.rights $ + [P.runParser + (Amount.Read.amount <* P.eof) + () "" ("0.0"::Text)]) + ~?= + [Amount.nil + { Amount.quantity = Decimal 0 0 + , Amount.style = + Amount.Style.nil + { Amount.Style.fractioning = Just '.' + , Amount.Style.precision = 1 + } + }] + , "\"00.00\" = Right 0.00" ~: + (Data.Either.rights $ + [P.runParser + (Amount.Read.amount <* P.eof) + () "" ("00.00"::Text)]) + ~?= + [Amount.nil + { Amount.quantity = Decimal 0 0 + , Amount.style = + Amount.Style.nil + { Amount.Style.fractioning = Just '.' + , Amount.Style.precision = 2 + } + }] + , "\"0,0\" = Right 0,0" ~: + (Data.Either.rights $ + [P.runParser + (Amount.Read.amount <* P.eof) + () "" ("0,0"::Text)]) + ~?= + [Amount.nil + { Amount.quantity = Decimal 0 0 + , Amount.style = + Amount.Style.nil + { Amount.Style.fractioning = Just ',' + , Amount.Style.precision = 1 + } + }] + , "\"00,00\" = Right 0,00" ~: + (Data.Either.rights $ + [P.runParser + (Amount.Read.amount <* P.eof) + () "" ("00,00"::Text)]) + ~?= + [Amount.nil + { Amount.quantity = Decimal 0 0 + , Amount.style = + Amount.Style.nil + { Amount.Style.fractioning = Just ',' + , Amount.Style.precision = 2 + } + }] + , "\"0_0\" = Right 0" ~: + (Data.Either.rights $ + [P.runParser + (Amount.Read.amount <* P.eof) + () "" ("0_0"::Text)]) + ~?= + [Amount.nil + { Amount.quantity = Decimal 0 0 + , Amount.style = + Amount.Style.nil + { Amount.Style.fractioning = Nothing + , Amount.Style.grouping_integral = Just $ Amount.Style.Grouping '_' [1] + , Amount.Style.precision = 0 + } + }] + , "\"00_00\" = Right 0" ~: + (Data.Either.rights $ + [P.runParser + (Amount.Read.amount <* P.eof) + () "" ("00_00"::Text)]) + ~?= + [Amount.nil + { Amount.quantity = Decimal 0 0 + , Amount.style = + Amount.Style.nil + { Amount.Style.fractioning = Nothing + , Amount.Style.grouping_integral = Just $ Amount.Style.Grouping '_' [2] + , Amount.Style.precision = 0 + } + }] + , "\"0,000.00\" = Right 0,000.00" ~: + (Data.Either.rights $ + [P.runParser + (Amount.Read.amount <* P.eof) + () "" ("0,000.00"::Text)]) + ~?= + [Amount.nil + { Amount.quantity = Decimal 0 0 + , Amount.style = + Amount.Style.nil + { Amount.Style.fractioning = Just '.' + , Amount.Style.grouping_integral = Just $ Amount.Style.Grouping ',' [3] + , Amount.Style.precision = 2 + } + }] + , "\"0.000,00\" = Right 0.000,00" ~: + (Data.Either.rights $ + [P.runParser + (Amount.Read.amount) + () "" ("0.000,00"::Text)]) + ~?= + [Amount.nil + { Amount.quantity = Decimal 0 0 + , Amount.style = + Amount.Style.nil + { Amount.Style.fractioning = Just ',' + , Amount.Style.grouping_integral = Just $ Amount.Style.Grouping '.' [3] + , Amount.Style.precision = 2 + } + }] + , "\"1,000.00\" = Right 1,000.00" ~: + (Data.Either.rights $ + [P.runParser + (Amount.Read.amount <* P.eof) + () "" ("1,000.00"::Text)]) + ~?= + [Amount.nil + { Amount.quantity = Decimal 0 1000 + , Amount.style = + Amount.Style.nil + { Amount.Style.fractioning = Just '.' + , Amount.Style.grouping_integral = Just $ Amount.Style.Grouping ',' [3] + , Amount.Style.precision = 2 + } + }] + , "\"1.000,00\" = Right 1.000,00" ~: + (Data.Either.rights $ + [P.runParser + (Amount.Read.amount) + () "" ("1.000,00"::Text)]) + ~?= + [Amount.nil + { Amount.quantity = Decimal 0 1000 + , Amount.style = + Amount.Style.nil + { Amount.Style.fractioning = Just ',' + , Amount.Style.grouping_integral = Just $ Amount.Style.Grouping '.' [3] + , Amount.Style.precision = 2 + } + }] + , "\"1,000.00.\" = Left" ~: + (Data.Either.rights $ + [P.runParser + (Amount.Read.amount) + () "" ("1,000.00."::Text)]) + ~?= + [] + , "\"1.000,00,\" = Left" ~: + (Data.Either.rights $ + [P.runParser + (Amount.Read.amount) + () "" ("1.000,00,"::Text)]) + ~?= + [] + , "\"1,000.00_\" = Left" ~: + (Data.Either.rights $ + [P.runParser + (Amount.Read.amount) + () "" ("1,000.00_"::Text)]) + ~?= + [] + , "\"12\" = Right 12" ~: + (Data.Either.rights $ + [P.runParser + (Amount.Read.amount <* P.eof) + () "" ("123"::Text)]) + ~?= + [Amount.nil + { Amount.quantity = Decimal 0 123 + }] + , "\"1.2\" = Right 1.2" ~: + (Data.Either.rights $ + [P.runParser + (Amount.Read.amount <* P.eof) + () "" ("1.2"::Text)]) + ~?= + [Amount.nil + { Amount.quantity = Decimal 1 12 + , Amount.style = + Amount.Style.nil + { Amount.Style.fractioning = Just '.' + , Amount.Style.precision = 1 + } + }] + , "\"1,2\" = Right 1,2" ~: + (Data.Either.rights $ + [P.runParser + (Amount.Read.amount <* P.eof) + () "" ("1,2"::Text)]) + ~?= + [Amount.nil + { Amount.quantity = Decimal 1 12 + , Amount.style = + Amount.Style.nil + { Amount.Style.fractioning = Just ',' + , Amount.Style.precision = 1 + } + }] + , "\"12.23\" = Right 12.23" ~: + (Data.Either.rights $ + [P.runParser + (Amount.Read.amount <* P.eof) + () "" ("12.34"::Text)]) + ~?= + [Amount.nil + { Amount.quantity = Decimal 2 1234 + , Amount.style = + Amount.Style.nil + { Amount.Style.fractioning = Just '.' + , Amount.Style.precision = 2 + } + }] + , "\"12,23\" = Right 12,23" ~: + (Data.Either.rights $ + [P.runParser + (Amount.Read.amount <* P.eof) + () "" ("12,34"::Text)]) + ~?= + [Amount.nil + { Amount.quantity = Decimal 2 1234 + , Amount.style = + Amount.Style.nil + { Amount.Style.fractioning = Just ',' + , Amount.Style.precision = 2 + } + }] + , "\"1_2\" = Right 1_2" ~: + (Data.Either.rights $ + [P.runParser + (Amount.Read.amount <* P.eof) + () "" ("1_2"::Text)]) + ~?= + [Amount.nil + { Amount.quantity = Decimal 0 12 + , Amount.style = + Amount.Style.nil + { Amount.Style.grouping_integral = Just $ Amount.Style.Grouping '_' [1] + , Amount.Style.precision = 0 + } + }] + , "\"1_23\" = Right 1_23" ~: + (Data.Either.rights $ + [P.runParser + (Amount.Read.amount <* P.eof) + () "" ("1_23"::Text)]) + ~?= + [Amount.nil + { Amount.quantity = Decimal 0 123 + , Amount.style = + Amount.Style.nil + { Amount.Style.grouping_integral = Just $ Amount.Style.Grouping '_' [2] + , Amount.Style.precision = 0 + } + }] + , "\"1_23_456\" = Right 1_23_456" ~: + (Data.Either.rights $ + [P.runParser + (Amount.Read.amount <* P.eof) + () "" ("1_23_456"::Text)]) + ~?= + [Amount.nil + { Amount.quantity = Decimal 0 123456 + , Amount.style = + Amount.Style.nil + { Amount.Style.grouping_integral = Just $ Amount.Style.Grouping '_' [3, 2] + , Amount.Style.precision = 0 + } + }] + , "\"1_23_456.7890_12345_678901\" = Right 1_23_456.7890_12345_678901" ~: + (Data.Either.rights $ + [P.runParser + (Amount.Read.amount <* P.eof) + () "" ("1_23_456.7890_12345_678901"::Text)]) + ~?= + [Amount.nil + { Amount.quantity = Decimal 15 123456789012345678901 + , Amount.style = + Amount.Style.nil + { Amount.Style.fractioning = Just '.' + , Amount.Style.grouping_integral = Just $ Amount.Style.Grouping '_' [3, 2] + , Amount.Style.grouping_fractional = Just $ Amount.Style.Grouping '_' [4, 5, 6] + , Amount.Style.precision = 15 + } + }] + , "\"123456_78901_2345.678_90_1\" = Right 123456_78901_2345.678_90_1" ~: + (Data.Either.rights $ + [P.runParser + (Amount.Read.amount <* P.eof) + () "" ("123456_78901_2345.678_90_1"::Text)]) + ~?= + [Amount.nil + { Amount.quantity = Decimal 6 123456789012345678901 + , Amount.style = + Amount.Style.nil + { Amount.Style.fractioning = Just '.' + , Amount.Style.grouping_integral = Just $ Amount.Style.Grouping '_' [4, 5, 6] + , Amount.Style.grouping_fractional = Just $ Amount.Style.Grouping '_' [3, 2] + , Amount.Style.precision = 6 + } + }] + , "\"$1\" = Right $1" ~: + (Data.Either.rights $ + [P.runParser + (Amount.Read.amount <* P.eof) + () "" ("$1"::Text)]) + ~?= + [Amount.nil { Amount.quantity = Decimal 0 1 - , Amount.style = Amount.Style.nil - { Amount.Style.unit_side = Just $ Amount.Style.Side_Left + , Amount.style = + Amount.Style.nil + { Amount.Style.fractioning = Nothing + , Amount.Style.grouping_integral = Nothing + , Amount.Style.grouping_fractional = Nothing + , Amount.Style.precision = 0 + , Amount.Style.unit_side = Just Amount.Style.Side_Left + , Amount.Style.unit_spaced = Just False } , Amount.unit = "$" - }) - (Amount.nil + }] + , "\"1$\" = Right 1$" ~: + (Data.Either.rights $ + [P.runParser + (Amount.Read.amount <* P.eof) + () "" ("1$"::Text)]) + ~?= + [Amount.nil { Amount.quantity = Decimal 0 1 - , Amount.style = Amount.Style.nil - { Amount.Style.unit_side = Just $ Amount.Style.Side_Right + , Amount.style = + Amount.Style.nil + { Amount.Style.fractioning = Nothing + , Amount.Style.grouping_integral = Nothing + , Amount.Style.grouping_fractional = Nothing + , Amount.Style.precision = 0 + , Amount.Style.unit_side = Just Amount.Style.Side_Right + , Amount.Style.unit_spaced = Just False } , Amount.unit = "$" - }) - ~?= - (Amount.nil - { Amount.quantity = Decimal 0 2 - , Amount.style = Amount.Style.nil - { Amount.Style.unit_side = Just $ Amount.Style.Side_Left - } - , Amount.unit = "$" - }) - ] - , "from_List" ~: TestList - [ "from_List [$1, 1$] = $2" ~: - Amount.from_List - [ Amount.nil + }] + , "\"$ 1\" = Right $ 1" ~: + (Data.Either.rights $ + [P.runParser + (Amount.Read.amount <* P.eof) + () "" ("$ 1"::Text)]) + ~?= + [Amount.nil { Amount.quantity = Decimal 0 1 - , Amount.style = Amount.Style.nil - { Amount.Style.unit_side = Just $ Amount.Style.Side_Left + , Amount.style = + Amount.Style.nil + { Amount.Style.fractioning = Nothing + , Amount.Style.grouping_integral = Nothing + , Amount.Style.grouping_fractional = Nothing + , Amount.Style.precision = 0 + , Amount.Style.unit_side = Just Amount.Style.Side_Left + , Amount.Style.unit_spaced = Just True } , Amount.unit = "$" - } - , Amount.nil + }] + , "\"1 $\" = Right 1 $" ~: + (Data.Either.rights $ + [P.runParser + (Amount.Read.amount <* P.eof) + () "" ("1 $"::Text)]) + ~?= + [Amount.nil { Amount.quantity = Decimal 0 1 - , Amount.style = Amount.Style.nil - { Amount.Style.unit_side = Just $ Amount.Style.Side_Right + , Amount.style = + Amount.Style.nil + { Amount.Style.fractioning = Nothing + , Amount.Style.grouping_integral = Nothing + , Amount.Style.grouping_fractional = Nothing + , Amount.Style.precision = 0 + , Amount.Style.unit_side = Just Amount.Style.Side_Right + , Amount.Style.unit_spaced = Just True } , Amount.unit = "$" - } - ] - ~?= - Data.Map.fromList - [ ("$", Amount.nil - { Amount.quantity = Decimal 0 2 - , Amount.style = Amount.Style.nil - { Amount.Style.unit_side = Just $ Amount.Style.Side_Left + }] + , "\"-$1\" = Right $-1" ~: + (Data.Either.rights $ + [P.runParser + (Amount.Read.amount <* P.eof) + () "" ("-$1"::Text)]) + ~?= + [Amount.nil + { Amount.quantity = Decimal 0 (-1) + , Amount.style = + Amount.Style.nil + { Amount.Style.fractioning = Nothing + , Amount.Style.grouping_integral = Nothing + , Amount.Style.grouping_fractional = Nothing + , Amount.Style.precision = 0 + , Amount.Style.unit_side = Just Amount.Style.Side_Left + , Amount.Style.unit_spaced = Just False } , Amount.unit = "$" - }) - ] + }] + , "\"\\\"4 2\\\"1\" = Right \\\"4 2\\\"1" ~: + (Data.Either.rights $ + [P.runParser + (Amount.Read.amount <* P.eof) + () "" ("\"4 2\"1"::Text)]) + ~?= + [Amount.nil + { Amount.quantity = Decimal 0 1 + , Amount.style = + Amount.Style.nil + { Amount.Style.fractioning = Nothing + , Amount.Style.grouping_integral = Nothing + , Amount.Style.grouping_fractional = Nothing + , Amount.Style.precision = 0 + , Amount.Style.unit_side = Just Amount.Style.Side_Left + , Amount.Style.unit_spaced = Just False + } + , Amount.unit = "4 2" + }] + , "\"1\\\"4 2\\\"\" = Right 1\\\"4 2\\\"" ~: + (Data.Either.rights $ + [P.runParser + (Amount.Read.amount <* P.eof) + () "" ("1\"4 2\""::Text)]) + ~?= + [Amount.nil + { Amount.quantity = Decimal 0 1 + , Amount.style = + Amount.Style.nil + { Amount.Style.fractioning = Nothing + , Amount.Style.grouping_integral = Nothing + , Amount.Style.grouping_fractional = Nothing + , Amount.Style.precision = 0 + , Amount.Style.unit_side = Just Amount.Style.Side_Right + , Amount.Style.unit_spaced = Just False + } + , Amount.unit = "4 2" + }] + , "\"$1.000,00\" = Right $1.000,00" ~: + (Data.Either.rights $ + [P.runParser + (Amount.Read.amount <* P.eof) + () "" ("$1.000,00"::Text)]) + ~?= + [Amount.nil + { Amount.quantity = Decimal 0 1000 + , Amount.style = + Amount.Style.nil + { Amount.Style.fractioning = Just ',' + , Amount.Style.grouping_integral = Just $ Amount.Style.Grouping '.' [3] + , Amount.Style.grouping_fractional = Nothing + , Amount.Style.precision = 2 + , Amount.Style.unit_side = Just Amount.Style.Side_Left + , Amount.Style.unit_spaced = Just False + } + , Amount.unit = "$" + }] + , "\"1.000,00$\" = Right 1.000,00$" ~: + (Data.Either.rights $ + [P.runParser + (Amount.Read.amount <* P.eof) + () "" ("1.000,00$"::Text)]) + ~?= + [Amount.nil + { Amount.quantity = Decimal 0 1000 + , Amount.style = + Amount.Style.nil + { Amount.Style.fractioning = Just ',' + , Amount.Style.grouping_integral = Just $ Amount.Style.Grouping '.' [3] + , Amount.Style.grouping_fractional = Nothing + , Amount.Style.precision = 2 + , Amount.Style.unit_side = Just Amount.Style.Side_Right + , Amount.Style.unit_spaced = Just False + } + , Amount.unit = "$" + }] ] ] - , "Filter" ~: TestList - [ "test" ~: TestList - [ "Test_Account" ~: TestList - [ "A A" ~? - Filter.test - [ Filter.Test_Account_Section_Text - (Filter.Test_Text_Exact "A") - ] - (("A":|[]::Account)) - , "* A" ~? - Filter.test - [ Filter.Test_Account_Section_Any - ] - (("A":|[]::Account)) - , ": A" ~? - Filter.test - [ Filter.Test_Account_Section_Many - ] - (("A":|[]::Account)) - , ":A A" ~? - Filter.test - [ Filter.Test_Account_Section_Many - , Filter.Test_Account_Section_Text - (Filter.Test_Text_Exact "A") - ] - (("A":|[]::Account)) - , "A: A" ~? - Filter.test - [ Filter.Test_Account_Section_Text - (Filter.Test_Text_Exact "A") - , Filter.Test_Account_Section_Many - ] - (("A":|[]::Account)) - , "A: A:B" ~? - Filter.test - [ Filter.Test_Account_Section_Text - (Filter.Test_Text_Exact "A") - , Filter.Test_Account_Section_Many - ] - (("A":|"B":[]::Account)) - , "A:B A:B" ~? - Filter.test - [ Filter.Test_Account_Section_Text - (Filter.Test_Text_Exact "A") - , Filter.Test_Account_Section_Text - (Filter.Test_Text_Exact "B") - ] - (("A":|"B":[]::Account)) - , "A::B A:B" ~? - Filter.test - [ Filter.Test_Account_Section_Text - (Filter.Test_Text_Exact "A") - , Filter.Test_Account_Section_Many - , Filter.Test_Account_Section_Text - (Filter.Test_Text_Exact "B") - ] - (("A":|"B":[]::Account)) - , ":B: A:B:C" ~? - Filter.test - [ Filter.Test_Account_Section_Many - , Filter.Test_Account_Section_Text - (Filter.Test_Text_Exact "B") - , Filter.Test_Account_Section_Many - ] - (("A":|"B":"C":[]::Account)) - , ":C A:B:C" ~? - Filter.test - [ Filter.Test_Account_Section_Many - , Filter.Test_Account_Section_Text - (Filter.Test_Text_Exact "C") - ] - (("A":|"B":"C":[]::Account)) - ] - , "Test_Bool" ~: TestList - [ "Any A" ~? - Filter.test - (Filter.Any::Filter.Test_Bool Filter.Test_Account) - (("A":|[]::Account)) - ] + ] + , "Date" ~: TestList + [ "Read" ~: TestList + [ "date" ~: TestList + [ "2000/01/01" ~: + (Data.Either.rights $ + [P.runParser_with_Error + (Date.Read.date id Nothing <* P.eof) + () "" ("2000/01/01"::Text)]) + ~?= + [ Time.zonedTimeToUTC $ + Time.ZonedTime + (Time.LocalTime + (Time.fromGregorian 2000 01 01) + (Time.TimeOfDay 0 0 0)) + (Time.utc)] + , "2000/01/01 some text" ~: + (Data.Either.rights $ + [P.runParser_with_Error + (Date.Read.date id Nothing) + () "" ("2000/01/01 some text"::Text)]) + ~?= + [ Time.zonedTimeToUTC $ + Time.ZonedTime + (Time.LocalTime + (Time.fromGregorian 2000 01 01) + (Time.TimeOfDay 0 0 0)) + (Time.utc)] + , "2000/01/01 12:34" ~: + (Data.Either.rights $ + [P.runParser_with_Error + (Date.Read.date id Nothing <* P.eof) + () "" ("2000/01/01 12:34"::Text)]) + ~?= + [ Time.zonedTimeToUTC $ + Time.ZonedTime + (Time.LocalTime + (Time.fromGregorian 2000 01 01) + (Time.TimeOfDay 12 34 0)) + (Time.utc)] + , "2000/01/01 12:34:56" ~: + (Data.Either.rights $ + [P.runParser_with_Error + (Date.Read.date id Nothing <* P.eof) + () "" ("2000/01/01 12:34:56"::Text)]) + ~?= + [ Time.zonedTimeToUTC $ + Time.ZonedTime + (Time.LocalTime + (Time.fromGregorian 2000 01 01) + (Time.TimeOfDay 12 34 56)) + (Time.utc)] + , "2000/01/01 12:34 CET" ~: + (Data.Either.rights $ + [P.runParser_with_Error + (Date.Read.date id Nothing <* P.eof) + () "" ("2000/01/01 12:34 CET"::Text)]) + ~?= + [ Time.zonedTimeToUTC $ + Time.ZonedTime + (Time.LocalTime + (Time.fromGregorian 2000 01 01) + (Time.TimeOfDay 12 34 0)) + (Time.TimeZone 60 True "CET")] + , "2000/01/01 12:34 +0130" ~: + (Data.Either.rights $ + [P.runParser_with_Error + (Date.Read.date id Nothing <* P.eof) + () "" ("2000/01/01 12:34 +0130"::Text)]) + ~?= + [ Time.zonedTimeToUTC $ + Time.ZonedTime + (Time.LocalTime + (Time.fromGregorian 2000 01 01) + (Time.TimeOfDay 12 34 0)) + (Time.TimeZone 90 False "+0130")] + , "2000/01/01 12:34:56 CET" ~: + (Data.Either.rights $ + [P.runParser_with_Error + (Date.Read.date id Nothing <* P.eof) + () "" ("2000/01/01 12:34:56 CET"::Text)]) + ~?= + [ Time.zonedTimeToUTC $ + Time.ZonedTime + (Time.LocalTime + (Time.fromGregorian 2000 01 01) + (Time.TimeOfDay 12 34 56)) + (Time.TimeZone 60 True "CET")] + , "2001/02/29" ~: + (Data.Either.rights $ + [P.runParser_with_Error + (Date.Read.date id Nothing <* P.eof) + () "" ("2001/02/29"::Text)]) + ~?= + [] + , "01/01" ~: + (Data.Either.rights $ + [P.runParser_with_Error + (Date.Read.date id (Just 2000) <* P.eof) + () "" ("01/01"::Text)]) + ~?= + [ Time.zonedTimeToUTC $ + Time.ZonedTime + (Time.LocalTime + (Time.fromGregorian 2000 01 01) + (Time.TimeOfDay 0 0 0)) + (Time.utc)] ] - , "Read" ~: TestList - [ "test_account_section" ~: TestList - [ "*" ~: - (Data.Either.rights $ - [P.runParser - (Filter.Read.test_account <* P.eof) - () "" ("*"::Text)]) - ~?= - [ [Filter.Test_Account_Section_Any] - ] - , "A" ~: - (Data.Either.rights $ - [P.runParser - (Filter.Read.test_account <* P.eof) - () "" ("A"::Text)]) - ~?= - [ [Filter.Test_Account_Section_Text (Filter.Test_Text_Exact "A")] + ] + ] + , "Filter" ~: TestList + [ "test" ~: TestList + [ "Test_Account" ~: TestList + [ "A A" ~? + Filter.test + [ Filter.Test_Account_Section_Text + (Filter.Test_Text_Exact "A") ] - , "AA" ~: - (Data.Either.rights $ - [P.runParser - (Filter.Read.test_account <* P.eof) - () "" ("AA"::Text)]) - ~?= - [ [Filter.Test_Account_Section_Text (Filter.Test_Text_Exact "AA")] + (("A":|[]::Account)) + , "* A" ~? + Filter.test + [ Filter.Test_Account_Section_Any ] - , "::A" ~: - (Data.Either.rights $ - [P.runParser - (Filter.Read.test_account <* P.eof) - () "" ("::A"::Text)]) - ~?= - [ [ Filter.Test_Account_Section_Many - , Filter.Test_Account_Section_Text (Filter.Test_Text_Exact "A") - ] + (("A":|[]::Account)) + , ": A" ~? + Filter.test + [ Filter.Test_Account_Section_Many ] - , ":A" ~: - (Data.Either.rights $ - [P.runParser - (Filter.Read.test_account <* P.eof) - () "" (":A"::Text)]) - ~?= - [ [ Filter.Test_Account_Section_Many - , Filter.Test_Account_Section_Text (Filter.Test_Text_Exact "A") - ] + (("A":|[]::Account)) + , ":A A" ~? + Filter.test + [ Filter.Test_Account_Section_Many + , Filter.Test_Account_Section_Text + (Filter.Test_Text_Exact "A") ] - , "A:" ~: - (Data.Either.rights $ - [P.runParser - (Filter.Read.test_account <* P.eof) - () "" ("A:"::Text)]) - ~?= - [ [ Filter.Test_Account_Section_Text (Filter.Test_Text_Exact "A") - , Filter.Test_Account_Section_Many - ] + (("A":|[]::Account)) + , "A: A" ~? + Filter.test + [ Filter.Test_Account_Section_Text + (Filter.Test_Text_Exact "A") + , Filter.Test_Account_Section_Many ] - , "A::" ~: - (Data.Either.rights $ - [P.runParser - (Filter.Read.test_account <* P.eof) - () "" ("A::"::Text)]) - ~?= - [ [ Filter.Test_Account_Section_Text (Filter.Test_Text_Exact "A") - , Filter.Test_Account_Section_Many - ] + (("A":|[]::Account)) + , "A: A:B" ~? + Filter.test + [ Filter.Test_Account_Section_Text + (Filter.Test_Text_Exact "A") + , Filter.Test_Account_Section_Many ] - , "A:B" ~: - (Data.Either.rights $ - [P.runParser - (Filter.Read.test_account <* P.eof) - () "" ("A:B"::Text)]) - ~?= - [ [ Filter.Test_Account_Section_Text (Filter.Test_Text_Exact "A") - , Filter.Test_Account_Section_Text (Filter.Test_Text_Exact "B") ] + (("A":|"B":[]::Account)) + , "A:B A:B" ~? + Filter.test + [ Filter.Test_Account_Section_Text + (Filter.Test_Text_Exact "A") + , Filter.Test_Account_Section_Text + (Filter.Test_Text_Exact "B") ] - , "A::B" ~: - (Data.Either.rights $ - [P.runParser - (Filter.Read.test_account <* P.eof) - () "" ("A::B"::Text)]) - ~?= - [ [ Filter.Test_Account_Section_Text (Filter.Test_Text_Exact "A") - , Filter.Test_Account_Section_Many - , Filter.Test_Account_Section_Text (Filter.Test_Text_Exact "B") - ] + (("A":|"B":[]::Account)) + , "A::B A:B" ~? + Filter.test + [ Filter.Test_Account_Section_Text + (Filter.Test_Text_Exact "A") + , Filter.Test_Account_Section_Many + , Filter.Test_Account_Section_Text + (Filter.Test_Text_Exact "B") ] - , "A:::B" ~: - (Data.Either.rights $ - [P.runParser - (Filter.Read.test_account <* P.eof) - () "" ("A:::B"::Text)]) - ~?= - [ [ Filter.Test_Account_Section_Text (Filter.Test_Text_Exact "A") - , Filter.Test_Account_Section_Many - , Filter.Test_Account_Section_Text (Filter.Test_Text_Exact "B") - ] + (("A":|"B":[]::Account)) + , ":B: A:B:C" ~? + Filter.test + [ Filter.Test_Account_Section_Many + , Filter.Test_Account_Section_Text + (Filter.Test_Text_Exact "B") + , Filter.Test_Account_Section_Many ] - , "A: " ~: - (Data.Either.rights $ - [P.runParser - (Filter.Read.test_account <* P.char ' ' <* P.eof) - () "" ("A: "::Text)]) - ~?= - [ [ Filter.Test_Account_Section_Text (Filter.Test_Text_Exact "A") - , Filter.Test_Account_Section_Many - ] + (("A":|"B":"C":[]::Account)) + , ":C A:B:C" ~? + Filter.test + [ Filter.Test_Account_Section_Many + , Filter.Test_Account_Section_Text + (Filter.Test_Text_Exact "C") ] + (("A":|"B":"C":[]::Account)) + ] + , "Test_Bool" ~: TestList + [ "Any A" ~? + Filter.test + (Filter.Any::Filter.Test_Bool Filter.Test_Account) + (("A":|[]::Account)) + ] + ] + , "Read" ~: TestList + [ "test_account_section" ~: TestList + [ "*" ~: + (Data.Either.rights $ + [P.runParser + (Filter.Read.test_account <* P.eof) + () "" ("*"::Text)]) + ~?= + [ [Filter.Test_Account_Section_Any] ] - , "test_bool" ~: TestList - [ "( E )" ~: - (Data.Either.rights $ - [P.runParser - (Filter.Read.test_bool - [ P.char 'E' >> return (return True) ] - <* P.eof) - () "" ("( E )"::Text)]) - ~?= - [ Filter.And (Filter.Bool True) Filter.Any + , "A" ~: + (Data.Either.rights $ + [P.runParser + (Filter.Read.test_account <* P.eof) + () "" ("A"::Text)]) + ~?= + [ [Filter.Test_Account_Section_Text (Filter.Test_Text_Exact "A")] + ] + , "AA" ~: + (Data.Either.rights $ + [P.runParser + (Filter.Read.test_account <* P.eof) + () "" ("AA"::Text)]) + ~?= + [ [Filter.Test_Account_Section_Text (Filter.Test_Text_Exact "AA")] + ] + , "::A" ~: + (Data.Either.rights $ + [P.runParser + (Filter.Read.test_account <* P.eof) + () "" ("::A"::Text)]) + ~?= + [ [ Filter.Test_Account_Section_Many + , Filter.Test_Account_Section_Text (Filter.Test_Text_Exact "A") ] - , "( ( E ) )" ~: - (Data.Either.rights $ - [P.runParser - (Filter.Read.test_bool - [ P.char 'E' >> return (return True) ] - <* P.eof) - () "" ("( ( E ) )"::Text)]) - ~?= - [ Filter.And (Filter.And (Filter.Bool True) Filter.Any) Filter.Any + ] + , ":A" ~: + (Data.Either.rights $ + [P.runParser + (Filter.Read.test_account <* P.eof) + () "" (":A"::Text)]) + ~?= + [ [ Filter.Test_Account_Section_Many + , Filter.Test_Account_Section_Text (Filter.Test_Text_Exact "A") ] - , "( E ) & ( E )" ~: - (Data.Either.rights $ - [P.runParser - (Filter.Read.test_bool - [ P.char 'E' >> return (return True) ] - <* P.eof) - () "" ("( E ) & ( E )"::Text)]) - ~?= - [ Filter.And - (Filter.And (Filter.Bool True) Filter.Any) - (Filter.And (Filter.Bool True) Filter.Any) + ] + , "A:" ~: + (Data.Either.rights $ + [P.runParser + (Filter.Read.test_account <* P.eof) + () "" ("A:"::Text)]) + ~?= + [ [ Filter.Test_Account_Section_Text (Filter.Test_Text_Exact "A") + , Filter.Test_Account_Section_Many ] - , "( E ) + ( E )" ~: - (Data.Either.rights $ - [P.runParser - (Filter.Read.test_bool - [ P.char 'E' >> return (return True) ] - <* P.eof) - () "" ("( E ) + ( E )"::Text)]) - ~?= - [ Filter.Or - (Filter.And (Filter.Bool True) Filter.Any) - (Filter.And (Filter.Bool True) Filter.Any) + ] + , "A::" ~: + (Data.Either.rights $ + [P.runParser + (Filter.Read.test_account <* P.eof) + () "" ("A::"::Text)]) + ~?= + [ [ Filter.Test_Account_Section_Text (Filter.Test_Text_Exact "A") + , Filter.Test_Account_Section_Many ] - , "( E ) - ( E )" ~: - (Data.Either.rights $ - [P.runParser - (Filter.Read.test_bool - [ P.char 'E' >> return (return True) ] - <* P.eof) - () "" ("( E ) - ( E )"::Text)]) - ~?= - [ Filter.And - (Filter.And (Filter.Bool True) Filter.Any) - (Filter.Not (Filter.And (Filter.Bool True) Filter.Any)) + ] + , "A:B" ~: + (Data.Either.rights $ + [P.runParser + (Filter.Read.test_account <* P.eof) + () "" ("A:B"::Text)]) + ~?= + [ [ Filter.Test_Account_Section_Text (Filter.Test_Text_Exact "A") + , Filter.Test_Account_Section_Text (Filter.Test_Text_Exact "B") ] + ] + , "A::B" ~: + (Data.Either.rights $ + [P.runParser + (Filter.Read.test_account <* P.eof) + () "" ("A::B"::Text)]) + ~?= + [ [ Filter.Test_Account_Section_Text (Filter.Test_Text_Exact "A") + , Filter.Test_Account_Section_Many + , Filter.Test_Account_Section_Text (Filter.Test_Text_Exact "B") ] - , "(- E )" ~: - (Data.Either.rights $ - [P.runParser - (Filter.Read.test_bool - [ P.char 'E' >> return (return True) ] - <* P.eof) - () "" ("(- E )"::Text)]) - ~?= - [ Filter.And (Filter.Not (Filter.Bool True)) Filter.Any + ] + , "A:::B" ~: + (Data.Either.rights $ + [P.runParser + (Filter.Read.test_account <* P.eof) + () "" ("A:::B"::Text)]) + ~?= + [ [ Filter.Test_Account_Section_Text (Filter.Test_Text_Exact "A") + , Filter.Test_Account_Section_Many + , Filter.Test_Account_Section_Text (Filter.Test_Text_Exact "B") + ] + ] + , "A: " ~: + (Data.Either.rights $ + [P.runParser + (Filter.Read.test_account <* P.char ' ' <* P.eof) + () "" ("A: "::Text)]) + ~?= + [ [ Filter.Test_Account_Section_Text (Filter.Test_Text_Exact "A") + , Filter.Test_Account_Section_Many ] ] ] + , "test_bool" ~: TestList + [ "( E )" ~: + (Data.Either.rights $ + [P.runParser + (Filter.Read.test_bool + [ P.char 'E' >> return (return True) ] + <* P.eof) + () "" ("( E )"::Text)]) + ~?= + [ Filter.And (Filter.Bool True) Filter.Any + ] + , "( ( E ) )" ~: + (Data.Either.rights $ + [P.runParser + (Filter.Read.test_bool + [ P.char 'E' >> return (return True) ] + <* P.eof) + () "" ("( ( E ) )"::Text)]) + ~?= + [ Filter.And (Filter.And (Filter.Bool True) Filter.Any) Filter.Any + ] + , "( E ) & ( E )" ~: + (Data.Either.rights $ + [P.runParser + (Filter.Read.test_bool + [ P.char 'E' >> return (return True) ] + <* P.eof) + () "" ("( E ) & ( E )"::Text)]) + ~?= + [ Filter.And + (Filter.And (Filter.Bool True) Filter.Any) + (Filter.And (Filter.Bool True) Filter.Any) + ] + , "( E ) + ( E )" ~: + (Data.Either.rights $ + [P.runParser + (Filter.Read.test_bool + [ P.char 'E' >> return (return True) ] + <* P.eof) + () "" ("( E ) + ( E )"::Text)]) + ~?= + [ Filter.Or + (Filter.And (Filter.Bool True) Filter.Any) + (Filter.And (Filter.Bool True) Filter.Any) + ] + , "( E ) - ( E )" ~: + (Data.Either.rights $ + [P.runParser + (Filter.Read.test_bool + [ P.char 'E' >> return (return True) ] + <* P.eof) + () "" ("( E ) - ( E )"::Text)]) + ~?= + [ Filter.And + (Filter.And (Filter.Bool True) Filter.Any) + (Filter.Not (Filter.And (Filter.Bool True) Filter.Any)) + ] + , "(- E )" ~: + (Data.Either.rights $ + [P.runParser + (Filter.Read.test_bool + [ P.char 'E' >> return (return True) ] + <* P.eof) + () "" ("(- E )"::Text)]) + ~?= + [ Filter.And (Filter.Not (Filter.Bool True)) Filter.Any + ] + ] ] ] - , "Calc" ~: TestList - [ "Balance" ~: TestList - [ "balance" ~: TestList - [ "[A+$1] = A+$1 & $+1" ~: - (Calc.Balance.balance - (Format.Ledger.posting ("A":|[])) - { Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ 1 ] - } - Calc.Balance.nil) - ~?= - Calc.Balance.Balance - { Calc.Balance.balance_by_account = - Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Calc.Balance.amount_sum) $ - [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) ] - , Calc.Balance.balance_by_unit = - Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Calc.Balance.amount_sum_balance $ Calc.Balance.unit_sum_amount s, s)) - [ Calc.Balance.Unit_Sum - { Calc.Balance.unit_sum_amount = Calc.Balance.amount_sum $ Amount.usd $ 1 - , Calc.Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) - ["A":|[]] - } - ] + , "Balance" ~: TestList + [ "balance" ~: TestList + [ "[A+$1] = A+$1 & $+1" ~: + (Balance.balance + (Format.Ledger.posting ("A":|[])) + { Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ 1 ] } - , "[A+$1, A-$1] = {A+$0, $+0}" ~: - (Data.List.foldl - (flip Calc.Balance.balance) - Calc.Balance.nil - [ (Format.Ledger.posting ("A":|[])) - { Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ 1 ] - } - , (Format.Ledger.posting ("A":|[])) - { Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ -1 ] - } - ]) - ~?= - Calc.Balance.Balance - { Calc.Balance.balance_by_account = - Lib.TreeMap.from_List const $ - [ ( "A":|[] - , Data.Map.fromListWith const $ - Data.List.map (\s -> (Amount.unit $ Calc.Balance.amount_sum_balance s, s)) - [ Calc.Balance.Amount_Sum - { Calc.Balance.amount_sum_negative = Just $ Amount.usd $ -1 - , Calc.Balance.amount_sum_positive = Just $ Amount.usd $ 1 - , Calc.Balance.amount_sum_balance = Amount.usd $ 0 - } - ] - ) ] - , Calc.Balance.balance_by_unit = - Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Calc.Balance.amount_sum_balance $ Calc.Balance.unit_sum_amount s, s)) - [ Calc.Balance.Unit_Sum - { Calc.Balance.unit_sum_amount = Calc.Balance.Amount_Sum - { Calc.Balance.amount_sum_negative = Just $ Amount.usd $ -1 - , Calc.Balance.amount_sum_positive = Just $ Amount.usd $ 1 - , Calc.Balance.amount_sum_balance = Amount.usd $ 0 - } - , Calc.Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) - ["A":|[]] - } - ] + Balance.nil) + ~?= + Balance.Balance + { Balance.balance_by_account = + Lib.TreeMap.from_List const $ + Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) ] + , Balance.balance_by_unit = + Data.Map.fromList $ + Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + [ Balance.Unit_Sum + { Balance.unit_sum_amount = Balance.amount_sum $ Amount.usd $ 1 + , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) + ["A":|[]] } - , "[A+$1, A-€1] = {A+$1-€1, $+1 €-1}" ~: - (Data.List.foldl - (flip Calc.Balance.balance) - Calc.Balance.nil - [ (Format.Ledger.posting ("A":|[])) - { Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ 1 ] - } - , (Format.Ledger.posting ("A":|[])) - { Format.Ledger.posting_amounts=Amount.from_List [ Amount.eur $ -1 ] - } - ]) - ~?= - Calc.Balance.Balance - { Calc.Balance.balance_by_account = - Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Calc.Balance.amount_sum) $ - [ ("A":|[], Amount.from_List [ Amount.usd $ 1, Amount.eur $ -1 ]) ] - , Calc.Balance.balance_by_unit = - Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Calc.Balance.amount_sum_balance $ Calc.Balance.unit_sum_amount s, s)) - [ Calc.Balance.Unit_Sum - { Calc.Balance.unit_sum_amount = Calc.Balance.Amount_Sum - { Calc.Balance.amount_sum_negative = Nothing - , Calc.Balance.amount_sum_positive = Just $ Amount.usd $ 1 - , Calc.Balance.amount_sum_balance = Amount.usd $ 1 - } - , Calc.Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) - ["A":|[]] - } - , Calc.Balance.Unit_Sum - { Calc.Balance.unit_sum_amount = Calc.Balance.Amount_Sum - { Calc.Balance.amount_sum_negative = Just $ Amount.eur $ -1 - , Calc.Balance.amount_sum_positive = Nothing - , Calc.Balance.amount_sum_balance = Amount.eur $ -1 - } - , Calc.Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) - ["A":|[]] - } - ] + ] + } + , "[A+$1, A-$1] = {A+$0, $+0}" ~: + (Data.List.foldl + (flip Balance.balance) + Balance.nil + [ (Format.Ledger.posting ("A":|[])) + { Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ 1 ] } - , "[A+$1, B-$1] = {A+$1 B-$1, $+0}" ~: - (Data.List.foldl - (flip Calc.Balance.balance) - Calc.Balance.nil - [ (Format.Ledger.posting ("A":|[])) - { Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ 1 ] - } - , (Format.Ledger.posting ("B":|[])) - { Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ -1 ] - } - ]) - ~?= - Calc.Balance.Balance - { Calc.Balance.balance_by_account = - Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Calc.Balance.amount_sum) $ - [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) - , ("B":|[], Amount.from_List [ Amount.usd $ -1 ]) - ] - , Calc.Balance.balance_by_unit = - Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Calc.Balance.amount_sum_balance $ Calc.Balance.unit_sum_amount s, s)) - [ Calc.Balance.Unit_Sum - { Calc.Balance.unit_sum_amount = Calc.Balance.Amount_Sum - { Calc.Balance.amount_sum_negative = Just $ Amount.usd $ -1 - , Calc.Balance.amount_sum_positive = Just $ Amount.usd $ 1 - , Calc.Balance.amount_sum_balance = Amount.usd $ 0 - } - , Calc.Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) - ["A":|[], "B":|[]] - } - ] + , (Format.Ledger.posting ("A":|[])) + { Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ -1 ] } - , "[A+$1, B+$1]" ~: - (Data.List.foldl - (flip Calc.Balance.balance) - Calc.Balance.nil - [ (Format.Ledger.posting ("A":|[])) - { Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ 1 ] - } - , (Format.Ledger.posting ("B":|[])) - { Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ 1 ] - } - ]) - ~?= - Calc.Balance.Balance - { Calc.Balance.balance_by_account = - Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Calc.Balance.amount_sum) $ - [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) - , ("B":|[], Amount.from_List [ Amount.usd $ 1 ]) - ] - , Calc.Balance.balance_by_unit = - Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Calc.Balance.amount_sum_balance $ Calc.Balance.unit_sum_amount s, s)) - [ Calc.Balance.Unit_Sum - { Calc.Balance.unit_sum_amount = Calc.Balance.amount_sum $ Amount.usd $ 2 - , Calc.Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) - ["A":|[], "B":|[]] - } - ] + ]) + ~?= + Balance.Balance + { Balance.balance_by_account = + Lib.TreeMap.from_List const $ + [ ( "A":|[] + , Data.Map.fromListWith const $ + Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance s, s)) + [ Balance.Amount_Sum + { Balance.amount_sum_negative = Just $ Amount.usd $ -1 + , Balance.amount_sum_positive = Just $ Amount.usd $ 1 + , Balance.amount_sum_balance = Amount.usd $ 0 + } + ] + ) ] + , Balance.balance_by_unit = + Data.Map.fromList $ + Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + [ Balance.Unit_Sum + { Balance.unit_sum_amount = Balance.Amount_Sum + { Balance.amount_sum_negative = Just $ Amount.usd $ -1 + , Balance.amount_sum_positive = Just $ Amount.usd $ 1 + , Balance.amount_sum_balance = Amount.usd $ 0 + } + , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) + ["A":|[]] } - , "[A+$1+€2, A-$1-€2] = {A+$0+€0, $+0 €+0}" ~: - (Data.List.foldl - (flip Calc.Balance.balance) - Calc.Balance.nil - [ (Format.Ledger.posting ("A":|[])) - { Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ 1, Amount.eur $ 2 ] - } - , (Format.Ledger.posting ("A":|[])) - { Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ -1, Amount.eur $ -2 ] - } - ]) - ~?= - Calc.Balance.Balance - { Calc.Balance.balance_by_account = + ] + } + , "[A+$1, A-€1] = {A+$1-€1, $+1 €-1}" ~: + (Data.List.foldl + (flip Balance.balance) + Balance.nil + [ (Format.Ledger.posting ("A":|[])) + { Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ 1 ] + } + , (Format.Ledger.posting ("A":|[])) + { Format.Ledger.posting_amounts=Amount.from_List [ Amount.eur $ -1 ] + } + ]) + ~?= + Balance.Balance + { Balance.balance_by_account = + Lib.TreeMap.from_List const $ + Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + [ ("A":|[], Amount.from_List [ Amount.usd $ 1, Amount.eur $ -1 ]) ] + , Balance.balance_by_unit = + Data.Map.fromList $ + Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + [ Balance.Unit_Sum + { Balance.unit_sum_amount = Balance.Amount_Sum + { Balance.amount_sum_negative = Nothing + , Balance.amount_sum_positive = Just $ Amount.usd $ 1 + , Balance.amount_sum_balance = Amount.usd $ 1 + } + , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) + ["A":|[]] + } + , Balance.Unit_Sum + { Balance.unit_sum_amount = Balance.Amount_Sum + { Balance.amount_sum_negative = Just $ Amount.eur $ -1 + , Balance.amount_sum_positive = Nothing + , Balance.amount_sum_balance = Amount.eur $ -1 + } + , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) + ["A":|[]] + } + ] + } + , "[A+$1, B-$1] = {A+$1 B-$1, $+0}" ~: + (Data.List.foldl + (flip Balance.balance) + Balance.nil + [ (Format.Ledger.posting ("A":|[])) + { Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ 1 ] + } + , (Format.Ledger.posting ("B":|[])) + { Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ -1 ] + } + ]) + ~?= + Balance.Balance + { Balance.balance_by_account = + Lib.TreeMap.from_List const $ + Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) + , ("B":|[], Amount.from_List [ Amount.usd $ -1 ]) + ] + , Balance.balance_by_unit = + Data.Map.fromList $ + Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + [ Balance.Unit_Sum + { Balance.unit_sum_amount = Balance.Amount_Sum + { Balance.amount_sum_negative = Just $ Amount.usd $ -1 + , Balance.amount_sum_positive = Just $ Amount.usd $ 1 + , Balance.amount_sum_balance = Amount.usd $ 0 + } + , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) + ["A":|[], "B":|[]] + } + ] + } + , "[A+$1, B+$1]" ~: + (Data.List.foldl + (flip Balance.balance) + Balance.nil + [ (Format.Ledger.posting ("A":|[])) + { Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ 1 ] + } + , (Format.Ledger.posting ("B":|[])) + { Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ 1 ] + } + ]) + ~?= + Balance.Balance + { Balance.balance_by_account = + Lib.TreeMap.from_List const $ + Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) + , ("B":|[], Amount.from_List [ Amount.usd $ 1 ]) + ] + , Balance.balance_by_unit = + Data.Map.fromList $ + Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + [ Balance.Unit_Sum + { Balance.unit_sum_amount = Balance.amount_sum $ Amount.usd $ 2 + , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) + ["A":|[], "B":|[]] + } + ] + } + , "[A+$1+€2, A-$1-€2] = {A+$0+€0, $+0 €+0}" ~: + (Data.List.foldl + (flip Balance.balance) + Balance.nil + [ (Format.Ledger.posting ("A":|[])) + { Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ 1, Amount.eur $ 2 ] + } + , (Format.Ledger.posting ("A":|[])) + { Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ -1, Amount.eur $ -2 ] + } + ]) + ~?= + Balance.Balance + { Balance.balance_by_account = + Lib.TreeMap.from_List const $ + [ ("A":|[] + , Data.Map.fromListWith const $ + Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance s, s)) + [ Balance.Amount_Sum + { Balance.amount_sum_negative = Just $ Amount.usd $ -1 + , Balance.amount_sum_positive = Just $ Amount.usd $ 1 + , Balance.amount_sum_balance = Amount.usd $ 0 + } + , Balance.Amount_Sum + { Balance.amount_sum_negative = Just $ Amount.eur $ -2 + , Balance.amount_sum_positive = Just $ Amount.eur $ 2 + , Balance.amount_sum_balance = Amount.eur $ 0 + } + ] + ) + ] + , Balance.balance_by_unit = + Data.Map.fromList $ + Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + [ Balance.Unit_Sum + { Balance.unit_sum_amount = Balance.Amount_Sum + { Balance.amount_sum_negative = Just $ Amount.usd $ -1 + , Balance.amount_sum_positive = Just $ Amount.usd $ 1 + , Balance.amount_sum_balance = Amount.usd $ 0 + } + , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) + ["A":|[]] + } + , Balance.Unit_Sum + { Balance.unit_sum_amount = Balance.Amount_Sum + { Balance.amount_sum_negative = Just $ Amount.eur $ -2 + , Balance.amount_sum_positive = Just $ Amount.eur $ 2 + , Balance.amount_sum_balance = Amount.eur $ 0 + } + , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) + ["A":|[]] + } + ] + } + , "[A+$1+€2+£3, B-$1-2€-£3] = {A+$1+€2+£3 B-$1-€2-£3, $+0 €+0 £+0}" ~: + (Data.List.foldl + (flip Balance.balance) + Balance.nil + [ (Format.Ledger.posting ("A":|[])) + { Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ 1, Amount.eur $ 2, Amount.gbp $ 3 ] + } + , (Format.Ledger.posting ("B":|[])) + { Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ -1, Amount.eur $ -2, Amount.gbp $ -3 ] + } + ]) + ~?= + Balance.Balance + { Balance.balance_by_account = + Lib.TreeMap.from_List const $ + Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + [ ("A":|[], Amount.from_List [ Amount.usd $ 1, Amount.eur $ 2, Amount.gbp $ 3 ]) + , ("B":|[], Amount.from_List [ Amount.usd $ -1, Amount.eur $ -2, Amount.gbp $ -3 ]) + ] + , Balance.balance_by_unit = + Data.Map.fromList $ + Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + [ Balance.Unit_Sum + { Balance.unit_sum_amount = Balance.Amount_Sum + { Balance.amount_sum_negative = Just $ Amount.usd $ -1 + , Balance.amount_sum_positive = Just $ Amount.usd $ 1 + , Balance.amount_sum_balance = Amount.usd $ 0 + } + , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) + ["A":|[], "B":|[]] + } + , Balance.Unit_Sum + { Balance.unit_sum_amount = Balance.Amount_Sum + { Balance.amount_sum_negative = Just $ Amount.eur $ -2 + , Balance.amount_sum_positive = Just $ Amount.eur $ 2 + , Balance.amount_sum_balance = Amount.eur $ 0 + } + , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) + ["A":|[], "B":|[]] + } + , Balance.Unit_Sum + { Balance.unit_sum_amount = Balance.Amount_Sum + { Balance.amount_sum_negative = Just $ Amount.gbp $ -3 + , Balance.amount_sum_positive = Just $ Amount.gbp $ 3 + , Balance.amount_sum_balance = Amount.gbp $ 0 + } + , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) + ["A":|[], "B":|[]] + } + ] + } + ] + , "union" ~: TestList + [ "nil nil = nil" ~: + Balance.union Balance.nil Balance.nil + ~?= + (Balance.nil::Balance.Balance Amount) + , "{A+$1, $+1} {A+$1, $+1} = {A+$2, $+2}" ~: + Balance.union + (Balance.Balance + { Balance.balance_by_account = Lib.TreeMap.from_List const $ - [ ("A":|[] - , Data.Map.fromListWith const $ - Data.List.map (\s -> (Amount.unit $ Calc.Balance.amount_sum_balance s, s)) - [ Calc.Balance.Amount_Sum - { Calc.Balance.amount_sum_negative = Just $ Amount.usd $ -1 - , Calc.Balance.amount_sum_positive = Just $ Amount.usd $ 1 - , Calc.Balance.amount_sum_balance = Amount.usd $ 0 - } - , Calc.Balance.Amount_Sum - { Calc.Balance.amount_sum_negative = Just $ Amount.eur $ -2 - , Calc.Balance.amount_sum_positive = Just $ Amount.eur $ 2 - , Calc.Balance.amount_sum_balance = Amount.eur $ 0 - } - ] - ) - ] - , Calc.Balance.balance_by_unit = + Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) ] + , Balance.balance_by_unit = Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Calc.Balance.amount_sum_balance $ Calc.Balance.unit_sum_amount s, s)) - [ Calc.Balance.Unit_Sum - { Calc.Balance.unit_sum_amount = Calc.Balance.Amount_Sum - { Calc.Balance.amount_sum_negative = Just $ Amount.usd $ -1 - , Calc.Balance.amount_sum_positive = Just $ Amount.usd $ 1 - , Calc.Balance.amount_sum_balance = Amount.usd $ 0 - } - , Calc.Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) - ["A":|[]] - } - , Calc.Balance.Unit_Sum - { Calc.Balance.unit_sum_amount = Calc.Balance.Amount_Sum - { Calc.Balance.amount_sum_negative = Just $ Amount.eur $ -2 - , Calc.Balance.amount_sum_positive = Just $ Amount.eur $ 2 - , Calc.Balance.amount_sum_balance = Amount.eur $ 0 - } - , Calc.Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) + Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + [ Balance.Unit_Sum + { Balance.unit_sum_amount = Balance.amount_sum $ Amount.usd $ 1 + , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["A":|[]] } ] - } - , "[A+$1+€2+£3, B-$1-2€-£3] = {A+$1+€2+£3 B-$1-€2-£3, $+0 €+0 £+0}" ~: - (Data.List.foldl - (flip Calc.Balance.balance) - Calc.Balance.nil - [ (Format.Ledger.posting ("A":|[])) - { Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ 1, Amount.eur $ 2, Amount.gbp $ 3 ] - } - , (Format.Ledger.posting ("B":|[])) - { Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ -1, Amount.eur $ -2, Amount.gbp $ -3 ] - } - ]) - ~?= - Calc.Balance.Balance - { Calc.Balance.balance_by_account = + }) + (Balance.Balance + { Balance.balance_by_account = Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Calc.Balance.amount_sum) $ - [ ("A":|[], Amount.from_List [ Amount.usd $ 1, Amount.eur $ 2, Amount.gbp $ 3 ]) - , ("B":|[], Amount.from_List [ Amount.usd $ -1, Amount.eur $ -2, Amount.gbp $ -3 ]) - ] - , Calc.Balance.balance_by_unit = + Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) ] + , Balance.balance_by_unit = Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Calc.Balance.amount_sum_balance $ Calc.Balance.unit_sum_amount s, s)) - [ Calc.Balance.Unit_Sum - { Calc.Balance.unit_sum_amount = Calc.Balance.Amount_Sum - { Calc.Balance.amount_sum_negative = Just $ Amount.usd $ -1 - , Calc.Balance.amount_sum_positive = Just $ Amount.usd $ 1 - , Calc.Balance.amount_sum_balance = Amount.usd $ 0 - } - , Calc.Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) - ["A":|[], "B":|[]] - } - , Calc.Balance.Unit_Sum - { Calc.Balance.unit_sum_amount = Calc.Balance.Amount_Sum - { Calc.Balance.amount_sum_negative = Just $ Amount.eur $ -2 - , Calc.Balance.amount_sum_positive = Just $ Amount.eur $ 2 - , Calc.Balance.amount_sum_balance = Amount.eur $ 0 - } - , Calc.Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) - ["A":|[], "B":|[]] - } - , Calc.Balance.Unit_Sum - { Calc.Balance.unit_sum_amount = Calc.Balance.Amount_Sum - { Calc.Balance.amount_sum_negative = Just $ Amount.gbp $ -3 - , Calc.Balance.amount_sum_positive = Just $ Amount.gbp $ 3 - , Calc.Balance.amount_sum_balance = Amount.gbp $ 0 - } - , Calc.Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) - ["A":|[], "B":|[]] + Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + [ Balance.Unit_Sum + { Balance.unit_sum_amount = Balance.amount_sum $ Amount.usd $ 1 + , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) + ["A":|[]] } ] + }) + ~?= + Balance.Balance + { Balance.balance_by_account = + Lib.TreeMap.from_List const $ + Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + [ ("A":|[], Amount.from_List [ Amount.usd $ 2 ]) ] + , Balance.balance_by_unit = + Data.Map.fromList $ + Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + [ Balance.Unit_Sum + { Balance.unit_sum_amount = Balance.amount_sum $ Amount.usd $ 2 + , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) + ["A":|[]] } - ] - , "union" ~: TestList - [ "nil nil = nil" ~: - Calc.Balance.union Calc.Balance.nil Calc.Balance.nil - ~?= - (Calc.Balance.nil::Calc.Balance.Balance Amount) - , "{A+$1, $+1} {A+$1, $+1} = {A+$2, $+2}" ~: - Calc.Balance.union - (Calc.Balance.Balance - { Calc.Balance.balance_by_account = - Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Calc.Balance.amount_sum) $ - [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) ] - , Calc.Balance.balance_by_unit = - Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Calc.Balance.amount_sum_balance $ Calc.Balance.unit_sum_amount s, s)) - [ Calc.Balance.Unit_Sum - { Calc.Balance.unit_sum_amount = Calc.Balance.amount_sum $ Amount.usd $ 1 - , Calc.Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) - ["A":|[]] - } - ] - }) - (Calc.Balance.Balance - { Calc.Balance.balance_by_account = - Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Calc.Balance.amount_sum) $ - [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) ] - , Calc.Balance.balance_by_unit = - Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Calc.Balance.amount_sum_balance $ Calc.Balance.unit_sum_amount s, s)) - [ Calc.Balance.Unit_Sum - { Calc.Balance.unit_sum_amount = Calc.Balance.amount_sum $ Amount.usd $ 1 - , Calc.Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) - ["A":|[]] - } - ] - }) - ~?= - Calc.Balance.Balance - { Calc.Balance.balance_by_account = + ] + } + , "{A+$1, $+1} {B+$1, $+1} = {A+$1 B+$1, $+2}" ~: + Balance.union + (Balance.Balance + { Balance.balance_by_account = Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Calc.Balance.amount_sum) $ - [ ("A":|[], Amount.from_List [ Amount.usd $ 2 ]) ] - , Calc.Balance.balance_by_unit = + Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) ] + , Balance.balance_by_unit = Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Calc.Balance.amount_sum_balance $ Calc.Balance.unit_sum_amount s, s)) - [ Calc.Balance.Unit_Sum - { Calc.Balance.unit_sum_amount = Calc.Balance.amount_sum $ Amount.usd $ 2 - , Calc.Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) + Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + [ Balance.Unit_Sum + { Balance.unit_sum_amount = Balance.amount_sum $ Amount.usd $ 1 + , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["A":|[]] } ] - } - , "{A+$1, $+1} {B+$1, $+1} = {A+$1 B+$1, $+2}" ~: - Calc.Balance.union - (Calc.Balance.Balance - { Calc.Balance.balance_by_account = - Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Calc.Balance.amount_sum) $ - [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) ] - , Calc.Balance.balance_by_unit = - Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Calc.Balance.amount_sum_balance $ Calc.Balance.unit_sum_amount s, s)) - [ Calc.Balance.Unit_Sum - { Calc.Balance.unit_sum_amount = Calc.Balance.amount_sum $ Amount.usd $ 1 - , Calc.Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) - ["A":|[]] - } - ] - }) - (Calc.Balance.Balance - { Calc.Balance.balance_by_account = - Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Calc.Balance.amount_sum) $ - [ ("B":|[], Amount.from_List [ Amount.usd $ 1 ]) ] - , Calc.Balance.balance_by_unit = - Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Calc.Balance.amount_sum_balance $ Calc.Balance.unit_sum_amount s, s)) - [ Calc.Balance.Unit_Sum - { Calc.Balance.unit_sum_amount = Calc.Balance.amount_sum $ Amount.usd $ 1 - , Calc.Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) - ["B":|[]] - } - ] - }) - ~?= - Calc.Balance.Balance - { Calc.Balance.balance_by_account = + }) + (Balance.Balance + { Balance.balance_by_account = Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Calc.Balance.amount_sum) $ - [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) - , ("B":|[], Amount.from_List [ Amount.usd $ 1 ]) ] - , Calc.Balance.balance_by_unit = + Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + [ ("B":|[], Amount.from_List [ Amount.usd $ 1 ]) ] + , Balance.balance_by_unit = Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Calc.Balance.amount_sum_balance $ Calc.Balance.unit_sum_amount s, s)) - [ Calc.Balance.Unit_Sum - { Calc.Balance.unit_sum_amount = Calc.Balance.amount_sum $ Amount.usd $ 2 - , Calc.Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) - ["A":|[], "B":|[]] + Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + [ Balance.Unit_Sum + { Balance.unit_sum_amount = Balance.amount_sum $ Amount.usd $ 1 + , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) + ["B":|[]] } ] + }) + ~?= + Balance.Balance + { Balance.balance_by_account = + Lib.TreeMap.from_List const $ + Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) + , ("B":|[], Amount.from_List [ Amount.usd $ 1 ]) ] + , Balance.balance_by_unit = + Data.Map.fromList $ + Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + [ Balance.Unit_Sum + { Balance.unit_sum_amount = Balance.amount_sum $ Amount.usd $ 2 + , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) + ["A":|[], "B":|[]] } - , "{A+$1, $+1} {B+€1, €+1} = {A+$1 B+€1, $+1 €+1}" ~: - Calc.Balance.union - (Calc.Balance.Balance - { Calc.Balance.balance_by_account = - Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Calc.Balance.amount_sum) $ - [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) ] - , Calc.Balance.balance_by_unit = - Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Calc.Balance.amount_sum_balance $ Calc.Balance.unit_sum_amount s, s)) - [ Calc.Balance.Unit_Sum - { Calc.Balance.unit_sum_amount = Calc.Balance.amount_sum $ Amount.usd $ 1 - , Calc.Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) - ["A":|[]] - } - ] - }) - (Calc.Balance.Balance - { Calc.Balance.balance_by_account = - Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Calc.Balance.amount_sum) $ - [ ("B":|[], Amount.from_List [ Amount.eur $ 1 ]) ] - , Calc.Balance.balance_by_unit = - Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Calc.Balance.amount_sum_balance $ Calc.Balance.unit_sum_amount s, s)) - [ Calc.Balance.Unit_Sum - { Calc.Balance.unit_sum_amount = Calc.Balance.amount_sum $ Amount.eur $ 1 - , Calc.Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) - ["B":|[]] - } - ] - }) - ~?= - Calc.Balance.Balance - { Calc.Balance.balance_by_account = + ] + } + , "{A+$1, $+1} {B+€1, €+1} = {A+$1 B+€1, $+1 €+1}" ~: + Balance.union + (Balance.Balance + { Balance.balance_by_account = Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Calc.Balance.amount_sum) $ - [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) - , ("B":|[], Amount.from_List [ Amount.eur $ 1 ]) ] - , Calc.Balance.balance_by_unit = + Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) ] + , Balance.balance_by_unit = Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Calc.Balance.amount_sum_balance $ Calc.Balance.unit_sum_amount s, s)) - [ Calc.Balance.Unit_Sum - { Calc.Balance.unit_sum_amount = Calc.Balance.amount_sum $ Amount.usd $ 1 - , Calc.Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) + Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + [ Balance.Unit_Sum + { Balance.unit_sum_amount = Balance.amount_sum $ Amount.usd $ 1 + , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["A":|[]] } - , Calc.Balance.Unit_Sum - { Calc.Balance.unit_sum_amount = Calc.Balance.amount_sum $ Amount.eur $ 1 - , Calc.Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) - ["B":|[]] - } ] - } - ] - , "expanded" ~: TestList - [ "nil_By_Account" ~: - Calc.Balance.expanded - Lib.TreeMap.empty - ~?= - (Lib.TreeMap.empty::Calc.Balance.Expanded Amount) - , "A+$1 = A+$1" ~: - Calc.Balance.expanded - (Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Calc.Balance.amount_sum) $ - [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) ]) - ~?= - (Lib.TreeMap.from_List const $ - [ ("A":|[], Calc.Balance.Account_Sum_Expanded - { Calc.Balance.inclusive = - Data.Map.map Calc.Balance.amount_sum $ - Amount.from_List [ Amount.usd $ 1 ] - , Calc.Balance.exclusive = - Data.Map.map Calc.Balance.amount_sum $ - Amount.from_List [ Amount.usd $ 1 ] - }) - ]) - , "A/A+$1 = A+$1 A/A+$1" ~: - Calc.Balance.expanded - (Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Calc.Balance.amount_sum) $ - [ ("A":|["A"], Amount.from_List [ Amount.usd $ 1 ]) ]) - ~?= - (Lib.TreeMap.from_List const - [ ("A":|[], Calc.Balance.Account_Sum_Expanded - { Calc.Balance.inclusive = - Data.Map.map Calc.Balance.amount_sum $ - Amount.from_List [ Amount.usd $ 1 ] - , Calc.Balance.exclusive = - Data.Map.map Calc.Balance.amount_sum $ - Amount.from_List [] - }) - , ("A":|["A"], Calc.Balance.Account_Sum_Expanded - { Calc.Balance.inclusive = - Data.Map.map Calc.Balance.amount_sum $ - Amount.from_List [ Amount.usd $ 1 ] - , Calc.Balance.exclusive = - Data.Map.map Calc.Balance.amount_sum $ - Amount.from_List [ Amount.usd $ 1 ] - }) - ]) - , "A/B+$1 = A+$1 A/B+$1" ~: - Calc.Balance.expanded - (Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Calc.Balance.amount_sum) $ - [ ("A":|["B"], Amount.from_List [ Amount.usd $ 1 ]) ]) - ~?= - (Lib.TreeMap.from_List const - [ ("A":|[], Calc.Balance.Account_Sum_Expanded - { Calc.Balance.inclusive = - Data.Map.map Calc.Balance.amount_sum $ - Amount.from_List [ Amount.usd $ 1 ] - , Calc.Balance.exclusive = - Data.Map.map Calc.Balance.amount_sum $ - Amount.from_List [] - }) - , ("A":|["B"], Calc.Balance.Account_Sum_Expanded - { Calc.Balance.inclusive = - Data.Map.map Calc.Balance.amount_sum $ - Amount.from_List [ Amount.usd $ 1 ] - , Calc.Balance.exclusive = - Data.Map.map Calc.Balance.amount_sum $ - Amount.from_List [ Amount.usd $ 1 ] - }) - ]) - , "A/B/C+$1 = A+$1 A/B+$1 A/B/C+$1" ~: - Calc.Balance.expanded - (Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Calc.Balance.amount_sum) $ - [ ("A":|["B", "C"], Amount.from_List [ Amount.usd $ 1 ]) ]) - ~?= - (Lib.TreeMap.from_List const $ - [ ("A":|[], Calc.Balance.Account_Sum_Expanded - { Calc.Balance.inclusive = - Data.Map.map Calc.Balance.amount_sum $ - Amount.from_List [ Amount.usd $ 1 ] - , Calc.Balance.exclusive = - Data.Map.map Calc.Balance.amount_sum $ - Amount.from_List [] - }) - , ("A":|["B"], Calc.Balance.Account_Sum_Expanded - { Calc.Balance.inclusive = - Data.Map.map Calc.Balance.amount_sum $ - Amount.from_List [ Amount.usd $ 1 ] - , Calc.Balance.exclusive = - Data.Map.map Calc.Balance.amount_sum $ - Amount.from_List [] - }) - , ("A":|["B", "C"], Calc.Balance.Account_Sum_Expanded - { Calc.Balance.inclusive = - Data.Map.map Calc.Balance.amount_sum $ - Amount.from_List [ Amount.usd $ 1 ] - , Calc.Balance.exclusive = - Data.Map.map Calc.Balance.amount_sum $ - Amount.from_List [ Amount.usd $ 1 ] - }) - ]) - , "A+$1 A/B+$1 = A+$2 A/B+$1" ~: - Calc.Balance.expanded - (Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Calc.Balance.amount_sum) $ - [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) - , ("A":|["B"], Amount.from_List [ Amount.usd $ 1 ]) - ]) - ~?= - (Lib.TreeMap.from_List const - [ ("A":|[], Calc.Balance.Account_Sum_Expanded - { Calc.Balance.inclusive = - Data.Map.map Calc.Balance.amount_sum $ - Amount.from_List [ Amount.usd $ 2 ] - , Calc.Balance.exclusive = - Data.Map.map Calc.Balance.amount_sum $ - Amount.from_List [ Amount.usd $ 1 ] - }) - , ("A":|["B"], Calc.Balance.Account_Sum_Expanded - { Calc.Balance.inclusive = - Data.Map.map Calc.Balance.amount_sum $ - Amount.from_List [ Amount.usd $ 1 ] - , Calc.Balance.exclusive = - Data.Map.map Calc.Balance.amount_sum $ - Amount.from_List [ Amount.usd $ 1 ] - }) - ]) - , "A+$1 A/B+$1 A/B/C+$1 = A+$3 A/B+$2 A/B/C+$1" ~: - Calc.Balance.expanded - (Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Calc.Balance.amount_sum) $ - [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) - , ("A":|["B"], Amount.from_List [ Amount.usd $ 1 ]) - , ("A":|["B", "C"], Amount.from_List [ Amount.usd $ 1 ]) - ]) - ~?= - (Lib.TreeMap.from_List const - [ ("A":|[], Calc.Balance.Account_Sum_Expanded - { Calc.Balance.inclusive = - Data.Map.map Calc.Balance.amount_sum $ - Amount.from_List [ Amount.usd $ 3 ] - , Calc.Balance.exclusive = - Data.Map.map Calc.Balance.amount_sum $ - Amount.from_List [ Amount.usd $ 1 ] - }) - , ("A":|["B"], Calc.Balance.Account_Sum_Expanded - { Calc.Balance.inclusive = - Data.Map.map Calc.Balance.amount_sum $ - Amount.from_List [ Amount.usd $ 2 ] - , Calc.Balance.exclusive = - Data.Map.map Calc.Balance.amount_sum $ - Amount.from_List [ Amount.usd $ 1 ] - }) - , ("A":|["B", "C"], Calc.Balance.Account_Sum_Expanded - { Calc.Balance.inclusive = - Data.Map.map Calc.Balance.amount_sum $ - Amount.from_List [ Amount.usd $ 1 ] - , Calc.Balance.exclusive = - Data.Map.map Calc.Balance.amount_sum $ - Amount.from_List [ Amount.usd $ 1 ] - }) - ]) - , "A+$1 A/B+$1 A/B/C+$1 A/B/C/D+$1 = A+$4 A/B+$3 A/B/C+$2 A/B/C/D+$1" ~: - Calc.Balance.expanded - (Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Calc.Balance.amount_sum) $ - [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) - , ("A":|["B"], Amount.from_List [ Amount.usd $ 1 ]) - , ("A":|["B", "C"], Amount.from_List [ Amount.usd $ 1 ]) - , ("A":|["B", "C", "D"], Amount.from_List [ Amount.usd $ 1 ]) - ]) - ~?= - (Lib.TreeMap.from_List const - [ ("A":|[], Calc.Balance.Account_Sum_Expanded - { Calc.Balance.inclusive = - Data.Map.map Calc.Balance.amount_sum $ - Amount.from_List [ Amount.usd $ 4 ] - , Calc.Balance.exclusive = - Data.Map.map Calc.Balance.amount_sum $ - Amount.from_List [ Amount.usd $ 1 ] - }) - , ("A":|["B"], Calc.Balance.Account_Sum_Expanded - { Calc.Balance.inclusive = - Data.Map.map Calc.Balance.amount_sum $ - Amount.from_List [ Amount.usd $ 3 ] - , Calc.Balance.exclusive = - Data.Map.map Calc.Balance.amount_sum $ - Amount.from_List [ Amount.usd $ 1 ] - }) - , ("A":|["B", "C"], Calc.Balance.Account_Sum_Expanded - { Calc.Balance.inclusive = - Data.Map.map Calc.Balance.amount_sum $ - Amount.from_List [ Amount.usd $ 2 ] - , Calc.Balance.exclusive = - Data.Map.map Calc.Balance.amount_sum $ - Amount.from_List [ Amount.usd $ 1 ] - }) - , ("A":|["B", "C", "D"], Calc.Balance.Account_Sum_Expanded - { Calc.Balance.inclusive = - Data.Map.map Calc.Balance.amount_sum $ - Amount.from_List [ Amount.usd $ 1 ] - , Calc.Balance.exclusive = - Data.Map.map Calc.Balance.amount_sum $ - Amount.from_List [ Amount.usd $ 1 ] - }) - ]) - , "A+$1 A/B+$1 A/BB+$1 AA/B+$1 = A+$3 A/B+$1 A/BB+$1 AA+$1 AA/B+$1" ~: - Calc.Balance.expanded - (Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Calc.Balance.amount_sum) $ - [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) - , ("A":|["B"], Amount.from_List [ Amount.usd $ 1 ]) - , ("A":|["BB"], Amount.from_List [ Amount.usd $ 1 ]) - , ("AA":|["B"], Amount.from_List [ Amount.usd $ 1 ]) - ]) - ~?= - (Lib.TreeMap.from_List const - [ ("A":|[], Calc.Balance.Account_Sum_Expanded - { Calc.Balance.inclusive = - Data.Map.map Calc.Balance.amount_sum $ - Amount.from_List [ Amount.usd $ 3 ] - , Calc.Balance.exclusive = - Data.Map.map Calc.Balance.amount_sum $ - Amount.from_List [ Amount.usd $ 1 ] - }) - , ("A":|["B"], Calc.Balance.Account_Sum_Expanded - { Calc.Balance.inclusive = - Data.Map.map Calc.Balance.amount_sum $ - Amount.from_List [ Amount.usd $ 1 ] - , Calc.Balance.exclusive = - Data.Map.map Calc.Balance.amount_sum $ - Amount.from_List [ Amount.usd $ 1 ] - }) - , ("A":|["BB"], Calc.Balance.Account_Sum_Expanded - { Calc.Balance.inclusive = - Data.Map.map Calc.Balance.amount_sum $ - Amount.from_List [ Amount.usd $ 1 ] - , Calc.Balance.exclusive = - Data.Map.map Calc.Balance.amount_sum $ - Amount.from_List [ Amount.usd $ 1 ] - }) - , ("AA":|[], Calc.Balance.Account_Sum_Expanded - { Calc.Balance.inclusive = - Data.Map.map Calc.Balance.amount_sum $ - Amount.from_List [ Amount.usd $ 1 ] - , Calc.Balance.exclusive = - Data.Map.map Calc.Balance.amount_sum $ - Amount.from_List [] - }) - , ("AA":|["B"], Calc.Balance.Account_Sum_Expanded - { Calc.Balance.inclusive = - Data.Map.map Calc.Balance.amount_sum $ - Amount.from_List [ Amount.usd $ 1 ] - , Calc.Balance.exclusive = - Data.Map.map Calc.Balance.amount_sum $ - Amount.from_List [ Amount.usd $ 1 ] - }) - ]) - ] - , "deviation" ~: TestList - [ "{A+$1, $1}" ~: - (Calc.Balance.deviation $ - Calc.Balance.Balance - { Calc.Balance.balance_by_account = + }) + (Balance.Balance + { Balance.balance_by_account = Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Calc.Balance.amount_sum) $ - [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) - , ("B":|[], Amount.from_List []) - ] - , Calc.Balance.balance_by_unit = + Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + [ ("B":|[], Amount.from_List [ Amount.eur $ 1 ]) ] + , Balance.balance_by_unit = Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Calc.Balance.amount_sum_balance $ Calc.Balance.unit_sum_amount s, s)) - [ Calc.Balance.Unit_Sum - { Calc.Balance.unit_sum_amount = Calc.Balance.amount_sum $ Amount.usd $ 1 - , Calc.Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) - ["A":|[]] + Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + [ Balance.Unit_Sum + { Balance.unit_sum_amount = Balance.amount_sum $ Amount.eur $ 1 + , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) + ["B":|[]] } ] }) - ~?= - (Calc.Balance.Deviation $ + ~?= + Balance.Balance + { Balance.balance_by_account = + Lib.TreeMap.from_List const $ + Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) + , ("B":|[], Amount.from_List [ Amount.eur $ 1 ]) ] + , Balance.balance_by_unit = Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Calc.Balance.amount_sum_balance $ Calc.Balance.unit_sum_amount s, s)) - [ Calc.Balance.Unit_Sum - { Calc.Balance.unit_sum_amount = Calc.Balance.amount_sum $ Amount.usd $ 1 - , Calc.Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) + Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + [ Balance.Unit_Sum + { Balance.unit_sum_amount = Balance.amount_sum $ Amount.usd $ 1 + , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) + ["A":|[]] + } + , Balance.Unit_Sum + { Balance.unit_sum_amount = Balance.amount_sum $ Amount.eur $ 1 + , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["B":|[]] } - ]) - , "{A+$1 B+$1, $2}" ~: - (Calc.Balance.deviation $ - Calc.Balance.Balance - { Calc.Balance.balance_by_account = - Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Calc.Balance.amount_sum) $ - [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) - , ("B":|[], Amount.from_List [ Amount.usd $ 1 ]) - ] - , Calc.Balance.balance_by_unit = - Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Calc.Balance.amount_sum_balance $ Calc.Balance.unit_sum_amount s, s)) - [ Calc.Balance.Unit_Sum - { Calc.Balance.unit_sum_amount = Calc.Balance.amount_sum $ Amount.usd $ 2 - , Calc.Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) - [ "A":|[] - , "B":|[] - ] - } - ] + ] + } + ] + , "expanded" ~: TestList + [ "nil_By_Account" ~: + Balance.expanded + Lib.TreeMap.empty + ~?= + (Lib.TreeMap.empty::Balance.Expanded Amount) + , "A+$1 = A+$1" ~: + Balance.expanded + (Lib.TreeMap.from_List const $ + Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) ]) + ~?= + (Lib.TreeMap.from_List const $ + [ ("A":|[], Balance.Account_Sum_Expanded + { Balance.inclusive = + Data.Map.map Balance.amount_sum $ + Amount.from_List [ Amount.usd $ 1 ] + , Balance.exclusive = + Data.Map.map Balance.amount_sum $ + Amount.from_List [ Amount.usd $ 1 ] + }) + ]) + , "A/A+$1 = A+$1 A/A+$1" ~: + Balance.expanded + (Lib.TreeMap.from_List const $ + Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + [ ("A":|["A"], Amount.from_List [ Amount.usd $ 1 ]) ]) + ~?= + (Lib.TreeMap.from_List const + [ ("A":|[], Balance.Account_Sum_Expanded + { Balance.inclusive = + Data.Map.map Balance.amount_sum $ + Amount.from_List [ Amount.usd $ 1 ] + , Balance.exclusive = + Data.Map.map Balance.amount_sum $ + Amount.from_List [] + }) + , ("A":|["A"], Balance.Account_Sum_Expanded + { Balance.inclusive = + Data.Map.map Balance.amount_sum $ + Amount.from_List [ Amount.usd $ 1 ] + , Balance.exclusive = + Data.Map.map Balance.amount_sum $ + Amount.from_List [ Amount.usd $ 1 ] + }) + ]) + , "A/B+$1 = A+$1 A/B+$1" ~: + Balance.expanded + (Lib.TreeMap.from_List const $ + Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + [ ("A":|["B"], Amount.from_List [ Amount.usd $ 1 ]) ]) + ~?= + (Lib.TreeMap.from_List const + [ ("A":|[], Balance.Account_Sum_Expanded + { Balance.inclusive = + Data.Map.map Balance.amount_sum $ + Amount.from_List [ Amount.usd $ 1 ] + , Balance.exclusive = + Data.Map.map Balance.amount_sum $ + Amount.from_List [] + }) + , ("A":|["B"], Balance.Account_Sum_Expanded + { Balance.inclusive = + Data.Map.map Balance.amount_sum $ + Amount.from_List [ Amount.usd $ 1 ] + , Balance.exclusive = + Data.Map.map Balance.amount_sum $ + Amount.from_List [ Amount.usd $ 1 ] + }) + ]) + , "A/B/C+$1 = A+$1 A/B+$1 A/B/C+$1" ~: + Balance.expanded + (Lib.TreeMap.from_List const $ + Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + [ ("A":|["B", "C"], Amount.from_List [ Amount.usd $ 1 ]) ]) + ~?= + (Lib.TreeMap.from_List const $ + [ ("A":|[], Balance.Account_Sum_Expanded + { Balance.inclusive = + Data.Map.map Balance.amount_sum $ + Amount.from_List [ Amount.usd $ 1 ] + , Balance.exclusive = + Data.Map.map Balance.amount_sum $ + Amount.from_List [] + }) + , ("A":|["B"], Balance.Account_Sum_Expanded + { Balance.inclusive = + Data.Map.map Balance.amount_sum $ + Amount.from_List [ Amount.usd $ 1 ] + , Balance.exclusive = + Data.Map.map Balance.amount_sum $ + Amount.from_List [] + }) + , ("A":|["B", "C"], Balance.Account_Sum_Expanded + { Balance.inclusive = + Data.Map.map Balance.amount_sum $ + Amount.from_List [ Amount.usd $ 1 ] + , Balance.exclusive = + Data.Map.map Balance.amount_sum $ + Amount.from_List [ Amount.usd $ 1 ] + }) + ]) + , "A+$1 A/B+$1 = A+$2 A/B+$1" ~: + Balance.expanded + (Lib.TreeMap.from_List const $ + Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) + , ("A":|["B"], Amount.from_List [ Amount.usd $ 1 ]) + ]) + ~?= + (Lib.TreeMap.from_List const + [ ("A":|[], Balance.Account_Sum_Expanded + { Balance.inclusive = + Data.Map.map Balance.amount_sum $ + Amount.from_List [ Amount.usd $ 2 ] + , Balance.exclusive = + Data.Map.map Balance.amount_sum $ + Amount.from_List [ Amount.usd $ 1 ] + }) + , ("A":|["B"], Balance.Account_Sum_Expanded + { Balance.inclusive = + Data.Map.map Balance.amount_sum $ + Amount.from_List [ Amount.usd $ 1 ] + , Balance.exclusive = + Data.Map.map Balance.amount_sum $ + Amount.from_List [ Amount.usd $ 1 ] + }) + ]) + , "A+$1 A/B+$1 A/B/C+$1 = A+$3 A/B+$2 A/B/C+$1" ~: + Balance.expanded + (Lib.TreeMap.from_List const $ + Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) + , ("A":|["B"], Amount.from_List [ Amount.usd $ 1 ]) + , ("A":|["B", "C"], Amount.from_List [ Amount.usd $ 1 ]) + ]) + ~?= + (Lib.TreeMap.from_List const + [ ("A":|[], Balance.Account_Sum_Expanded + { Balance.inclusive = + Data.Map.map Balance.amount_sum $ + Amount.from_List [ Amount.usd $ 3 ] + , Balance.exclusive = + Data.Map.map Balance.amount_sum $ + Amount.from_List [ Amount.usd $ 1 ] + }) + , ("A":|["B"], Balance.Account_Sum_Expanded + { Balance.inclusive = + Data.Map.map Balance.amount_sum $ + Amount.from_List [ Amount.usd $ 2 ] + , Balance.exclusive = + Data.Map.map Balance.amount_sum $ + Amount.from_List [ Amount.usd $ 1 ] + }) + , ("A":|["B", "C"], Balance.Account_Sum_Expanded + { Balance.inclusive = + Data.Map.map Balance.amount_sum $ + Amount.from_List [ Amount.usd $ 1 ] + , Balance.exclusive = + Data.Map.map Balance.amount_sum $ + Amount.from_List [ Amount.usd $ 1 ] + }) + ]) + , "A+$1 A/B+$1 A/B/C+$1 A/B/C/D+$1 = A+$4 A/B+$3 A/B/C+$2 A/B/C/D+$1" ~: + Balance.expanded + (Lib.TreeMap.from_List const $ + Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) + , ("A":|["B"], Amount.from_List [ Amount.usd $ 1 ]) + , ("A":|["B", "C"], Amount.from_List [ Amount.usd $ 1 ]) + , ("A":|["B", "C", "D"], Amount.from_List [ Amount.usd $ 1 ]) + ]) + ~?= + (Lib.TreeMap.from_List const + [ ("A":|[], Balance.Account_Sum_Expanded + { Balance.inclusive = + Data.Map.map Balance.amount_sum $ + Amount.from_List [ Amount.usd $ 4 ] + , Balance.exclusive = + Data.Map.map Balance.amount_sum $ + Amount.from_List [ Amount.usd $ 1 ] + }) + , ("A":|["B"], Balance.Account_Sum_Expanded + { Balance.inclusive = + Data.Map.map Balance.amount_sum $ + Amount.from_List [ Amount.usd $ 3 ] + , Balance.exclusive = + Data.Map.map Balance.amount_sum $ + Amount.from_List [ Amount.usd $ 1 ] + }) + , ("A":|["B", "C"], Balance.Account_Sum_Expanded + { Balance.inclusive = + Data.Map.map Balance.amount_sum $ + Amount.from_List [ Amount.usd $ 2 ] + , Balance.exclusive = + Data.Map.map Balance.amount_sum $ + Amount.from_List [ Amount.usd $ 1 ] + }) + , ("A":|["B", "C", "D"], Balance.Account_Sum_Expanded + { Balance.inclusive = + Data.Map.map Balance.amount_sum $ + Amount.from_List [ Amount.usd $ 1 ] + , Balance.exclusive = + Data.Map.map Balance.amount_sum $ + Amount.from_List [ Amount.usd $ 1 ] + }) + ]) + , "A+$1 A/B+$1 A/BB+$1 AA/B+$1 = A+$3 A/B+$1 A/BB+$1 AA+$1 AA/B+$1" ~: + Balance.expanded + (Lib.TreeMap.from_List const $ + Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) + , ("A":|["B"], Amount.from_List [ Amount.usd $ 1 ]) + , ("A":|["BB"], Amount.from_List [ Amount.usd $ 1 ]) + , ("AA":|["B"], Amount.from_List [ Amount.usd $ 1 ]) + ]) + ~?= + (Lib.TreeMap.from_List const + [ ("A":|[], Balance.Account_Sum_Expanded + { Balance.inclusive = + Data.Map.map Balance.amount_sum $ + Amount.from_List [ Amount.usd $ 3 ] + , Balance.exclusive = + Data.Map.map Balance.amount_sum $ + Amount.from_List [ Amount.usd $ 1 ] + }) + , ("A":|["B"], Balance.Account_Sum_Expanded + { Balance.inclusive = + Data.Map.map Balance.amount_sum $ + Amount.from_List [ Amount.usd $ 1 ] + , Balance.exclusive = + Data.Map.map Balance.amount_sum $ + Amount.from_List [ Amount.usd $ 1 ] + }) + , ("A":|["BB"], Balance.Account_Sum_Expanded + { Balance.inclusive = + Data.Map.map Balance.amount_sum $ + Amount.from_List [ Amount.usd $ 1 ] + , Balance.exclusive = + Data.Map.map Balance.amount_sum $ + Amount.from_List [ Amount.usd $ 1 ] + }) + , ("AA":|[], Balance.Account_Sum_Expanded + { Balance.inclusive = + Data.Map.map Balance.amount_sum $ + Amount.from_List [ Amount.usd $ 1 ] + , Balance.exclusive = + Data.Map.map Balance.amount_sum $ + Amount.from_List [] }) - ~?= - (Calc.Balance.Deviation $ + , ("AA":|["B"], Balance.Account_Sum_Expanded + { Balance.inclusive = + Data.Map.map Balance.amount_sum $ + Amount.from_List [ Amount.usd $ 1 ] + , Balance.exclusive = + Data.Map.map Balance.amount_sum $ + Amount.from_List [ Amount.usd $ 1 ] + }) + ]) + ] + , "deviation" ~: TestList + [ "{A+$1, $1}" ~: + (Balance.deviation $ + Balance.Balance + { Balance.balance_by_account = + Lib.TreeMap.from_List const $ + Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) + , ("B":|[], Amount.from_List []) + ] + , Balance.balance_by_unit = Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Calc.Balance.amount_sum_balance $ Calc.Balance.unit_sum_amount s, s)) - [ Calc.Balance.Unit_Sum - { Calc.Balance.unit_sum_amount = Calc.Balance.amount_sum $ Amount.usd $ 2 - , Calc.Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) - [ - ] + Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + [ Balance.Unit_Sum + { Balance.unit_sum_amount = Balance.amount_sum $ Amount.usd $ 1 + , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) + ["A":|[]] } - ]) - ] - , "is_equilibrium_inferrable" ~: TestList - [ "nil" ~: TestCase $ - (@=?) True $ - Calc.Balance.is_equilibrium_inferrable $ - Calc.Balance.deviation $ - (Calc.Balance.nil::Calc.Balance.Balance Amount.Amount) - , "{A+$0, $+0}" ~: TestCase $ - (@=?) True $ - Calc.Balance.is_equilibrium_inferrable $ - Calc.Balance.deviation $ - Calc.Balance.Balance - { Calc.Balance.balance_by_account = - Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Calc.Balance.amount_sum) $ - [ ("A":|[], Amount.from_List [ Amount.usd $ 0 ]) + ] + }) + ~?= + (Balance.Deviation $ + Data.Map.fromList $ + Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + [ Balance.Unit_Sum + { Balance.unit_sum_amount = Balance.amount_sum $ Amount.usd $ 1 + , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) + ["B":|[]] + } + ]) + , "{A+$1 B+$1, $2}" ~: + (Balance.deviation $ + Balance.Balance + { Balance.balance_by_account = + Lib.TreeMap.from_List const $ + Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) + , ("B":|[], Amount.from_List [ Amount.usd $ 1 ]) + ] + , Balance.balance_by_unit = + Data.Map.fromList $ + Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + [ Balance.Unit_Sum + { Balance.unit_sum_amount = Balance.amount_sum $ Amount.usd $ 2 + , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) + [ "A":|[] + , "B":|[] ] - , Calc.Balance.balance_by_unit = - Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Calc.Balance.amount_sum_balance $ Calc.Balance.unit_sum_amount s, s)) - [ Calc.Balance.Unit_Sum - { Calc.Balance.unit_sum_amount = Calc.Balance.amount_sum $ Amount.usd $ 0 - , Calc.Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) - ["A":|[]] - } - ] } - , "{A+$1, $+1}" ~: TestCase $ - (@=?) False $ - Calc.Balance.is_equilibrium_inferrable $ - Calc.Balance.deviation $ - Calc.Balance.Balance - { Calc.Balance.balance_by_account = - Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Calc.Balance.amount_sum) $ - [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) - ] - , Calc.Balance.balance_by_unit = - Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Calc.Balance.amount_sum_balance $ Calc.Balance.unit_sum_amount s, s)) - [ Calc.Balance.Unit_Sum - { Calc.Balance.unit_sum_amount = Calc.Balance.amount_sum $ Amount.usd $ 1 - , Calc.Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) - ["A":|[]] - } - ] + ] + }) + ~?= + (Balance.Deviation $ + Data.Map.fromList $ + Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + [ Balance.Unit_Sum + { Balance.unit_sum_amount = Balance.amount_sum $ Amount.usd $ 2 + , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) + [ + ] + } + ]) + ] + , "is_equilibrium_inferrable" ~: TestList + [ "nil" ~: TestCase $ + (@=?) True $ + Balance.is_equilibrium_inferrable $ + Balance.deviation $ + (Balance.nil::Balance.Balance Amount.Amount) + , "{A+$0, $+0}" ~: TestCase $ + (@=?) True $ + Balance.is_equilibrium_inferrable $ + Balance.deviation $ + Balance.Balance + { Balance.balance_by_account = + Lib.TreeMap.from_List const $ + Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + [ ("A":|[], Amount.from_List [ Amount.usd $ 0 ]) + ] + , Balance.balance_by_unit = + Data.Map.fromList $ + Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + [ Balance.Unit_Sum + { Balance.unit_sum_amount = Balance.amount_sum $ Amount.usd $ 0 + , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) + ["A":|[]] } - , "{A+$0+€0, $0 €+0}" ~: TestCase $ - (@=?) True $ - Calc.Balance.is_equilibrium_inferrable $ - Calc.Balance.deviation $ - Calc.Balance.Balance - { Calc.Balance.balance_by_account = - Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Calc.Balance.amount_sum) $ - [ ("A":|[], Amount.from_List [ Amount.usd $ 0, Amount.eur $ 0 ]) - ] - , Calc.Balance.balance_by_unit = - Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Calc.Balance.amount_sum_balance $ Calc.Balance.unit_sum_amount s, s)) - [ Calc.Balance.Unit_Sum - { Calc.Balance.unit_sum_amount = Calc.Balance.amount_sum $ Amount.usd $ 0 - , Calc.Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) - ["A":|[]] - } - , Calc.Balance.Unit_Sum - { Calc.Balance.unit_sum_amount = Calc.Balance.amount_sum $ Amount.eur $ 0 - , Calc.Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) - ["A":|[]] - } - ] + ] + } + , "{A+$1, $+1}" ~: TestCase $ + (@=?) False $ + Balance.is_equilibrium_inferrable $ + Balance.deviation $ + Balance.Balance + { Balance.balance_by_account = + Lib.TreeMap.from_List const $ + Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) + ] + , Balance.balance_by_unit = + Data.Map.fromList $ + Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + [ Balance.Unit_Sum + { Balance.unit_sum_amount = Balance.amount_sum $ Amount.usd $ 1 + , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) + ["A":|[]] } - , "{A+$1, B-$1, $+0}" ~: TestCase $ - (@=?) True $ - Calc.Balance.is_equilibrium_inferrable $ - Calc.Balance.deviation $ - Calc.Balance.Balance - { Calc.Balance.balance_by_account = - Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Calc.Balance.amount_sum) $ - [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) - , ("B":|[], Amount.from_List [ Amount.usd $ -1 ]) - ] - , Calc.Balance.balance_by_unit = - Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Calc.Balance.amount_sum_balance $ Calc.Balance.unit_sum_amount s, s)) - [ Calc.Balance.Unit_Sum - { Calc.Balance.unit_sum_amount = Calc.Balance.amount_sum $ Amount.usd $ 0 - , Calc.Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) - ["A":|[], "B":|[]] - } - ] + ] + } + , "{A+$0+€0, $0 €+0}" ~: TestCase $ + (@=?) True $ + Balance.is_equilibrium_inferrable $ + Balance.deviation $ + Balance.Balance + { Balance.balance_by_account = + Lib.TreeMap.from_List const $ + Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + [ ("A":|[], Amount.from_List [ Amount.usd $ 0, Amount.eur $ 0 ]) + ] + , Balance.balance_by_unit = + Data.Map.fromList $ + Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + [ Balance.Unit_Sum + { Balance.unit_sum_amount = Balance.amount_sum $ Amount.usd $ 0 + , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) + ["A":|[]] } - , "{A+$1 B, $+1}" ~: TestCase $ - (@=?) True $ - Calc.Balance.is_equilibrium_inferrable $ - Calc.Balance.deviation $ - Calc.Balance.Balance - { Calc.Balance.balance_by_account = - Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Calc.Balance.amount_sum) $ - [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) - , ("B":|[], Amount.from_List []) - ] - , Calc.Balance.balance_by_unit = - Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Calc.Balance.amount_sum_balance $ Calc.Balance.unit_sum_amount s, s)) - [ Calc.Balance.Unit_Sum - { Calc.Balance.unit_sum_amount = Calc.Balance.amount_sum $ Amount.usd $ 1 - , Calc.Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) - ["A":|[]] - } - ] - } - , "{A+$1 B+€1, $+1 €+1}" ~: TestCase $ - (@=?) True $ - Calc.Balance.is_equilibrium_inferrable $ - Calc.Balance.deviation $ - Calc.Balance.Balance - { Calc.Balance.balance_by_account = + , Balance.Unit_Sum + { Balance.unit_sum_amount = Balance.amount_sum $ Amount.eur $ 0 + , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) + ["A":|[]] + } + ] + } + , "{A+$1, B-$1, $+0}" ~: TestCase $ + (@=?) True $ + Balance.is_equilibrium_inferrable $ + Balance.deviation $ + Balance.Balance + { Balance.balance_by_account = + Lib.TreeMap.from_List const $ + Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) + , ("B":|[], Amount.from_List [ Amount.usd $ -1 ]) + ] + , Balance.balance_by_unit = + Data.Map.fromList $ + Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + [ Balance.Unit_Sum + { Balance.unit_sum_amount = Balance.amount_sum $ Amount.usd $ 0 + , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) + ["A":|[], "B":|[]] + } + ] + } + , "{A+$1 B, $+1}" ~: TestCase $ + (@=?) True $ + Balance.is_equilibrium_inferrable $ + Balance.deviation $ + Balance.Balance + { Balance.balance_by_account = Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Calc.Balance.amount_sum) $ + Data.List.map (id *** Data.Map.map Balance.amount_sum) $ [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) - , ("B":|[], Amount.from_List [ Amount.eur $ 1 ]) + , ("B":|[], Amount.from_List []) ] - , Calc.Balance.balance_by_unit = + , Balance.balance_by_unit = Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Calc.Balance.amount_sum_balance $ Calc.Balance.unit_sum_amount s, s)) - [ Calc.Balance.Unit_Sum - { Calc.Balance.unit_sum_amount = Calc.Balance.amount_sum $ Amount.usd $ 1 - , Calc.Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) + Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + [ Balance.Unit_Sum + { Balance.unit_sum_amount = Balance.amount_sum $ Amount.usd $ 1 + , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["A":|[]] } - , Calc.Balance.Unit_Sum - { Calc.Balance.unit_sum_amount = Calc.Balance.amount_sum $ Amount.eur $ 1 - , Calc.Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) - ["B":|[]] - } ] } - , "{A+$1 B-$1+€1, $+0 €+1}" ~: TestCase $ - (@=?) True $ - Calc.Balance.is_equilibrium_inferrable $ - Calc.Balance.deviation $ - Calc.Balance.Balance - { Calc.Balance.balance_by_account = - Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Calc.Balance.amount_sum) $ - [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) - , ("B":|[], Amount.from_List [ Amount.usd $ -1, Amount.eur $ 1 ]) - ] - , Calc.Balance.balance_by_unit = - Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Calc.Balance.amount_sum_balance $ Calc.Balance.unit_sum_amount s, s)) - [ Calc.Balance.Unit_Sum - { Calc.Balance.unit_sum_amount = Calc.Balance.amount_sum $ Amount.usd $ 0 - , Calc.Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) - ["A":|[], "B":|[]] - } - , Calc.Balance.Unit_Sum - { Calc.Balance.unit_sum_amount = Calc.Balance.amount_sum $ Amount.eur $ 1 - , Calc.Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) - ["B":|[]] - } - ] + , "{A+$1 B+€1, $+1 €+1}" ~: TestCase $ + (@=?) True $ + Balance.is_equilibrium_inferrable $ + Balance.deviation $ + Balance.Balance + { Balance.balance_by_account = + Lib.TreeMap.from_List const $ + Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) + , ("B":|[], Amount.from_List [ Amount.eur $ 1 ]) + ] + , Balance.balance_by_unit = + Data.Map.fromList $ + Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + [ Balance.Unit_Sum + { Balance.unit_sum_amount = Balance.amount_sum $ Amount.usd $ 1 + , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) + ["A":|[]] } - , "{A+$1+€2+£3 B-$1-€2-£3, $+0 €+0 £+0}" ~: TestCase $ - (@=?) True $ - Calc.Balance.is_equilibrium_inferrable $ - Calc.Balance.deviation $ - Calc.Balance.Balance - { Calc.Balance.balance_by_account = - Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Calc.Balance.amount_sum) $ - [ ("A":|[], Amount.from_List [ Amount.usd $ 1, Amount.eur $ 2, Amount.gbp $ 3 ]) - , ("B":|[], Amount.from_List [ Amount.usd $ -1, Amount.eur $ -2, Amount.gbp $ -3 ]) - ] - , Calc.Balance.balance_by_unit = - Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Calc.Balance.amount_sum_balance $ Calc.Balance.unit_sum_amount s, s)) - [ Calc.Balance.Unit_Sum - { Calc.Balance.unit_sum_amount = Calc.Balance.amount_sum $ Amount.usd $ 0 - , Calc.Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) - ["A":|[], "B":|[]] - } - , Calc.Balance.Unit_Sum - { Calc.Balance.unit_sum_amount = Calc.Balance.amount_sum $ Amount.eur $ 0 - , Calc.Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) - ["A":|[], "B":|[]] - } - , Calc.Balance.Unit_Sum - { Calc.Balance.unit_sum_amount = Calc.Balance.amount_sum $ Amount.gbp $ 0 - , Calc.Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) - ["A":|[], "B":|[]] - } - ] + , Balance.Unit_Sum + { Balance.unit_sum_amount = Balance.amount_sum $ Amount.eur $ 1 + , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) + ["B":|[]] } - ] - , "infer_equilibrium" ~: TestList - [ "{A+$1 B}" ~: - (snd $ Calc.Balance.infer_equilibrium $ - Format.Ledger.posting_by_Account - [ (Format.Ledger.posting ("A":|[])) - { Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ 1 ] } - , (Format.Ledger.posting ("B":|[])) - { Format.Ledger.posting_amounts=Amount.from_List [] } - ]) - ~?= - (Right $ - Format.Ledger.posting_by_Account - [ (Format.Ledger.posting ("A":|[])) - { Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ 1 ] } - , (Format.Ledger.posting ("B":|[])) - { Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ -1 ] } - ]) - , "{A+$1 B-1€}" ~: - (snd $ Calc.Balance.infer_equilibrium $ - Format.Ledger.posting_by_Account - [ (Format.Ledger.posting ("A":|[])) - { Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ 1 ] } - , (Format.Ledger.posting ("B":|[])) - { Format.Ledger.posting_amounts=Amount.from_List [ Amount.eur $ -1 ] } - ]) - ~?= - (Right $ - Format.Ledger.posting_by_Account - [ (Format.Ledger.posting ("A":|[])) - { Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ 1, Amount.eur $ 1] } - , (Format.Ledger.posting ("B":|[])) - { Format.Ledger.posting_amounts=Amount.from_List [ Amount.eur $ -1, Amount.usd $ -1 ] } - ]) - , "{A+$1 B+$1}" ~: - (snd $ Calc.Balance.infer_equilibrium $ - Format.Ledger.posting_by_Account - [ (Format.Ledger.posting ("A":|[])) - { Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ 1 ] } - , (Format.Ledger.posting ("B":|[])) - { Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ 1 ] } - ]) - ~?= - (Left - [ Calc.Balance.Unit_Sum - { Calc.Balance.unit_sum_amount = Calc.Balance.amount_sum $ Amount.usd $ 2 - , Calc.Balance.unit_sum_accounts = Data.Map.fromList []} - ]) - , "{A+$1 B-$1 B-1€}" ~: - (snd $ Calc.Balance.infer_equilibrium $ - Format.Ledger.posting_by_Account - [ (Format.Ledger.posting ("A":|[])) - { Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ 1 ] } - , (Format.Ledger.posting ("B":|[])) - { Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ -1, Amount.eur $ -1 ] } - ]) - ~?= - (Right $ - Format.Ledger.posting_by_Account - [ (Format.Ledger.posting ("A":|[])) - { Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ 1, Amount.eur $ 1 ] } - , (Format.Ledger.posting ("B":|[])) - { Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ -1, Amount.eur $ -1 ] } - ]) - ] + ] + } + , "{A+$1 B-$1+€1, $+0 €+1}" ~: TestCase $ + (@=?) True $ + Balance.is_equilibrium_inferrable $ + Balance.deviation $ + Balance.Balance + { Balance.balance_by_account = + Lib.TreeMap.from_List const $ + Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) + , ("B":|[], Amount.from_List [ Amount.usd $ -1, Amount.eur $ 1 ]) + ] + , Balance.balance_by_unit = + Data.Map.fromList $ + Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + [ Balance.Unit_Sum + { Balance.unit_sum_amount = Balance.amount_sum $ Amount.usd $ 0 + , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) + ["A":|[], "B":|[]] + } + , Balance.Unit_Sum + { Balance.unit_sum_amount = Balance.amount_sum $ Amount.eur $ 1 + , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) + ["B":|[]] + } + ] + } + , "{A+$1+€2+£3 B-$1-€2-£3, $+0 €+0 £+0}" ~: TestCase $ + (@=?) True $ + Balance.is_equilibrium_inferrable $ + Balance.deviation $ + Balance.Balance + { Balance.balance_by_account = + Lib.TreeMap.from_List const $ + Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + [ ("A":|[], Amount.from_List [ Amount.usd $ 1, Amount.eur $ 2, Amount.gbp $ 3 ]) + , ("B":|[], Amount.from_List [ Amount.usd $ -1, Amount.eur $ -2, Amount.gbp $ -3 ]) + ] + , Balance.balance_by_unit = + Data.Map.fromList $ + Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + [ Balance.Unit_Sum + { Balance.unit_sum_amount = Balance.amount_sum $ Amount.usd $ 0 + , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) + ["A":|[], "B":|[]] + } + , Balance.Unit_Sum + { Balance.unit_sum_amount = Balance.amount_sum $ Amount.eur $ 0 + , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) + ["A":|[], "B":|[]] + } + , Balance.Unit_Sum + { Balance.unit_sum_amount = Balance.amount_sum $ Amount.gbp $ 0 + , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) + ["A":|[], "B":|[]] + } + ] + } + ] + , "infer_equilibrium" ~: TestList + [ "{A+$1 B}" ~: + (snd $ Balance.infer_equilibrium $ + Format.Ledger.posting_by_Account + [ (Format.Ledger.posting ("A":|[])) + { Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ 1 ] } + , (Format.Ledger.posting ("B":|[])) + { Format.Ledger.posting_amounts=Amount.from_List [] } + ]) + ~?= + (Right $ + Format.Ledger.posting_by_Account + [ (Format.Ledger.posting ("A":|[])) + { Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ 1 ] } + , (Format.Ledger.posting ("B":|[])) + { Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ -1 ] } + ]) + , "{A+$1 B-1€}" ~: + (snd $ Balance.infer_equilibrium $ + Format.Ledger.posting_by_Account + [ (Format.Ledger.posting ("A":|[])) + { Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ 1 ] } + , (Format.Ledger.posting ("B":|[])) + { Format.Ledger.posting_amounts=Amount.from_List [ Amount.eur $ -1 ] } + ]) + ~?= + (Right $ + Format.Ledger.posting_by_Account + [ (Format.Ledger.posting ("A":|[])) + { Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ 1, Amount.eur $ 1] } + , (Format.Ledger.posting ("B":|[])) + { Format.Ledger.posting_amounts=Amount.from_List [ Amount.eur $ -1, Amount.usd $ -1 ] } + ]) + , "{A+$1 B+$1}" ~: + (snd $ Balance.infer_equilibrium $ + Format.Ledger.posting_by_Account + [ (Format.Ledger.posting ("A":|[])) + { Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ 1 ] } + , (Format.Ledger.posting ("B":|[])) + { Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ 1 ] } + ]) + ~?= + (Left + [ Balance.Unit_Sum + { Balance.unit_sum_amount = Balance.amount_sum $ Amount.usd $ 2 + , Balance.unit_sum_accounts = Data.Map.fromList []} + ]) + , "{A+$1 B-$1 B-1€}" ~: + (snd $ Balance.infer_equilibrium $ + Format.Ledger.posting_by_Account + [ (Format.Ledger.posting ("A":|[])) + { Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ 1 ] } + , (Format.Ledger.posting ("B":|[])) + { Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ -1, Amount.eur $ -1 ] } + ]) + ~?= + (Right $ + Format.Ledger.posting_by_Account + [ (Format.Ledger.posting ("A":|[])) + { Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ 1, Amount.eur $ 1 ] } + , (Format.Ledger.posting ("B":|[])) + { Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ -1, Amount.eur $ -1 ] } + ]) ] ] , "Format" ~: TestList @@ -1862,578 +2542,6 @@ test_Hcompta = ~?= (Format.Ledger.Posting_Type_Regular, "A":|["B", "[C]"]) ] - , "amount" ~: TestList - [ "\"\" = Left" ~: - (Data.Either.rights $ - [P.runParser - (Format.Ledger.Read.amount <* P.eof) - () "" (""::Text)]) - ~?= - [] - , "\"0\" = Right 0" ~: - (Data.Either.rights $ - [P.runParser - (Format.Ledger.Read.amount <* P.eof) - () "" ("0"::Text)]) - ~?= - [Amount.nil - { Amount.quantity = Decimal 0 0 - }] - , "\"00\" = Right 0" ~: - (Data.Either.rights $ - [P.runParser - (Format.Ledger.Read.amount <* P.eof) - () "" ("00"::Text)]) - ~?= - [Amount.nil - { Amount.quantity = Decimal 0 0 - }] - , "\"0.\" = Right 0." ~: - (Data.Either.rights $ - [P.runParser - (Format.Ledger.Read.amount <* P.eof) - () "" ("0."::Text)]) - ~?= - [Amount.nil - { Amount.quantity = Decimal 0 0 - , Amount.style = - Amount.Style.nil - { Amount.Style.fractioning = Just '.' - } - }] - , "\".0\" = Right 0.0" ~: - (Data.Either.rights $ - [P.runParser - (Format.Ledger.Read.amount <* P.eof) - () "" (".0"::Text)]) - ~?= - [Amount.nil - { Amount.quantity = Decimal 0 0 - , Amount.style = - Amount.Style.nil - { Amount.Style.fractioning = Just '.' - , Amount.Style.precision = 1 - } - }] - , "\"0,\" = Right 0," ~: - (Data.Either.rights $ - [P.runParser - (Format.Ledger.Read.amount <* P.eof) - () "" ("0,"::Text)]) - ~?= - [Amount.nil - { Amount.quantity = Decimal 0 0 - , Amount.style = - Amount.Style.nil - { Amount.Style.fractioning = Just ',' - } - }] - , "\",0\" = Right 0,0" ~: - (Data.Either.rights $ - [P.runParser - (Format.Ledger.Read.amount <* P.eof) - () "" (",0"::Text)]) - ~?= - [Amount.nil - { Amount.quantity = Decimal 0 0 - , Amount.style = - Amount.Style.nil - { Amount.Style.fractioning = Just ',' - , Amount.Style.precision = 1 - } - }] - , "\"0_\" = Left" ~: - (Data.Either.rights $ - [P.runParser - (Format.Ledger.Read.amount <* P.eof) - () "" ("0_"::Text)]) - ~?= - [] - , "\"_0\" = Left" ~: - (Data.Either.rights $ - [P.runParser - (Format.Ledger.Read.amount <* P.eof) - () "" ("_0"::Text)]) - ~?= - [] - , "\"0.0\" = Right 0.0" ~: - (Data.Either.rights $ - [P.runParser - (Format.Ledger.Read.amount <* P.eof) - () "" ("0.0"::Text)]) - ~?= - [Amount.nil - { Amount.quantity = Decimal 0 0 - , Amount.style = - Amount.Style.nil - { Amount.Style.fractioning = Just '.' - , Amount.Style.precision = 1 - } - }] - , "\"00.00\" = Right 0.00" ~: - (Data.Either.rights $ - [P.runParser - (Format.Ledger.Read.amount <* P.eof) - () "" ("00.00"::Text)]) - ~?= - [Amount.nil - { Amount.quantity = Decimal 0 0 - , Amount.style = - Amount.Style.nil - { Amount.Style.fractioning = Just '.' - , Amount.Style.precision = 2 - } - }] - , "\"0,0\" = Right 0,0" ~: - (Data.Either.rights $ - [P.runParser - (Format.Ledger.Read.amount <* P.eof) - () "" ("0,0"::Text)]) - ~?= - [Amount.nil - { Amount.quantity = Decimal 0 0 - , Amount.style = - Amount.Style.nil - { Amount.Style.fractioning = Just ',' - , Amount.Style.precision = 1 - } - }] - , "\"00,00\" = Right 0,00" ~: - (Data.Either.rights $ - [P.runParser - (Format.Ledger.Read.amount <* P.eof) - () "" ("00,00"::Text)]) - ~?= - [Amount.nil - { Amount.quantity = Decimal 0 0 - , Amount.style = - Amount.Style.nil - { Amount.Style.fractioning = Just ',' - , Amount.Style.precision = 2 - } - }] - , "\"0_0\" = Right 0" ~: - (Data.Either.rights $ - [P.runParser - (Format.Ledger.Read.amount <* P.eof) - () "" ("0_0"::Text)]) - ~?= - [Amount.nil - { Amount.quantity = Decimal 0 0 - , Amount.style = - Amount.Style.nil - { Amount.Style.fractioning = Nothing - , Amount.Style.grouping_integral = Just $ Amount.Style.Grouping '_' [1] - , Amount.Style.precision = 0 - } - }] - , "\"00_00\" = Right 0" ~: - (Data.Either.rights $ - [P.runParser - (Format.Ledger.Read.amount <* P.eof) - () "" ("00_00"::Text)]) - ~?= - [Amount.nil - { Amount.quantity = Decimal 0 0 - , Amount.style = - Amount.Style.nil - { Amount.Style.fractioning = Nothing - , Amount.Style.grouping_integral = Just $ Amount.Style.Grouping '_' [2] - , Amount.Style.precision = 0 - } - }] - , "\"0,000.00\" = Right 0,000.00" ~: - (Data.Either.rights $ - [P.runParser - (Format.Ledger.Read.amount <* P.eof) - () "" ("0,000.00"::Text)]) - ~?= - [Amount.nil - { Amount.quantity = Decimal 0 0 - , Amount.style = - Amount.Style.nil - { Amount.Style.fractioning = Just '.' - , Amount.Style.grouping_integral = Just $ Amount.Style.Grouping ',' [3] - , Amount.Style.precision = 2 - } - }] - , "\"0.000,00\" = Right 0.000,00" ~: - (Data.Either.rights $ - [P.runParser - (Format.Ledger.Read.amount) - () "" ("0.000,00"::Text)]) - ~?= - [Amount.nil - { Amount.quantity = Decimal 0 0 - , Amount.style = - Amount.Style.nil - { Amount.Style.fractioning = Just ',' - , Amount.Style.grouping_integral = Just $ Amount.Style.Grouping '.' [3] - , Amount.Style.precision = 2 - } - }] - , "\"1,000.00\" = Right 1,000.00" ~: - (Data.Either.rights $ - [P.runParser - (Format.Ledger.Read.amount <* P.eof) - () "" ("1,000.00"::Text)]) - ~?= - [Amount.nil - { Amount.quantity = Decimal 0 1000 - , Amount.style = - Amount.Style.nil - { Amount.Style.fractioning = Just '.' - , Amount.Style.grouping_integral = Just $ Amount.Style.Grouping ',' [3] - , Amount.Style.precision = 2 - } - }] - , "\"1.000,00\" = Right 1.000,00" ~: - (Data.Either.rights $ - [P.runParser - (Format.Ledger.Read.amount) - () "" ("1.000,00"::Text)]) - ~?= - [Amount.nil - { Amount.quantity = Decimal 0 1000 - , Amount.style = - Amount.Style.nil - { Amount.Style.fractioning = Just ',' - , Amount.Style.grouping_integral = Just $ Amount.Style.Grouping '.' [3] - , Amount.Style.precision = 2 - } - }] - , "\"1,000.00.\" = Left" ~: - (Data.Either.rights $ - [P.runParser - (Format.Ledger.Read.amount) - () "" ("1,000.00."::Text)]) - ~?= - [] - , "\"1.000,00,\" = Left" ~: - (Data.Either.rights $ - [P.runParser - (Format.Ledger.Read.amount) - () "" ("1.000,00,"::Text)]) - ~?= - [] - , "\"1,000.00_\" = Left" ~: - (Data.Either.rights $ - [P.runParser - (Format.Ledger.Read.amount) - () "" ("1,000.00_"::Text)]) - ~?= - [] - , "\"12\" = Right 12" ~: - (Data.Either.rights $ - [P.runParser - (Format.Ledger.Read.amount <* P.eof) - () "" ("123"::Text)]) - ~?= - [Amount.nil - { Amount.quantity = Decimal 0 123 - }] - , "\"1.2\" = Right 1.2" ~: - (Data.Either.rights $ - [P.runParser - (Format.Ledger.Read.amount <* P.eof) - () "" ("1.2"::Text)]) - ~?= - [Amount.nil - { Amount.quantity = Decimal 1 12 - , Amount.style = - Amount.Style.nil - { Amount.Style.fractioning = Just '.' - , Amount.Style.precision = 1 - } - }] - , "\"1,2\" = Right 1,2" ~: - (Data.Either.rights $ - [P.runParser - (Format.Ledger.Read.amount <* P.eof) - () "" ("1,2"::Text)]) - ~?= - [Amount.nil - { Amount.quantity = Decimal 1 12 - , Amount.style = - Amount.Style.nil - { Amount.Style.fractioning = Just ',' - , Amount.Style.precision = 1 - } - }] - , "\"12.23\" = Right 12.23" ~: - (Data.Either.rights $ - [P.runParser - (Format.Ledger.Read.amount <* P.eof) - () "" ("12.34"::Text)]) - ~?= - [Amount.nil - { Amount.quantity = Decimal 2 1234 - , Amount.style = - Amount.Style.nil - { Amount.Style.fractioning = Just '.' - , Amount.Style.precision = 2 - } - }] - , "\"12,23\" = Right 12,23" ~: - (Data.Either.rights $ - [P.runParser - (Format.Ledger.Read.amount <* P.eof) - () "" ("12,34"::Text)]) - ~?= - [Amount.nil - { Amount.quantity = Decimal 2 1234 - , Amount.style = - Amount.Style.nil - { Amount.Style.fractioning = Just ',' - , Amount.Style.precision = 2 - } - }] - , "\"1_2\" = Right 1_2" ~: - (Data.Either.rights $ - [P.runParser - (Format.Ledger.Read.amount <* P.eof) - () "" ("1_2"::Text)]) - ~?= - [Amount.nil - { Amount.quantity = Decimal 0 12 - , Amount.style = - Amount.Style.nil - { Amount.Style.grouping_integral = Just $ Amount.Style.Grouping '_' [1] - , Amount.Style.precision = 0 - } - }] - , "\"1_23\" = Right 1_23" ~: - (Data.Either.rights $ - [P.runParser - (Format.Ledger.Read.amount <* P.eof) - () "" ("1_23"::Text)]) - ~?= - [Amount.nil - { Amount.quantity = Decimal 0 123 - , Amount.style = - Amount.Style.nil - { Amount.Style.grouping_integral = Just $ Amount.Style.Grouping '_' [2] - , Amount.Style.precision = 0 - } - }] - , "\"1_23_456\" = Right 1_23_456" ~: - (Data.Either.rights $ - [P.runParser - (Format.Ledger.Read.amount <* P.eof) - () "" ("1_23_456"::Text)]) - ~?= - [Amount.nil - { Amount.quantity = Decimal 0 123456 - , Amount.style = - Amount.Style.nil - { Amount.Style.grouping_integral = Just $ Amount.Style.Grouping '_' [3, 2] - , Amount.Style.precision = 0 - } - }] - , "\"1_23_456.7890_12345_678901\" = Right 1_23_456.7890_12345_678901" ~: - (Data.Either.rights $ - [P.runParser - (Format.Ledger.Read.amount <* P.eof) - () "" ("1_23_456.7890_12345_678901"::Text)]) - ~?= - [Amount.nil - { Amount.quantity = Decimal 15 123456789012345678901 - , Amount.style = - Amount.Style.nil - { Amount.Style.fractioning = Just '.' - , Amount.Style.grouping_integral = Just $ Amount.Style.Grouping '_' [3, 2] - , Amount.Style.grouping_fractional = Just $ Amount.Style.Grouping '_' [4, 5, 6] - , Amount.Style.precision = 15 - } - }] - , "\"123456_78901_2345.678_90_1\" = Right 123456_78901_2345.678_90_1" ~: - (Data.Either.rights $ - [P.runParser - (Format.Ledger.Read.amount <* P.eof) - () "" ("123456_78901_2345.678_90_1"::Text)]) - ~?= - [Amount.nil - { Amount.quantity = Decimal 6 123456789012345678901 - , Amount.style = - Amount.Style.nil - { Amount.Style.fractioning = Just '.' - , Amount.Style.grouping_integral = Just $ Amount.Style.Grouping '_' [4, 5, 6] - , Amount.Style.grouping_fractional = Just $ Amount.Style.Grouping '_' [3, 2] - , Amount.Style.precision = 6 - } - }] - , "\"$1\" = Right $1" ~: - (Data.Either.rights $ - [P.runParser - (Format.Ledger.Read.amount <* P.eof) - () "" ("$1"::Text)]) - ~?= - [Amount.nil - { Amount.quantity = Decimal 0 1 - , Amount.style = - Amount.Style.nil - { Amount.Style.fractioning = Nothing - , Amount.Style.grouping_integral = Nothing - , Amount.Style.grouping_fractional = Nothing - , Amount.Style.precision = 0 - , Amount.Style.unit_side = Just Amount.Style.Side_Left - , Amount.Style.unit_spaced = Just False - } - , Amount.unit = "$" - }] - , "\"1$\" = Right 1$" ~: - (Data.Either.rights $ - [P.runParser - (Format.Ledger.Read.amount <* P.eof) - () "" ("1$"::Text)]) - ~?= - [Amount.nil - { Amount.quantity = Decimal 0 1 - , Amount.style = - Amount.Style.nil - { Amount.Style.fractioning = Nothing - , Amount.Style.grouping_integral = Nothing - , Amount.Style.grouping_fractional = Nothing - , Amount.Style.precision = 0 - , Amount.Style.unit_side = Just Amount.Style.Side_Right - , Amount.Style.unit_spaced = Just False - } - , Amount.unit = "$" - }] - , "\"$ 1\" = Right $ 1" ~: - (Data.Either.rights $ - [P.runParser - (Format.Ledger.Read.amount <* P.eof) - () "" ("$ 1"::Text)]) - ~?= - [Amount.nil - { Amount.quantity = Decimal 0 1 - , Amount.style = - Amount.Style.nil - { Amount.Style.fractioning = Nothing - , Amount.Style.grouping_integral = Nothing - , Amount.Style.grouping_fractional = Nothing - , Amount.Style.precision = 0 - , Amount.Style.unit_side = Just Amount.Style.Side_Left - , Amount.Style.unit_spaced = Just True - } - , Amount.unit = "$" - }] - , "\"1 $\" = Right 1 $" ~: - (Data.Either.rights $ - [P.runParser - (Format.Ledger.Read.amount <* P.eof) - () "" ("1 $"::Text)]) - ~?= - [Amount.nil - { Amount.quantity = Decimal 0 1 - , Amount.style = - Amount.Style.nil - { Amount.Style.fractioning = Nothing - , Amount.Style.grouping_integral = Nothing - , Amount.Style.grouping_fractional = Nothing - , Amount.Style.precision = 0 - , Amount.Style.unit_side = Just Amount.Style.Side_Right - , Amount.Style.unit_spaced = Just True - } - , Amount.unit = "$" - }] - , "\"-$1\" = Right $-1" ~: - (Data.Either.rights $ - [P.runParser - (Format.Ledger.Read.amount <* P.eof) - () "" ("-$1"::Text)]) - ~?= - [Amount.nil - { Amount.quantity = Decimal 0 (-1) - , Amount.style = - Amount.Style.nil - { Amount.Style.fractioning = Nothing - , Amount.Style.grouping_integral = Nothing - , Amount.Style.grouping_fractional = Nothing - , Amount.Style.precision = 0 - , Amount.Style.unit_side = Just Amount.Style.Side_Left - , Amount.Style.unit_spaced = Just False - } - , Amount.unit = "$" - }] - , "\"\\\"4 2\\\"1\" = Right \\\"4 2\\\"1" ~: - (Data.Either.rights $ - [P.runParser - (Format.Ledger.Read.amount <* P.eof) - () "" ("\"4 2\"1"::Text)]) - ~?= - [Amount.nil - { Amount.quantity = Decimal 0 1 - , Amount.style = - Amount.Style.nil - { Amount.Style.fractioning = Nothing - , Amount.Style.grouping_integral = Nothing - , Amount.Style.grouping_fractional = Nothing - , Amount.Style.precision = 0 - , Amount.Style.unit_side = Just Amount.Style.Side_Left - , Amount.Style.unit_spaced = Just False - } - , Amount.unit = "4 2" - }] - , "\"1\\\"4 2\\\"\" = Right 1\\\"4 2\\\"" ~: - (Data.Either.rights $ - [P.runParser - (Format.Ledger.Read.amount <* P.eof) - () "" ("1\"4 2\""::Text)]) - ~?= - [Amount.nil - { Amount.quantity = Decimal 0 1 - , Amount.style = - Amount.Style.nil - { Amount.Style.fractioning = Nothing - , Amount.Style.grouping_integral = Nothing - , Amount.Style.grouping_fractional = Nothing - , Amount.Style.precision = 0 - , Amount.Style.unit_side = Just Amount.Style.Side_Right - , Amount.Style.unit_spaced = Just False - } - , Amount.unit = "4 2" - }] - , "\"$1.000,00\" = Right $1.000,00" ~: - (Data.Either.rights $ - [P.runParser - (Format.Ledger.Read.amount <* P.eof) - () "" ("$1.000,00"::Text)]) - ~?= - [Amount.nil - { Amount.quantity = Decimal 0 1000 - , Amount.style = - Amount.Style.nil - { Amount.Style.fractioning = Just ',' - , Amount.Style.grouping_integral = Just $ Amount.Style.Grouping '.' [3] - , Amount.Style.grouping_fractional = Nothing - , Amount.Style.precision = 2 - , Amount.Style.unit_side = Just Amount.Style.Side_Left - , Amount.Style.unit_spaced = Just False - } - , Amount.unit = "$" - }] - , "\"1.000,00$\" = Right 1.000,00$" ~: - (Data.Either.rights $ - [P.runParser - (Format.Ledger.Read.amount <* P.eof) - () "" ("1.000,00$"::Text)]) - ~?= - [Amount.nil - { Amount.quantity = Decimal 0 1000 - , Amount.style = - Amount.Style.nil - { Amount.Style.fractioning = Just ',' - , Amount.Style.grouping_integral = Just $ Amount.Style.Grouping '.' [3] - , Amount.Style.grouping_fractional = Nothing - , Amount.Style.precision = 2 - , Amount.Style.unit_side = Just Amount.Style.Side_Right - , Amount.Style.unit_spaced = Just False - } - , Amount.unit = "$" - }] - ] , "comment" ~: TestList [ "; some comment = Right \" some comment\"" ~: (Data.Either.rights $ @@ -2473,111 +2581,6 @@ test_Hcompta = ~?= [ [" some comment "] ] ] - , "date" ~: TestList - [ "2000/01/01" ~: - (Data.Either.rights $ - [P.runParser_with_Error - (Date.Read.date id Nothing <* P.eof) - () "" ("2000/01/01"::Text)]) - ~?= - [ Time.zonedTimeToUTC $ - Time.ZonedTime - (Time.LocalTime - (Time.fromGregorian 2000 01 01) - (Time.TimeOfDay 0 0 0)) - (Time.utc)] - , "2000/01/01 some text" ~: - (Data.Either.rights $ - [P.runParser_with_Error - (Date.Read.date id Nothing) - () "" ("2000/01/01 some text"::Text)]) - ~?= - [ Time.zonedTimeToUTC $ - Time.ZonedTime - (Time.LocalTime - (Time.fromGregorian 2000 01 01) - (Time.TimeOfDay 0 0 0)) - (Time.utc)] - , "2000/01/01 12:34" ~: - (Data.Either.rights $ - [P.runParser_with_Error - (Date.Read.date id Nothing <* P.eof) - () "" ("2000/01/01 12:34"::Text)]) - ~?= - [ Time.zonedTimeToUTC $ - Time.ZonedTime - (Time.LocalTime - (Time.fromGregorian 2000 01 01) - (Time.TimeOfDay 12 34 0)) - (Time.utc)] - , "2000/01/01 12:34:56" ~: - (Data.Either.rights $ - [P.runParser_with_Error - (Date.Read.date id Nothing <* P.eof) - () "" ("2000/01/01 12:34:56"::Text)]) - ~?= - [ Time.zonedTimeToUTC $ - Time.ZonedTime - (Time.LocalTime - (Time.fromGregorian 2000 01 01) - (Time.TimeOfDay 12 34 56)) - (Time.utc)] - , "2000/01/01 12:34 CET" ~: - (Data.Either.rights $ - [P.runParser_with_Error - (Date.Read.date id Nothing <* P.eof) - () "" ("2000/01/01 12:34 CET"::Text)]) - ~?= - [ Time.zonedTimeToUTC $ - Time.ZonedTime - (Time.LocalTime - (Time.fromGregorian 2000 01 01) - (Time.TimeOfDay 12 34 0)) - (Time.TimeZone 60 True "CET")] - , "2000/01/01 12:34 +0130" ~: - (Data.Either.rights $ - [P.runParser_with_Error - (Date.Read.date id Nothing <* P.eof) - () "" ("2000/01/01 12:34 +0130"::Text)]) - ~?= - [ Time.zonedTimeToUTC $ - Time.ZonedTime - (Time.LocalTime - (Time.fromGregorian 2000 01 01) - (Time.TimeOfDay 12 34 0)) - (Time.TimeZone 90 False "+0130")] - , "2000/01/01 12:34:56 CET" ~: - (Data.Either.rights $ - [P.runParser_with_Error - (Date.Read.date id Nothing <* P.eof) - () "" ("2000/01/01 12:34:56 CET"::Text)]) - ~?= - [ Time.zonedTimeToUTC $ - Time.ZonedTime - (Time.LocalTime - (Time.fromGregorian 2000 01 01) - (Time.TimeOfDay 12 34 56)) - (Time.TimeZone 60 True "CET")] - , "2001/02/29" ~: - (Data.Either.rights $ - [P.runParser_with_Error - (Date.Read.date id Nothing <* P.eof) - () "" ("2001/02/29"::Text)]) - ~?= - [] - , "01/01" ~: - (Data.Either.rights $ - [P.runParser_with_Error - (Date.Read.date id (Just 2000) <* P.eof) - () "" ("01/01"::Text)]) - ~?= - [ Time.zonedTimeToUTC $ - Time.ZonedTime - (Time.LocalTime - (Time.fromGregorian 2000 01 01) - (Time.TimeOfDay 0 0 0)) - (Time.utc)] - ] , "tag_value" ~: TestList [ "," ~: (Data.Either.rights $ diff --git a/lib/hcompta-lib.cabal b/lib/hcompta-lib.cabal index 4ec436c..fd7fd72 100644 --- a/lib/hcompta-lib.cabal +++ b/lib/hcompta-lib.cabal @@ -52,11 +52,17 @@ Library -- default-language: Haskell2010 exposed-modules: Hcompta - Hcompta.Calc - Hcompta.Calc.Balance - Hcompta.Calc.Print - Hcompta.Calc.Register - Hcompta.Calc.Stats + Hcompta.Account + Hcompta.Amount + Hcompta.Amount.Quantity + Hcompta.Amount.Read + Hcompta.Amount.Style + Hcompta.Amount.Unit + Hcompta.Balance + Hcompta.Date + Hcompta.Date.Read + Hcompta.Filter + Hcompta.Filter.Read Hcompta.Format Hcompta.Format.CSV Hcompta.Format.Ledger @@ -69,17 +75,7 @@ Library Hcompta.Lib.Path Hcompta.Lib.Regex Hcompta.Lib.TreeMap - Hcompta.Model - Hcompta.Model.Account - Hcompta.Model.Amount - Hcompta.Model.Amount.Quantity - Hcompta.Model.Amount.Style - Hcompta.Model.Amount.Read - Hcompta.Model.Amount.Unit - Hcompta.Model.Date - Hcompta.Model.Date.Read - Hcompta.Model.Filter - Hcompta.Model.Filter.Read + Hcompta.Stats build-depends: base >= 4.3 && < 5 , ansi-terminal >= 0.4 && < 0.7 -- 2.47.2 From 2826d87607d97fe02b2dee04348ef6fdccccd80f Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Sat, 20 Jun 2015 21:18:15 +0200 Subject: [PATCH 12/16] =?utf8?q?Polissage=20:=20CLI.Command.Balance=20:=20?= =?utf8?q?s=C3=A9pare=20ce=20qui=20est=20sp=C3=A9cifique=20au=20format=20L?= =?utf8?q?edger.?= MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit --- cli/Hcompta/CLI/Command/Balance.hs | 115 +++++++++++++++++------------ 1 file changed, 69 insertions(+), 46 deletions(-) diff --git a/cli/Hcompta/CLI/Command/Balance.hs b/cli/Hcompta/CLI/Command/Balance.hs index 5d1b2c4..1cf915c 100644 --- a/cli/Hcompta/CLI/Command/Balance.hs +++ b/cli/Hcompta/CLI/Command/Balance.hs @@ -135,9 +135,7 @@ run context args = do (flip mapM_) errs $ \(_path, err) -> do Write.fatal context $ err ([], journals) -> do - (balance_filter:: - Filter.Test_Bool (Filter.Test_Balance - (Account, Balance.Amount_Sum Amount))) <- + balance_filter <- foldr Filter.And Filter.Any <$> do (flip mapM) text_filters $ \s -> liftIO $ Filter.Read.read Filter.Read.test_balance s @@ -147,47 +145,19 @@ run context args = do Write.debug context $ "balance_filter: " ++ show balance_filter Write.debug context $ "transaction_filter: " ++ show (ctx_transaction_filter ctx) Write.debug context $ "posting_filter: " ++ show (ctx_posting_filter ctx) - let (balance_by_account::Balance.Balance_by_Account (Balance.Amount_Sum Amount) Amount.Unit) = - foldr - (Ledger.Journal.fold - (flip (foldr - (flip (foldr - (\tr -> - case Filter.test (ctx_transaction_filter ctx) tr of - False -> id - True -> - let filter_postings = - Data.Foldable.concatMap $ - Data.List.filter $ - (Filter.test (ctx_posting_filter ctx)) in - let balance = - flip (foldr Balance.by_account) . - map (\p -> - ( Ledger.posting_account p - , Data.Map.map Balance.amount_sum (Ledger.posting_amounts p) - ) - ) . - filter_postings in - balance (Ledger.transaction_postings tr) . - balance (Ledger.transaction_virtual_postings tr) . - balance (Ledger.transaction_balanced_virtual_postings tr) - )))) - . Ledger.journal_transactions)) - (Balance.balance_by_account Balance.nil) + let (balance_by_account, balance_by_unit) = + ledger_balances + (ctx_transaction_filter ctx) + (ctx_posting_filter ctx) + balance_filter journals - let balance_expanded = - Lib.TreeMap.filter_with_Path (\acct -> - Data.Foldable.any - (Filter.test balance_filter . (acct,)) . - Balance.inclusive) $ - Balance.expanded balance_by_account style_color <- Write.with_color context IO.stdout - Ledger.Write.put Ledger.Write.Style - { Ledger.Write.style_align = True - , Ledger.Write.style_color - } IO.stdout $ do + W.displayIO IO.stdout $ + W.renderPretty style_color 1.0 maxBound $ do toDoc () $ - let title = TL.toStrict . W.displayT . W.renderCompact False . + let title = + TL.toStrict . W.displayT . + W.renderCompact False . toDoc (Context.lang context) in zipWith id [ Table.column (title Lang.Message_Balance_debit) Table.Align_Right @@ -195,7 +165,7 @@ run context args = do , Table.column (title Lang.Message_Balance_total) Table.Align_Right , Table.column (title Lang.Message_Account) Table.Align_Left ] $ - flip (write_by_accounts ctx) balance_expanded $ + flip (write_by_accounts ctx) balance_by_account $ zipWith (:) [ Table.Cell_Line '=' 0 , Table.Cell_Line '=' 0 @@ -203,10 +173,63 @@ run context args = do , Table.Cell_Line ' ' 0 ] $ write_by_amounts (repeat []) $ - Data.Map.map Balance.unit_sum_amount $ - Balance.by_unit_of_expanded - balance_expanded - (Balance.balance_by_unit Balance.nil) + Data.Map.map + Balance.unit_sum_amount + balance_by_unit + +ledger_balances + :: Filter.Test_Bool (Filter.Test_Transaction Ledger.Transaction) + -> Filter.Test_Bool (Filter.Test_Posting Ledger.Posting) + -> Filter.Test_Bool (Filter.Test_Balance (Account, Balance.Amount_Sum Amount)) + -> [Ledger.Journal] + -> ( Balance.Expanded (Balance.Amount_Sum Amount) + , Balance.Balance_by_Unit (Balance.Amount_Sum Amount) Unit ) +ledger_balances + transaction_filter + posting_filter + balance_filter + journals = + let balance_by_account = + foldr + (Ledger.Journal.fold + (flip (foldr + (flip (foldr + (\tr -> + case Filter.test transaction_filter tr of + False -> id + True -> + let filter_postings = + Data.Foldable.concatMap $ + Data.List.filter $ + (Filter.test posting_filter) in + let balance = + flip (foldr Balance.by_account) . + map (\p -> + ( Ledger.posting_account p + , Data.Map.map Balance.amount_sum (Ledger.posting_amounts p) + ) + ) . + filter_postings in + balance (Ledger.transaction_postings tr) . + balance (Ledger.transaction_virtual_postings tr) . + balance (Ledger.transaction_balanced_virtual_postings tr) + )))) + . Ledger.journal_transactions)) + (Balance.balance_by_account Balance.nil) + journals in + let balance_expanded = + Lib.TreeMap.filter_with_Path (\acct -> + Data.Foldable.any + (Filter.test balance_filter . (acct,)) . + Balance.inclusive) $ + Balance.expanded balance_by_account in + let balance_by_unit = + Balance.by_unit_of_expanded + balance_expanded + (Balance.balance_by_unit Balance.nil) in + ( balance_expanded + , balance_by_unit + ) write_by_accounts :: Ctx -- 2.47.2 From 4300c62051ca3e676b17902e93ed7bc313307bce Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Sat, 20 Jun 2015 21:31:51 +0200 Subject: [PATCH 13/16] =?utf8?q?Modif=20:=20Filter.Read=20:=20test=5Famoun?= =?utf8?q?t=20:=20pas=20d=E2=80=99unit=C3=A9=20accepte=20toutes=20les=20un?= =?utf8?q?it=C3=A9s.?= MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit --- lib/Hcompta/Filter/Read.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/lib/Hcompta/Filter/Read.hs b/lib/Hcompta/Filter/Read.hs index ad2738d..76e95a1 100644 --- a/lib/Hcompta/Filter/Read.hs +++ b/lib/Hcompta/Filter/Read.hs @@ -315,8 +315,11 @@ test_amount = do tst <- test_ord amt <- Amount.Read.amount return $ Test_Amount - (tst $ Amount.quantity amt) - (Test_Unit $ Test_Text_Exact $ Unit.text $ Amount.unit amt) + (tst $ Amount.quantity amt) $ + (Test_Unit $ + case Unit.text $ Amount.unit amt of + unit | Text.null unit -> Test_Text_Any + unit -> Test_Text_Exact unit) test_amount_operator :: Stream s m Char -- 2.47.2 From 626eaf9121d65ee15aacbe8aa608bd615c9b92a4 Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Sat, 20 Jun 2015 22:46:02 +0200 Subject: [PATCH 14/16] Modif : Balance : inutile de mettre amount_sum_balance dans Amount_Sum. --- lib/Hcompta/Balance.hs | 115 ++++++++++++++++++++++-------------- lib/Test/Main.hs | 78 ++++++------------------ web/Application.hs | 1 + web/Foundation.hs | 1 + web/Handler/Common.hs | 1 + web/Handler/Home.hs | 1 + web/Model.hs | 2 + web/Settings.hs | 3 + web/Settings/StaticFiles.hs | 1 + web/hcompta-web.cabal | 7 +-- 10 files changed, 99 insertions(+), 111 deletions(-) diff --git a/lib/Hcompta/Balance.hs b/lib/Hcompta/Balance.hs index 732b5cd..c089e0b 100644 --- a/lib/Hcompta/Balance.hs +++ b/lib/Hcompta/Balance.hs @@ -432,58 +432,83 @@ by_unit_of_expanded = -- * Type 'Amount_Sum' --- | Sum keeping track of negative and positive 'Amount's. +-- | Sum separately keeping track of negative and positive 'amount's. data Amount amount => Amount_Sum amount - = Amount_Sum - { amount_sum_negative :: Maybe amount - , amount_sum_positive :: Maybe amount - , amount_sum_balance :: amount - } deriving (Data, Eq, Show, Typeable) + = Amount_Sum_Negative amount + | Amount_Sum_Positive amount + | Amount_Sum_Both amount amount + deriving (Data, Eq, Show, Typeable) instance Amount a => Amount (Amount_Sum a) where type Amount_Unit (Amount_Sum a) = Amount_Unit a - amount_null = amount_null . amount_sum_balance + amount_null amt = + case amt of + Amount_Sum_Negative n -> amount_null n + Amount_Sum_Positive p -> amount_null p + Amount_Sum_Both n p -> amount_null (amount_add n p) amount_add a0 a1 = - let add get = - case (get a0, get a1) of - (Nothing, a) -> a - (a, Nothing) -> a - (Just x0, Just x1) -> Just $ amount_add x0 x1 in - Amount_Sum - { amount_sum_negative = add amount_sum_negative - , amount_sum_positive = add amount_sum_positive - , amount_sum_balance = amount_add (amount_sum_balance a0) (amount_sum_balance a1) - } - amount_negate a = - Amount_Sum - { amount_sum_negative = amount_sum_positive a - , amount_sum_positive = amount_sum_negative a - , amount_sum_balance = amount_negate $ amount_sum_balance a - } - amount_negative a = - maybe Nothing - (\amt -> Just $ Amount_Sum - { amount_sum_negative = Just amt - , amount_sum_positive = Nothing - , amount_sum_balance = amt - }) - (amount_sum_negative a) - amount_positive a = - maybe Nothing - (\amt -> Just $ Amount_Sum - { amount_sum_negative = Nothing - , amount_sum_positive = Just amt - , amount_sum_balance = amt - }) - (amount_sum_positive a) + case (a0, a1) of + (Amount_Sum_Negative n0, Amount_Sum_Negative n1) -> Amount_Sum_Negative (amount_add n0 n1) + (Amount_Sum_Negative n , Amount_Sum_Positive p) -> Amount_Sum_Both n p + (Amount_Sum_Negative n0, Amount_Sum_Both n1 p) -> Amount_Sum_Both (amount_add n0 n1) p + + (Amount_Sum_Positive p , Amount_Sum_Negative n) -> Amount_Sum_Both n p + (Amount_Sum_Positive p0, Amount_Sum_Positive p1) -> Amount_Sum_Positive (amount_add p0 p1) + (Amount_Sum_Positive p , Amount_Sum_Both n1 p1) -> Amount_Sum_Both n1 (amount_add p p1) + + (Amount_Sum_Both n0 p0, Amount_Sum_Negative p1) -> Amount_Sum_Both n0 (amount_add p0 p1) + (Amount_Sum_Both n0 p0, Amount_Sum_Positive p1) -> Amount_Sum_Both n0 (amount_add p0 p1) + (Amount_Sum_Both n0 p0, Amount_Sum_Both n1 p1) -> Amount_Sum_Both (amount_add n0 n1) (amount_add p0 p1) + amount_negate amt = + case amt of + Amount_Sum_Negative n -> Amount_Sum_Positive $ amount_negate n + Amount_Sum_Positive p -> Amount_Sum_Negative $ amount_negate p + Amount_Sum_Both n p -> Amount_Sum_Both (amount_negate p) (amount_negate n) + amount_negative amt = + case amt of + Amount_Sum_Negative _ -> Just $ amt + Amount_Sum_Positive _ -> Nothing + Amount_Sum_Both n _ -> Just $ Amount_Sum_Negative n + amount_positive amt = + case amt of + Amount_Sum_Negative _ -> Nothing + Amount_Sum_Positive _ -> Just $ amt + Amount_Sum_Both _ p -> Just $ Amount_Sum_Positive p amount_sum :: Amount amount => amount -> Amount_Sum amount -amount_sum a = - Amount_Sum - { amount_sum_negative = amount_negative a - , amount_sum_positive = amount_positive a - , amount_sum_balance = a - } +amount_sum amt = + case (amount_negative amt, amount_positive amt) of + (Just n, Nothing) -> Amount_Sum_Negative n + (Nothing, Just p) -> Amount_Sum_Positive p + (Just n, Just p) -> Amount_Sum_Both n p + (Nothing, Nothing) -> Amount_Sum_Both amt amt + +amount_sum_negative + :: Amount amount + => Amount_Sum amount -> Maybe amount +amount_sum_negative amt = + case amt of + Amount_Sum_Negative n -> Just n + Amount_Sum_Positive _ -> Nothing + Amount_Sum_Both n _ -> Just n + +amount_sum_positive + :: Amount amount + => Amount_Sum amount -> Maybe amount +amount_sum_positive amt = + case amt of + Amount_Sum_Negative _ -> Nothing + Amount_Sum_Positive p -> Just p + Amount_Sum_Both _ p -> Just p + +amount_sum_balance + :: Amount amount + => Amount_Sum amount -> amount +amount_sum_balance amt = + case amt of + Amount_Sum_Negative n -> n + Amount_Sum_Positive p -> p + Amount_Sum_Both n p -> amount_add n p diff --git a/lib/Test/Main.hs b/lib/Test/Main.hs index 551ae92..f449d0e 100644 --- a/lib/Test/Main.hs +++ b/lib/Test/Main.hs @@ -1205,22 +1205,18 @@ test_Hcompta = [ ( "A":|[] , Data.Map.fromListWith const $ Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance s, s)) - [ Balance.Amount_Sum - { Balance.amount_sum_negative = Just $ Amount.usd $ -1 - , Balance.amount_sum_positive = Just $ Amount.usd $ 1 - , Balance.amount_sum_balance = Amount.usd $ 0 - } + [ Balance.Amount_Sum_Both + (Amount.usd $ -1) + (Amount.usd $ 1) ] ) ] , Balance.balance_by_unit = Data.Map.fromList $ Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) [ Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.Amount_Sum - { Balance.amount_sum_negative = Just $ Amount.usd $ -1 - , Balance.amount_sum_positive = Just $ Amount.usd $ 1 - , Balance.amount_sum_balance = Amount.usd $ 0 - } + { Balance.unit_sum_amount = Balance.Amount_Sum_Both + (Amount.usd $ -1) + (Amount.usd $ 1) , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["A":|[]] } @@ -1247,20 +1243,12 @@ test_Hcompta = Data.Map.fromList $ Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) [ Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.Amount_Sum - { Balance.amount_sum_negative = Nothing - , Balance.amount_sum_positive = Just $ Amount.usd $ 1 - , Balance.amount_sum_balance = Amount.usd $ 1 - } + { Balance.unit_sum_amount = Balance.Amount_Sum_Positive (Amount.usd $ 1) , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["A":|[]] } , Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.Amount_Sum - { Balance.amount_sum_negative = Just $ Amount.eur $ -1 - , Balance.amount_sum_positive = Nothing - , Balance.amount_sum_balance = Amount.eur $ -1 - } + { Balance.unit_sum_amount = Balance.Amount_Sum_Negative (Amount.eur $ -1) , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["A":|[]] } @@ -1289,11 +1277,9 @@ test_Hcompta = Data.Map.fromList $ Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) [ Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.Amount_Sum - { Balance.amount_sum_negative = Just $ Amount.usd $ -1 - , Balance.amount_sum_positive = Just $ Amount.usd $ 1 - , Balance.amount_sum_balance = Amount.usd $ 0 - } + { Balance.unit_sum_amount = Balance.Amount_Sum_Both + (Amount.usd $ -1) + (Amount.usd $ 1) , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["A":|[], "B":|[]] } @@ -1346,16 +1332,8 @@ test_Hcompta = [ ("A":|[] , Data.Map.fromListWith const $ Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance s, s)) - [ Balance.Amount_Sum - { Balance.amount_sum_negative = Just $ Amount.usd $ -1 - , Balance.amount_sum_positive = Just $ Amount.usd $ 1 - , Balance.amount_sum_balance = Amount.usd $ 0 - } - , Balance.Amount_Sum - { Balance.amount_sum_negative = Just $ Amount.eur $ -2 - , Balance.amount_sum_positive = Just $ Amount.eur $ 2 - , Balance.amount_sum_balance = Amount.eur $ 0 - } + [ Balance.Amount_Sum_Both (Amount.usd $ -1) (Amount.usd $ 1) + , Balance.Amount_Sum_Both (Amount.eur $ -2) (Amount.eur $ 2) ] ) ] @@ -1363,20 +1341,12 @@ test_Hcompta = Data.Map.fromList $ Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) [ Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.Amount_Sum - { Balance.amount_sum_negative = Just $ Amount.usd $ -1 - , Balance.amount_sum_positive = Just $ Amount.usd $ 1 - , Balance.amount_sum_balance = Amount.usd $ 0 - } + { Balance.unit_sum_amount = Balance.Amount_Sum_Both (Amount.usd $ -1) (Amount.usd $ 1) , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["A":|[]] } , Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.Amount_Sum - { Balance.amount_sum_negative = Just $ Amount.eur $ -2 - , Balance.amount_sum_positive = Just $ Amount.eur $ 2 - , Balance.amount_sum_balance = Amount.eur $ 0 - } + { Balance.unit_sum_amount = Balance.Amount_Sum_Both (Amount.eur $ -2) (Amount.eur $ 2) , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["A":|[]] } @@ -1405,29 +1375,17 @@ test_Hcompta = Data.Map.fromList $ Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) [ Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.Amount_Sum - { Balance.amount_sum_negative = Just $ Amount.usd $ -1 - , Balance.amount_sum_positive = Just $ Amount.usd $ 1 - , Balance.amount_sum_balance = Amount.usd $ 0 - } + { Balance.unit_sum_amount = Balance.Amount_Sum_Both (Amount.usd $ -1) (Amount.usd $ 1) , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["A":|[], "B":|[]] } , Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.Amount_Sum - { Balance.amount_sum_negative = Just $ Amount.eur $ -2 - , Balance.amount_sum_positive = Just $ Amount.eur $ 2 - , Balance.amount_sum_balance = Amount.eur $ 0 - } + { Balance.unit_sum_amount = Balance.Amount_Sum_Both (Amount.eur $ -2) (Amount.eur $ 2) , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["A":|[], "B":|[]] } , Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.Amount_Sum - { Balance.amount_sum_negative = Just $ Amount.gbp $ -3 - , Balance.amount_sum_positive = Just $ Amount.gbp $ 3 - , Balance.amount_sum_balance = Amount.gbp $ 0 - } + { Balance.unit_sum_amount = Balance.Amount_Sum_Both (Amount.gbp $ -3) (Amount.gbp $ 3) , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["A":|[], "B":|[]] } diff --git a/web/Application.hs b/web/Application.hs index f0294a6..00f6753 100644 --- a/web/Application.hs +++ b/web/Application.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Application ( getApplicationDev diff --git a/web/Foundation.hs b/web/Foundation.hs index f9ff583..ef55a9a 100644 --- a/web/Foundation.hs +++ b/web/Foundation.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TemplateHaskell #-} module Foundation where import Import.NoFoundation diff --git a/web/Handler/Common.hs b/web/Handler/Common.hs index eadd206..95cff45 100644 --- a/web/Handler/Common.hs +++ b/web/Handler/Common.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TemplateHaskell #-} -- | Common handler functions. module Handler.Common where diff --git a/web/Handler/Home.hs b/web/Handler/Home.hs index 86e3039..efedaed 100644 --- a/web/Handler/Home.hs +++ b/web/Handler/Home.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TemplateHaskell #-} module Handler.Home where import Import diff --git a/web/Model.hs b/web/Model.hs index 353bafb..fe5bf38 100644 --- a/web/Model.hs +++ b/web/Model.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TemplateHaskell #-} module Model where import ClassyPrelude.Yesod diff --git a/web/Settings.hs b/web/Settings.hs index fb4310e..c0e8527 100644 --- a/web/Settings.hs +++ b/web/Settings.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} + -- | Settings are centralized, as much as possible, into this file. This -- includes database connection settings, static file locations, etc. -- In addition, you can configure a number of different aspects of Yesod diff --git a/web/Settings/StaticFiles.hs b/web/Settings/StaticFiles.hs index c8021d3..93d66c1 100644 --- a/web/Settings/StaticFiles.hs +++ b/web/Settings/StaticFiles.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TemplateHaskell #-} module Settings.StaticFiles where import Settings (appStaticDir, compileTimeAppSettings) diff --git a/web/hcompta-web.cabal b/web/hcompta-web.cabal index 6597125..13c86f3 100644 --- a/web/hcompta-web.cabal +++ b/web/hcompta-web.cabal @@ -31,11 +31,9 @@ library else ghc-options: -Wall -fwarn-tabs -O2 - extensions: CPP - DeriveDataTypeable + extensions: DeriveDataTypeable EmptyDataDecls FlexibleContexts - GADTs GeneralizedNewtypeDeriving MultiParamTypeClasses NoImplicitPrelude @@ -43,10 +41,7 @@ library OverloadedStrings QuasiQuotes RecordWildCards - TemplateHaskell TupleSections - TypeFamilies - ViewPatterns build-depends: base >= 4 && < 5 , aeson >= 0.6 && < 0.9 -- 2.47.2 From e28b00e9b1e16d72e5e11db5c6b026aa8862a535 Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Sun, 21 Jun 2015 16:46:07 +0200 Subject: [PATCH 15/16] Modif : {Balance.Amount_Sum => Amount.Sum}. --- cli/Hcompta/CLI/Command/Balance.hs | 48 ++--- cli/Hcompta/CLI/Format/Ledger.hs | 2 +- cli/Hcompta/CLI/Lang.hs | 38 +++- lib/Hcompta/Amount.hs | 128 ++++++++++++- lib/Hcompta/Balance.hs | 102 ---------- lib/Hcompta/Filter.hs | 20 +- lib/Hcompta/Format/Ledger.hs | 6 +- lib/Test/Main.hs | 296 ++++++++++++++--------------- 8 files changed, 333 insertions(+), 307 deletions(-) diff --git a/cli/Hcompta/CLI/Command/Balance.hs b/cli/Hcompta/CLI/Command/Balance.hs index 1cf915c..d56c8a6 100644 --- a/cli/Hcompta/CLI/Command/Balance.hs +++ b/cli/Hcompta/CLI/Command/Balance.hs @@ -160,19 +160,19 @@ run context args = do W.renderCompact False . toDoc (Context.lang context) in zipWith id - [ Table.column (title Lang.Message_Balance_debit) Table.Align_Right - , Table.column (title Lang.Message_Balance_credit) Table.Align_Right - , Table.column (title Lang.Message_Balance_total) Table.Align_Right - , Table.column (title Lang.Message_Account) Table.Align_Left + [ Table.column (title Lang.Message_Debit) Table.Align_Right + , Table.column (title Lang.Message_Credit) Table.Align_Right + , Table.column (title Lang.Message_Balance) Table.Align_Right + , Table.column (title Lang.Message_Account) Table.Align_Left ] $ - flip (write_by_accounts ctx) balance_by_account $ + write_by_accounts ctx balance_by_account $ zipWith (:) [ Table.Cell_Line '=' 0 , Table.Cell_Line '=' 0 , Table.Cell_Line '=' 0 , Table.Cell_Line ' ' 0 ] $ - write_by_amounts (repeat []) $ + flip write_by_amounts (repeat []) $ Data.Map.map Balance.unit_sum_amount balance_by_unit @@ -180,10 +180,10 @@ run context args = do ledger_balances :: Filter.Test_Bool (Filter.Test_Transaction Ledger.Transaction) -> Filter.Test_Bool (Filter.Test_Posting Ledger.Posting) - -> Filter.Test_Bool (Filter.Test_Balance (Account, Balance.Amount_Sum Amount)) + -> Filter.Test_Bool (Filter.Test_Balance (Account, Amount.Sum Amount)) -> [Ledger.Journal] - -> ( Balance.Expanded (Balance.Amount_Sum Amount) - , Balance.Balance_by_Unit (Balance.Amount_Sum Amount) Unit ) + -> ( Balance.Expanded (Amount.Sum Amount) + , Balance.Balance_by_Unit (Amount.Sum Amount) Unit ) ledger_balances transaction_filter posting_filter @@ -206,7 +206,7 @@ ledger_balances flip (foldr Balance.by_account) . map (\p -> ( Ledger.posting_account p - , Data.Map.map Balance.amount_sum (Ledger.posting_amounts p) + , Data.Map.map Amount.sum (Ledger.posting_amounts p) ) ) . filter_postings in @@ -233,12 +233,12 @@ ledger_balances write_by_accounts :: Ctx + -> Balance.Expanded (Amount.Sum Amount) -> [[Table.Cell]] - -> Balance.Expanded (Balance.Amount_Sum Amount) -> [[Table.Cell]] write_by_accounts ctx = let posting_type = Ledger.Posting_Type_Regular in - Lib.TreeMap.foldr_with_Path_and_Node + flip $ Lib.TreeMap.foldr_with_Path_and_Node (\account node balance rows -> do let descendants = Lib.TreeMap.nodes (Lib.TreeMap.node_descendants node) @@ -250,13 +250,13 @@ write_by_accounts ctx = || (Data.Map.null descendants && not (Data.Map.null (Data.Map.filter - (not . Amount.is_zero . Balance.amount_sum_balance) + (not . Amount.is_zero . Amount.sum_balance) (Balance.inclusive balance)))) -- NOTE: worth if account exclusive -- has at least a non-zero amount || not (Data.Map.null (Data.Map.filter - (not . Amount.is_zero . Balance.amount_sum_balance) + (not . Amount.is_zero . Amount.sum_balance) (Balance.exclusive balance))) -- NOTE: worth if account has at least more than -- one descendant account whose inclusive @@ -266,7 +266,7 @@ write_by_accounts ctx = ( maybe False ( not . Data.Foldable.all ( Amount.is_zero - . Balance.amount_sum_balance ) + . Amount.sum_balance ) . Balance.inclusive ) . Lib.TreeMap.node_value ) descendants) > 1 @@ -298,32 +298,32 @@ write_by_accounts ctx = let bal = Balance.inclusive balance in Data.Map.foldrWithKey (\unit amount acc -> - ( maybe Nothing Balance.amount_sum_positive $ Data.Map.lookup unit $ bal - , maybe Nothing Balance.amount_sum_negative $ Data.Map.lookup unit $ bal - , Balance.amount_sum_balance amount + ( maybe Nothing Amount.sum_positive $ Data.Map.lookup unit $ bal + , maybe Nothing Amount.sum_negative $ Data.Map.lookup unit $ bal + , Amount.sum_balance amount ) : acc ) [] $ bal ) write_by_amounts - :: [[Table.Cell]] - -> Data.Map.Map Unit (Balance.Amount_Sum Amount) + :: Data.Map.Map Unit (Amount.Sum Amount) + -> [[Table.Cell]] -> [[Table.Cell]] write_by_amounts = - foldr + flip $ foldr (\amount_sum -> zipWith (:) - [ let amt = Balance.amount_sum_positive amount_sum in + [ let amt = Amount.sum_positive amount_sum in Table.cell { Table.cell_content = maybe W.empty Ledger.Write.amount amt , Table.cell_width = maybe 0 Ledger.Write.amount_length amt } - , let amt = Balance.amount_sum_negative amount_sum in + , let amt = Amount.sum_negative amount_sum in Table.cell { Table.cell_content = maybe W.empty Ledger.Write.amount amt , Table.cell_width = maybe 0 Ledger.Write.amount_length amt } - , let amt = Balance.amount_sum_balance amount_sum in + , let amt = Amount.sum_balance amount_sum in Table.cell { Table.cell_content = Ledger.Write.amount amt , Table.cell_width = Ledger.Write.amount_length amt diff --git a/cli/Hcompta/CLI/Format/Ledger.hs b/cli/Hcompta/CLI/Format/Ledger.hs index 9819025..3eb2033 100644 --- a/cli/Hcompta/CLI/Format/Ledger.hs +++ b/cli/Hcompta/CLI/Format/Ledger.hs @@ -70,7 +70,7 @@ instance ToDoc Lang Ledger.Read.Error where [ toDoc lang msg , W.vsep $ Data.List.map (\Balance.Unit_Sum{Balance.unit_sum_amount} -> - let amt = Balance.amount_sum_balance unit_sum_amount in + let amt = Amount.sum_balance unit_sum_amount in toDoc lang $ Lang.Message_unit_sums_up_to_the_non_null_amount (Amount.unit amt) amt diff --git a/cli/Hcompta/CLI/Lang.hs b/cli/Hcompta/CLI/Lang.hs index fb13dc1..761c134 100644 --- a/cli/Hcompta/CLI/Lang.hs +++ b/cli/Hcompta/CLI/Lang.hs @@ -210,10 +210,14 @@ data Message | Message_sysunexpect_end_of_input {} | Message_unknown {} | Message_or {} - | Message_Balance_total {} - | Message_Balance_debit {} - | Message_Balance_credit {} + | Message_Balance {} + | Message_Debit {} + | Message_Credit {} + | Message_Total_debit {} + | Message_Total_credit {} | Message_Account {} + | Message_Date {} + | Message_Description {} instance ToDoc Lang Message where toDoc EN msg = case msg of @@ -253,14 +257,22 @@ instance ToDoc Lang Message where "unkown" Message_or -> "or" - Message_Balance_total -> + Message_Balance -> "Balance" - Message_Balance_debit -> + Message_Debit -> "Debit" - Message_Balance_credit -> + Message_Credit -> "Credit" + Message_Total_debit -> + "Total debit" + Message_Total_credit -> + "Total credit" Message_Account -> "Account" + Message_Date -> + "Date" + Message_Description -> + "Description" toDoc FR msg = case msg of Message_ERROR -> @@ -299,11 +311,19 @@ instance ToDoc Lang Message where "inconnu" Message_or -> "ou" - Message_Balance_total -> + Message_Balance -> "Solde" - Message_Balance_debit -> + Message_Debit -> "Débit" - Message_Balance_credit -> + Message_Credit -> "Crédit" + Message_Total_debit -> + "Total débit" + Message_Total_credit -> + "Total crédit" Message_Account -> "Compte" + Message_Date -> + "Date" + Message_Description -> + "Description" diff --git a/lib/Hcompta/Amount.hs b/lib/Hcompta/Amount.hs index 529fe1c..f324a19 100644 --- a/lib/Hcompta/Amount.hs +++ b/lib/Hcompta/Amount.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} @@ -55,16 +56,6 @@ instance Balance.Amount Amount where amount_null = (==) Quantity.zero . quantity amount_add = (+) amount_negate = negate - amount_positive a = - case compare (quantity a) Quantity.zero of - LT -> Nothing - EQ -> Nothing - _ -> Just a - amount_negative a = - case compare (quantity a) Quantity.zero of - GT -> Nothing - EQ -> Nothing - _ -> Just a -- | An 'Amount' is a partially valid 'Num' instance: -- @@ -312,3 +303,120 @@ from_List :: [Amount] -> Amount_by_Unit from_List amounts = Data.Map.fromListWith (flip (+)) $ -- NOTE: flip to propagate 'Style' first to last. Data.List.map assoc_by_unit amounts + +-- * Type 'Sum' + +-- ** Class 'Sumable' +class + ( Data (Sumable_Unit a) + , Data a + , Eq a + , Ord (Sumable_Unit a) + , Show (Sumable_Unit a) + , Show a + , Typeable (Sumable_Unit a) + , Typeable a + ) => Sumable a where + type Sumable_Unit a + -- sumable_add :: a -> a -> a + sumable_positive :: a -> Maybe a + sumable_negative :: a -> Maybe a + +instance Sumable Amount where + type Sumable_Unit Amount = Unit + -- sumable_add = (+) + sumable_positive a = + case compare (quantity a) Quantity.zero of + LT -> Nothing + EQ -> Nothing + _ -> Just a + sumable_negative a = + case compare (quantity a) Quantity.zero of + GT -> Nothing + EQ -> Nothing + _ -> Just a + +instance Sumable amount => Sumable (Sum amount) where + type Sumable_Unit (Sum amount) = Sumable_Unit amount + sumable_negative amt = + case amt of + Sum_Negative _ -> Just $ amt + Sum_Positive _ -> Nothing + Sum_Both n _ -> Just $ Sum_Negative n + sumable_positive amt = + case amt of + Sum_Negative _ -> Nothing + Sum_Positive _ -> Just $ amt + Sum_Both _ p -> Just $ Sum_Positive p + +-- | Sum separately keeping track of negative and positive 'amount's. +data Sum amount + = Sum_Negative amount + | Sum_Positive amount + | Sum_Both amount amount + deriving (Data, Eq, Show, Typeable) + +instance Balance.Amount a + => Balance.Amount (Sum a) where + type Amount_Unit (Sum a) = Balance.Amount_Unit a + amount_null amt = + case amt of + Sum_Negative n -> Balance.amount_null n + Sum_Positive p -> Balance.amount_null p + Sum_Both n p -> Balance.amount_null (Balance.amount_add n p) + amount_add a0 a1 = + case (a0, a1) of + (Sum_Negative n0, Sum_Negative n1) -> Sum_Negative (Balance.amount_add n0 n1) + (Sum_Negative n , Sum_Positive p) -> Sum_Both n p + (Sum_Negative n0, Sum_Both n1 p) -> Sum_Both (Balance.amount_add n0 n1) p + + (Sum_Positive p , Sum_Negative n) -> Sum_Both n p + (Sum_Positive p0, Sum_Positive p1) -> Sum_Positive (Balance.amount_add p0 p1) + (Sum_Positive p , Sum_Both n1 p1) -> Sum_Both n1 (Balance.amount_add p p1) + + (Sum_Both n0 p0, Sum_Negative p1) -> Sum_Both n0 (Balance.amount_add p0 p1) + (Sum_Both n0 p0, Sum_Positive p1) -> Sum_Both n0 (Balance.amount_add p0 p1) + (Sum_Both n0 p0, Sum_Both n1 p1) -> Sum_Both (Balance.amount_add n0 n1) (Balance.amount_add p0 p1) + amount_negate amt = + case amt of + Sum_Negative n -> Sum_Positive $ Balance.amount_negate n + Sum_Positive p -> Sum_Negative $ Balance.amount_negate p + Sum_Both n p -> Sum_Both (Balance.amount_negate p) (Balance.amount_negate n) + +sum + :: Sumable amount + => amount -> Sum amount +sum amt = + case ( sumable_negative amt + , sumable_positive amt ) of + (Just n, Nothing) -> Sum_Negative n + (Nothing, Just p) -> Sum_Positive p + (Just n, Just p) -> Sum_Both n p + (Nothing, Nothing) -> Sum_Both amt amt + +sum_negative + :: Balance.Amount amount + => Sum amount -> Maybe amount +sum_negative amt = + case amt of + Sum_Negative n -> Just n + Sum_Positive _ -> Nothing + Sum_Both n _ -> Just n + +sum_positive + :: Balance.Amount amount + => Sum amount -> Maybe amount +sum_positive amt = + case amt of + Sum_Negative _ -> Nothing + Sum_Positive p -> Just p + Sum_Both _ p -> Just p + +sum_balance + :: Balance.Amount amount + => Sum amount -> amount +sum_balance amt = + case amt of + Sum_Negative n -> n + Sum_Positive p -> p + Sum_Both n p -> Balance.amount_add n p diff --git a/lib/Hcompta/Balance.hs b/lib/Hcompta/Balance.hs index c089e0b..3665b74 100644 --- a/lib/Hcompta/Balance.hs +++ b/lib/Hcompta/Balance.hs @@ -39,25 +39,6 @@ class amount_null :: a -> Bool amount_add :: a -> a -> a amount_negate :: a -> a - amount_positive :: a -> Maybe a - amount_negative :: a -> Maybe a - -instance (Amount a, unit ~ Amount_Unit a) - => Amount (Map unit a) where - type Amount_Unit (Map unit a) = Amount_Unit a - amount_null = Data.Foldable.all amount_null - amount_add = Data.Map.unionWith amount_add - amount_negate = Data.Map.map amount_negate - amount_negative a = - let m = Data.Map.mapMaybe amount_negative a in - if Data.Map.null m - then Nothing - else Just m - amount_positive a = - let m = Data.Map.mapMaybe amount_positive a in - if Data.Map.null m - then Nothing - else Just m -- ** Class 'Posting' @@ -429,86 +410,3 @@ by_unit_of_expanded = let account = Lib.TreeMap.reverse $ Lib.TreeMap.path k p in by_unit (account, inclusive a) acc) bal m - --- * Type 'Amount_Sum' - --- | Sum separately keeping track of negative and positive 'amount's. -data Amount amount - => Amount_Sum amount - = Amount_Sum_Negative amount - | Amount_Sum_Positive amount - | Amount_Sum_Both amount amount - deriving (Data, Eq, Show, Typeable) - -instance Amount a => Amount (Amount_Sum a) where - type Amount_Unit (Amount_Sum a) = Amount_Unit a - amount_null amt = - case amt of - Amount_Sum_Negative n -> amount_null n - Amount_Sum_Positive p -> amount_null p - Amount_Sum_Both n p -> amount_null (amount_add n p) - amount_add a0 a1 = - case (a0, a1) of - (Amount_Sum_Negative n0, Amount_Sum_Negative n1) -> Amount_Sum_Negative (amount_add n0 n1) - (Amount_Sum_Negative n , Amount_Sum_Positive p) -> Amount_Sum_Both n p - (Amount_Sum_Negative n0, Amount_Sum_Both n1 p) -> Amount_Sum_Both (amount_add n0 n1) p - - (Amount_Sum_Positive p , Amount_Sum_Negative n) -> Amount_Sum_Both n p - (Amount_Sum_Positive p0, Amount_Sum_Positive p1) -> Amount_Sum_Positive (amount_add p0 p1) - (Amount_Sum_Positive p , Amount_Sum_Both n1 p1) -> Amount_Sum_Both n1 (amount_add p p1) - - (Amount_Sum_Both n0 p0, Amount_Sum_Negative p1) -> Amount_Sum_Both n0 (amount_add p0 p1) - (Amount_Sum_Both n0 p0, Amount_Sum_Positive p1) -> Amount_Sum_Both n0 (amount_add p0 p1) - (Amount_Sum_Both n0 p0, Amount_Sum_Both n1 p1) -> Amount_Sum_Both (amount_add n0 n1) (amount_add p0 p1) - amount_negate amt = - case amt of - Amount_Sum_Negative n -> Amount_Sum_Positive $ amount_negate n - Amount_Sum_Positive p -> Amount_Sum_Negative $ amount_negate p - Amount_Sum_Both n p -> Amount_Sum_Both (amount_negate p) (amount_negate n) - amount_negative amt = - case amt of - Amount_Sum_Negative _ -> Just $ amt - Amount_Sum_Positive _ -> Nothing - Amount_Sum_Both n _ -> Just $ Amount_Sum_Negative n - amount_positive amt = - case amt of - Amount_Sum_Negative _ -> Nothing - Amount_Sum_Positive _ -> Just $ amt - Amount_Sum_Both _ p -> Just $ Amount_Sum_Positive p - -amount_sum - :: Amount amount - => amount -> Amount_Sum amount -amount_sum amt = - case (amount_negative amt, amount_positive amt) of - (Just n, Nothing) -> Amount_Sum_Negative n - (Nothing, Just p) -> Amount_Sum_Positive p - (Just n, Just p) -> Amount_Sum_Both n p - (Nothing, Nothing) -> Amount_Sum_Both amt amt - -amount_sum_negative - :: Amount amount - => Amount_Sum amount -> Maybe amount -amount_sum_negative amt = - case amt of - Amount_Sum_Negative n -> Just n - Amount_Sum_Positive _ -> Nothing - Amount_Sum_Both n _ -> Just n - -amount_sum_positive - :: Amount amount - => Amount_Sum amount -> Maybe amount -amount_sum_positive amt = - case amt of - Amount_Sum_Negative _ -> Nothing - Amount_Sum_Positive p -> Just p - Amount_Sum_Both _ p -> Just p - -amount_sum_balance - :: Amount amount - => Amount_Sum amount -> amount -amount_sum_balance amt = - case amt of - Amount_Sum_Negative n -> n - Amount_Sum_Positive p -> p - Amount_Sum_Both n p -> amount_add n p diff --git a/lib/Hcompta/Filter.hs b/lib/Hcompta/Filter.hs index fc85c20..f7e1f12 100644 --- a/lib/Hcompta/Filter.hs +++ b/lib/Hcompta/Filter.hs @@ -73,11 +73,11 @@ instance Amount Amount.Amount where amount_unit = Amount.unit instance (Amount a, Balance.Amount a) - => Amount (Balance.Amount_Sum a) where - type Amount_Unit (Balance.Amount_Sum a) = Amount_Unit a - type Amount_Quantity (Balance.Amount_Sum a) = Amount_Quantity a - amount_quantity = amount_quantity . Balance.amount_sum_balance - amount_unit = amount_unit . Balance.amount_sum_balance + => Amount (Amount.Sum a) where + type Amount_Unit (Amount.Sum a) = Amount_Unit a + type Amount_Quantity (Amount.Sum a) = Amount_Quantity a + amount_quantity = amount_quantity . Amount.sum_balance + amount_unit = amount_unit . Amount.sum_balance -- ** Class 'Posting' @@ -108,12 +108,12 @@ class Amount (Balance_Amount b) balance_negative :: b -> Maybe (Balance_Amount b) instance (Amount a, Balance.Amount a) - => Balance (Account, Balance.Amount_Sum a) where - type Balance_Amount (Account, Balance.Amount_Sum a) = a + => Balance (Account, Amount.Sum a) where + type Balance_Amount (Account, Amount.Sum a) = a balance_account = fst - balance_amount = Balance.amount_sum_balance . snd - balance_positive = Balance.amount_sum_positive . snd - balance_negative = Balance.amount_sum_negative . snd + balance_amount = Amount.sum_balance . snd + balance_positive = Amount.sum_positive . snd + balance_negative = Amount.sum_negative . snd -- * Class 'Test' diff --git a/lib/Hcompta/Format/Ledger.hs b/lib/Hcompta/Format/Ledger.hs index 81b0e3e..745c393 100644 --- a/lib/Hcompta/Format/Ledger.hs +++ b/lib/Hcompta/Format/Ledger.hs @@ -133,11 +133,11 @@ posting acct = instance Balance.Posting Posting where - type Posting_Amount Posting = Balance.Amount_Sum Amount + type Posting_Amount Posting = Amount.Sum Amount posting_account = posting_account - posting_amounts = Data.Map.map Balance.amount_sum . posting_amounts + posting_amounts = Data.Map.map Amount.sum . posting_amounts posting_set_amounts amounts p = - p { posting_amounts=Data.Map.map Balance.amount_sum_balance amounts } + p { posting_amounts=Data.Map.map Amount.sum_balance amounts } instance Filter.Posting Posting where type Posting_Amount Posting = Amount diff --git a/lib/Test/Main.hs b/lib/Test/Main.hs index f449d0e..b727eb9 100644 --- a/lib/Test/Main.hs +++ b/lib/Test/Main.hs @@ -1175,13 +1175,13 @@ test_Hcompta = Balance.Balance { Balance.balance_by_account = Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + Data.List.map (id *** Data.Map.map Amount.sum) $ [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) ] , Balance.balance_by_unit = Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s)) [ Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.amount_sum $ Amount.usd $ 1 + { Balance.unit_sum_amount = Amount.sum $ Amount.usd $ 1 , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["A":|[]] } @@ -1204,17 +1204,17 @@ test_Hcompta = Lib.TreeMap.from_List const $ [ ( "A":|[] , Data.Map.fromListWith const $ - Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance s, s)) - [ Balance.Amount_Sum_Both + Data.List.map (\s -> (Amount.unit $ Amount.sum_balance s, s)) + [ Amount.Sum_Both (Amount.usd $ -1) (Amount.usd $ 1) ] ) ] , Balance.balance_by_unit = Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s)) [ Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.Amount_Sum_Both + { Balance.unit_sum_amount = Amount.Sum_Both (Amount.usd $ -1) (Amount.usd $ 1) , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) @@ -1237,18 +1237,18 @@ test_Hcompta = Balance.Balance { Balance.balance_by_account = Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + Data.List.map (id *** Data.Map.map Amount.sum) $ [ ("A":|[], Amount.from_List [ Amount.usd $ 1, Amount.eur $ -1 ]) ] , Balance.balance_by_unit = Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s)) [ Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.Amount_Sum_Positive (Amount.usd $ 1) + { Balance.unit_sum_amount = Amount.Sum_Positive (Amount.usd $ 1) , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["A":|[]] } , Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.Amount_Sum_Negative (Amount.eur $ -1) + { Balance.unit_sum_amount = Amount.Sum_Negative (Amount.eur $ -1) , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["A":|[]] } @@ -1269,15 +1269,15 @@ test_Hcompta = Balance.Balance { Balance.balance_by_account = Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + Data.List.map (id *** Data.Map.map Amount.sum) $ [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) , ("B":|[], Amount.from_List [ Amount.usd $ -1 ]) ] , Balance.balance_by_unit = Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s)) [ Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.Amount_Sum_Both + { Balance.unit_sum_amount = Amount.Sum_Both (Amount.usd $ -1) (Amount.usd $ 1) , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) @@ -1300,15 +1300,15 @@ test_Hcompta = Balance.Balance { Balance.balance_by_account = Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + Data.List.map (id *** Data.Map.map Amount.sum) $ [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) , ("B":|[], Amount.from_List [ Amount.usd $ 1 ]) ] , Balance.balance_by_unit = Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s)) [ Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.amount_sum $ Amount.usd $ 2 + { Balance.unit_sum_amount = Amount.sum $ Amount.usd $ 2 , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["A":|[], "B":|[]] } @@ -1331,22 +1331,22 @@ test_Hcompta = Lib.TreeMap.from_List const $ [ ("A":|[] , Data.Map.fromListWith const $ - Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance s, s)) - [ Balance.Amount_Sum_Both (Amount.usd $ -1) (Amount.usd $ 1) - , Balance.Amount_Sum_Both (Amount.eur $ -2) (Amount.eur $ 2) + Data.List.map (\s -> (Amount.unit $ Amount.sum_balance s, s)) + [ Amount.Sum_Both (Amount.usd $ -1) (Amount.usd $ 1) + , Amount.Sum_Both (Amount.eur $ -2) (Amount.eur $ 2) ] ) ] , Balance.balance_by_unit = Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s)) [ Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.Amount_Sum_Both (Amount.usd $ -1) (Amount.usd $ 1) + { Balance.unit_sum_amount = Amount.Sum_Both (Amount.usd $ -1) (Amount.usd $ 1) , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["A":|[]] } , Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.Amount_Sum_Both (Amount.eur $ -2) (Amount.eur $ 2) + { Balance.unit_sum_amount = Amount.Sum_Both (Amount.eur $ -2) (Amount.eur $ 2) , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["A":|[]] } @@ -1367,25 +1367,25 @@ test_Hcompta = Balance.Balance { Balance.balance_by_account = Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + Data.List.map (id *** Data.Map.map Amount.sum) $ [ ("A":|[], Amount.from_List [ Amount.usd $ 1, Amount.eur $ 2, Amount.gbp $ 3 ]) , ("B":|[], Amount.from_List [ Amount.usd $ -1, Amount.eur $ -2, Amount.gbp $ -3 ]) ] , Balance.balance_by_unit = Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s)) [ Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.Amount_Sum_Both (Amount.usd $ -1) (Amount.usd $ 1) + { Balance.unit_sum_amount = Amount.Sum_Both (Amount.usd $ -1) (Amount.usd $ 1) , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["A":|[], "B":|[]] } , Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.Amount_Sum_Both (Amount.eur $ -2) (Amount.eur $ 2) + { Balance.unit_sum_amount = Amount.Sum_Both (Amount.eur $ -2) (Amount.eur $ 2) , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["A":|[], "B":|[]] } , Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.Amount_Sum_Both (Amount.gbp $ -3) (Amount.gbp $ 3) + { Balance.unit_sum_amount = Amount.Sum_Both (Amount.gbp $ -3) (Amount.gbp $ 3) , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["A":|[], "B":|[]] } @@ -1402,13 +1402,13 @@ test_Hcompta = (Balance.Balance { Balance.balance_by_account = Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + Data.List.map (id *** Data.Map.map Amount.sum) $ [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) ] , Balance.balance_by_unit = Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s)) [ Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.amount_sum $ Amount.usd $ 1 + { Balance.unit_sum_amount = Amount.sum $ Amount.usd $ 1 , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["A":|[]] } @@ -1417,13 +1417,13 @@ test_Hcompta = (Balance.Balance { Balance.balance_by_account = Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + Data.List.map (id *** Data.Map.map Amount.sum) $ [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) ] , Balance.balance_by_unit = Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s)) [ Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.amount_sum $ Amount.usd $ 1 + { Balance.unit_sum_amount = Amount.sum $ Amount.usd $ 1 , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["A":|[]] } @@ -1433,13 +1433,13 @@ test_Hcompta = Balance.Balance { Balance.balance_by_account = Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + Data.List.map (id *** Data.Map.map Amount.sum) $ [ ("A":|[], Amount.from_List [ Amount.usd $ 2 ]) ] , Balance.balance_by_unit = Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s)) [ Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.amount_sum $ Amount.usd $ 2 + { Balance.unit_sum_amount = Amount.sum $ Amount.usd $ 2 , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["A":|[]] } @@ -1450,13 +1450,13 @@ test_Hcompta = (Balance.Balance { Balance.balance_by_account = Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + Data.List.map (id *** Data.Map.map Amount.sum) $ [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) ] , Balance.balance_by_unit = Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s)) [ Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.amount_sum $ Amount.usd $ 1 + { Balance.unit_sum_amount = Amount.sum $ Amount.usd $ 1 , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["A":|[]] } @@ -1465,13 +1465,13 @@ test_Hcompta = (Balance.Balance { Balance.balance_by_account = Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + Data.List.map (id *** Data.Map.map Amount.sum) $ [ ("B":|[], Amount.from_List [ Amount.usd $ 1 ]) ] , Balance.balance_by_unit = Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s)) [ Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.amount_sum $ Amount.usd $ 1 + { Balance.unit_sum_amount = Amount.sum $ Amount.usd $ 1 , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["B":|[]] } @@ -1481,14 +1481,14 @@ test_Hcompta = Balance.Balance { Balance.balance_by_account = Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + Data.List.map (id *** Data.Map.map Amount.sum) $ [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) , ("B":|[], Amount.from_List [ Amount.usd $ 1 ]) ] , Balance.balance_by_unit = Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s)) [ Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.amount_sum $ Amount.usd $ 2 + { Balance.unit_sum_amount = Amount.sum $ Amount.usd $ 2 , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["A":|[], "B":|[]] } @@ -1499,13 +1499,13 @@ test_Hcompta = (Balance.Balance { Balance.balance_by_account = Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + Data.List.map (id *** Data.Map.map Amount.sum) $ [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) ] , Balance.balance_by_unit = Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s)) [ Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.amount_sum $ Amount.usd $ 1 + { Balance.unit_sum_amount = Amount.sum $ Amount.usd $ 1 , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["A":|[]] } @@ -1514,13 +1514,13 @@ test_Hcompta = (Balance.Balance { Balance.balance_by_account = Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + Data.List.map (id *** Data.Map.map Amount.sum) $ [ ("B":|[], Amount.from_List [ Amount.eur $ 1 ]) ] , Balance.balance_by_unit = Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s)) [ Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.amount_sum $ Amount.eur $ 1 + { Balance.unit_sum_amount = Amount.sum $ Amount.eur $ 1 , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["B":|[]] } @@ -1530,19 +1530,19 @@ test_Hcompta = Balance.Balance { Balance.balance_by_account = Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + Data.List.map (id *** Data.Map.map Amount.sum) $ [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) , ("B":|[], Amount.from_List [ Amount.eur $ 1 ]) ] , Balance.balance_by_unit = Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s)) [ Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.amount_sum $ Amount.usd $ 1 + { Balance.unit_sum_amount = Amount.sum $ Amount.usd $ 1 , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["A":|[]] } , Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.amount_sum $ Amount.eur $ 1 + { Balance.unit_sum_amount = Amount.sum $ Amount.eur $ 1 , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["B":|[]] } @@ -1558,103 +1558,103 @@ test_Hcompta = , "A+$1 = A+$1" ~: Balance.expanded (Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + Data.List.map (id *** Data.Map.map Amount.sum) $ [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) ]) ~?= (Lib.TreeMap.from_List const $ [ ("A":|[], Balance.Account_Sum_Expanded { Balance.inclusive = - Data.Map.map Balance.amount_sum $ + Data.Map.map Amount.sum $ Amount.from_List [ Amount.usd $ 1 ] , Balance.exclusive = - Data.Map.map Balance.amount_sum $ + Data.Map.map Amount.sum $ Amount.from_List [ Amount.usd $ 1 ] }) ]) , "A/A+$1 = A+$1 A/A+$1" ~: Balance.expanded (Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + Data.List.map (id *** Data.Map.map Amount.sum) $ [ ("A":|["A"], Amount.from_List [ Amount.usd $ 1 ]) ]) ~?= (Lib.TreeMap.from_List const [ ("A":|[], Balance.Account_Sum_Expanded { Balance.inclusive = - Data.Map.map Balance.amount_sum $ + Data.Map.map Amount.sum $ Amount.from_List [ Amount.usd $ 1 ] , Balance.exclusive = - Data.Map.map Balance.amount_sum $ + Data.Map.map Amount.sum $ Amount.from_List [] }) , ("A":|["A"], Balance.Account_Sum_Expanded { Balance.inclusive = - Data.Map.map Balance.amount_sum $ + Data.Map.map Amount.sum $ Amount.from_List [ Amount.usd $ 1 ] , Balance.exclusive = - Data.Map.map Balance.amount_sum $ + Data.Map.map Amount.sum $ Amount.from_List [ Amount.usd $ 1 ] }) ]) , "A/B+$1 = A+$1 A/B+$1" ~: Balance.expanded (Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + Data.List.map (id *** Data.Map.map Amount.sum) $ [ ("A":|["B"], Amount.from_List [ Amount.usd $ 1 ]) ]) ~?= (Lib.TreeMap.from_List const [ ("A":|[], Balance.Account_Sum_Expanded { Balance.inclusive = - Data.Map.map Balance.amount_sum $ + Data.Map.map Amount.sum $ Amount.from_List [ Amount.usd $ 1 ] , Balance.exclusive = - Data.Map.map Balance.amount_sum $ + Data.Map.map Amount.sum $ Amount.from_List [] }) , ("A":|["B"], Balance.Account_Sum_Expanded { Balance.inclusive = - Data.Map.map Balance.amount_sum $ + Data.Map.map Amount.sum $ Amount.from_List [ Amount.usd $ 1 ] , Balance.exclusive = - Data.Map.map Balance.amount_sum $ + Data.Map.map Amount.sum $ Amount.from_List [ Amount.usd $ 1 ] }) ]) , "A/B/C+$1 = A+$1 A/B+$1 A/B/C+$1" ~: Balance.expanded (Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + Data.List.map (id *** Data.Map.map Amount.sum) $ [ ("A":|["B", "C"], Amount.from_List [ Amount.usd $ 1 ]) ]) ~?= (Lib.TreeMap.from_List const $ [ ("A":|[], Balance.Account_Sum_Expanded { Balance.inclusive = - Data.Map.map Balance.amount_sum $ + Data.Map.map Amount.sum $ Amount.from_List [ Amount.usd $ 1 ] , Balance.exclusive = - Data.Map.map Balance.amount_sum $ + Data.Map.map Amount.sum $ Amount.from_List [] }) , ("A":|["B"], Balance.Account_Sum_Expanded { Balance.inclusive = - Data.Map.map Balance.amount_sum $ + Data.Map.map Amount.sum $ Amount.from_List [ Amount.usd $ 1 ] , Balance.exclusive = - Data.Map.map Balance.amount_sum $ + Data.Map.map Amount.sum $ Amount.from_List [] }) , ("A":|["B", "C"], Balance.Account_Sum_Expanded { Balance.inclusive = - Data.Map.map Balance.amount_sum $ + Data.Map.map Amount.sum $ Amount.from_List [ Amount.usd $ 1 ] , Balance.exclusive = - Data.Map.map Balance.amount_sum $ + Data.Map.map Amount.sum $ Amount.from_List [ Amount.usd $ 1 ] }) ]) , "A+$1 A/B+$1 = A+$2 A/B+$1" ~: Balance.expanded (Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + Data.List.map (id *** Data.Map.map Amount.sum) $ [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) , ("A":|["B"], Amount.from_List [ Amount.usd $ 1 ]) ]) @@ -1662,25 +1662,25 @@ test_Hcompta = (Lib.TreeMap.from_List const [ ("A":|[], Balance.Account_Sum_Expanded { Balance.inclusive = - Data.Map.map Balance.amount_sum $ + Data.Map.map Amount.sum $ Amount.from_List [ Amount.usd $ 2 ] , Balance.exclusive = - Data.Map.map Balance.amount_sum $ + Data.Map.map Amount.sum $ Amount.from_List [ Amount.usd $ 1 ] }) , ("A":|["B"], Balance.Account_Sum_Expanded { Balance.inclusive = - Data.Map.map Balance.amount_sum $ + Data.Map.map Amount.sum $ Amount.from_List [ Amount.usd $ 1 ] , Balance.exclusive = - Data.Map.map Balance.amount_sum $ + Data.Map.map Amount.sum $ Amount.from_List [ Amount.usd $ 1 ] }) ]) , "A+$1 A/B+$1 A/B/C+$1 = A+$3 A/B+$2 A/B/C+$1" ~: Balance.expanded (Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + Data.List.map (id *** Data.Map.map Amount.sum) $ [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) , ("A":|["B"], Amount.from_List [ Amount.usd $ 1 ]) , ("A":|["B", "C"], Amount.from_List [ Amount.usd $ 1 ]) @@ -1689,33 +1689,33 @@ test_Hcompta = (Lib.TreeMap.from_List const [ ("A":|[], Balance.Account_Sum_Expanded { Balance.inclusive = - Data.Map.map Balance.amount_sum $ + Data.Map.map Amount.sum $ Amount.from_List [ Amount.usd $ 3 ] , Balance.exclusive = - Data.Map.map Balance.amount_sum $ + Data.Map.map Amount.sum $ Amount.from_List [ Amount.usd $ 1 ] }) , ("A":|["B"], Balance.Account_Sum_Expanded { Balance.inclusive = - Data.Map.map Balance.amount_sum $ + Data.Map.map Amount.sum $ Amount.from_List [ Amount.usd $ 2 ] , Balance.exclusive = - Data.Map.map Balance.amount_sum $ + Data.Map.map Amount.sum $ Amount.from_List [ Amount.usd $ 1 ] }) , ("A":|["B", "C"], Balance.Account_Sum_Expanded { Balance.inclusive = - Data.Map.map Balance.amount_sum $ + Data.Map.map Amount.sum $ Amount.from_List [ Amount.usd $ 1 ] , Balance.exclusive = - Data.Map.map Balance.amount_sum $ + Data.Map.map Amount.sum $ Amount.from_List [ Amount.usd $ 1 ] }) ]) , "A+$1 A/B+$1 A/B/C+$1 A/B/C/D+$1 = A+$4 A/B+$3 A/B/C+$2 A/B/C/D+$1" ~: Balance.expanded (Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + Data.List.map (id *** Data.Map.map Amount.sum) $ [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) , ("A":|["B"], Amount.from_List [ Amount.usd $ 1 ]) , ("A":|["B", "C"], Amount.from_List [ Amount.usd $ 1 ]) @@ -1725,41 +1725,41 @@ test_Hcompta = (Lib.TreeMap.from_List const [ ("A":|[], Balance.Account_Sum_Expanded { Balance.inclusive = - Data.Map.map Balance.amount_sum $ + Data.Map.map Amount.sum $ Amount.from_List [ Amount.usd $ 4 ] , Balance.exclusive = - Data.Map.map Balance.amount_sum $ + Data.Map.map Amount.sum $ Amount.from_List [ Amount.usd $ 1 ] }) , ("A":|["B"], Balance.Account_Sum_Expanded { Balance.inclusive = - Data.Map.map Balance.amount_sum $ + Data.Map.map Amount.sum $ Amount.from_List [ Amount.usd $ 3 ] , Balance.exclusive = - Data.Map.map Balance.amount_sum $ + Data.Map.map Amount.sum $ Amount.from_List [ Amount.usd $ 1 ] }) , ("A":|["B", "C"], Balance.Account_Sum_Expanded { Balance.inclusive = - Data.Map.map Balance.amount_sum $ + Data.Map.map Amount.sum $ Amount.from_List [ Amount.usd $ 2 ] , Balance.exclusive = - Data.Map.map Balance.amount_sum $ + Data.Map.map Amount.sum $ Amount.from_List [ Amount.usd $ 1 ] }) , ("A":|["B", "C", "D"], Balance.Account_Sum_Expanded { Balance.inclusive = - Data.Map.map Balance.amount_sum $ + Data.Map.map Amount.sum $ Amount.from_List [ Amount.usd $ 1 ] , Balance.exclusive = - Data.Map.map Balance.amount_sum $ + Data.Map.map Amount.sum $ Amount.from_List [ Amount.usd $ 1 ] }) ]) , "A+$1 A/B+$1 A/BB+$1 AA/B+$1 = A+$3 A/B+$1 A/BB+$1 AA+$1 AA/B+$1" ~: Balance.expanded (Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + Data.List.map (id *** Data.Map.map Amount.sum) $ [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) , ("A":|["B"], Amount.from_List [ Amount.usd $ 1 ]) , ("A":|["BB"], Amount.from_List [ Amount.usd $ 1 ]) @@ -1769,42 +1769,42 @@ test_Hcompta = (Lib.TreeMap.from_List const [ ("A":|[], Balance.Account_Sum_Expanded { Balance.inclusive = - Data.Map.map Balance.amount_sum $ + Data.Map.map Amount.sum $ Amount.from_List [ Amount.usd $ 3 ] , Balance.exclusive = - Data.Map.map Balance.amount_sum $ + Data.Map.map Amount.sum $ Amount.from_List [ Amount.usd $ 1 ] }) , ("A":|["B"], Balance.Account_Sum_Expanded { Balance.inclusive = - Data.Map.map Balance.amount_sum $ + Data.Map.map Amount.sum $ Amount.from_List [ Amount.usd $ 1 ] , Balance.exclusive = - Data.Map.map Balance.amount_sum $ + Data.Map.map Amount.sum $ Amount.from_List [ Amount.usd $ 1 ] }) , ("A":|["BB"], Balance.Account_Sum_Expanded { Balance.inclusive = - Data.Map.map Balance.amount_sum $ + Data.Map.map Amount.sum $ Amount.from_List [ Amount.usd $ 1 ] , Balance.exclusive = - Data.Map.map Balance.amount_sum $ + Data.Map.map Amount.sum $ Amount.from_List [ Amount.usd $ 1 ] }) , ("AA":|[], Balance.Account_Sum_Expanded { Balance.inclusive = - Data.Map.map Balance.amount_sum $ + Data.Map.map Amount.sum $ Amount.from_List [ Amount.usd $ 1 ] , Balance.exclusive = - Data.Map.map Balance.amount_sum $ + Data.Map.map Amount.sum $ Amount.from_List [] }) , ("AA":|["B"], Balance.Account_Sum_Expanded { Balance.inclusive = - Data.Map.map Balance.amount_sum $ + Data.Map.map Amount.sum $ Amount.from_List [ Amount.usd $ 1 ] , Balance.exclusive = - Data.Map.map Balance.amount_sum $ + Data.Map.map Amount.sum $ Amount.from_List [ Amount.usd $ 1 ] }) ]) @@ -1815,15 +1815,15 @@ test_Hcompta = Balance.Balance { Balance.balance_by_account = Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + Data.List.map (id *** Data.Map.map Amount.sum) $ [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) , ("B":|[], Amount.from_List []) ] , Balance.balance_by_unit = Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s)) [ Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.amount_sum $ Amount.usd $ 1 + { Balance.unit_sum_amount = Amount.sum $ Amount.usd $ 1 , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["A":|[]] } @@ -1832,9 +1832,9 @@ test_Hcompta = ~?= (Balance.Deviation $ Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s)) [ Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.amount_sum $ Amount.usd $ 1 + { Balance.unit_sum_amount = Amount.sum $ Amount.usd $ 1 , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["B":|[]] } @@ -1844,15 +1844,15 @@ test_Hcompta = Balance.Balance { Balance.balance_by_account = Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + Data.List.map (id *** Data.Map.map Amount.sum) $ [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) , ("B":|[], Amount.from_List [ Amount.usd $ 1 ]) ] , Balance.balance_by_unit = Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s)) [ Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.amount_sum $ Amount.usd $ 2 + { Balance.unit_sum_amount = Amount.sum $ Amount.usd $ 2 , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) [ "A":|[] , "B":|[] @@ -1863,9 +1863,9 @@ test_Hcompta = ~?= (Balance.Deviation $ Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s)) [ Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.amount_sum $ Amount.usd $ 2 + { Balance.unit_sum_amount = Amount.sum $ Amount.usd $ 2 , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) [ ] @@ -1885,14 +1885,14 @@ test_Hcompta = Balance.Balance { Balance.balance_by_account = Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + Data.List.map (id *** Data.Map.map Amount.sum) $ [ ("A":|[], Amount.from_List [ Amount.usd $ 0 ]) ] , Balance.balance_by_unit = Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s)) [ Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.amount_sum $ Amount.usd $ 0 + { Balance.unit_sum_amount = Amount.sum $ Amount.usd $ 0 , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["A":|[]] } @@ -1905,14 +1905,14 @@ test_Hcompta = Balance.Balance { Balance.balance_by_account = Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + Data.List.map (id *** Data.Map.map Amount.sum) $ [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) ] , Balance.balance_by_unit = Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s)) [ Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.amount_sum $ Amount.usd $ 1 + { Balance.unit_sum_amount = Amount.sum $ Amount.usd $ 1 , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["A":|[]] } @@ -1925,19 +1925,19 @@ test_Hcompta = Balance.Balance { Balance.balance_by_account = Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + Data.List.map (id *** Data.Map.map Amount.sum) $ [ ("A":|[], Amount.from_List [ Amount.usd $ 0, Amount.eur $ 0 ]) ] , Balance.balance_by_unit = Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s)) [ Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.amount_sum $ Amount.usd $ 0 + { Balance.unit_sum_amount = Amount.sum $ Amount.usd $ 0 , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["A":|[]] } , Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.amount_sum $ Amount.eur $ 0 + { Balance.unit_sum_amount = Amount.sum $ Amount.eur $ 0 , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["A":|[]] } @@ -1950,15 +1950,15 @@ test_Hcompta = Balance.Balance { Balance.balance_by_account = Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + Data.List.map (id *** Data.Map.map Amount.sum) $ [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) , ("B":|[], Amount.from_List [ Amount.usd $ -1 ]) ] , Balance.balance_by_unit = Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s)) [ Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.amount_sum $ Amount.usd $ 0 + { Balance.unit_sum_amount = Amount.sum $ Amount.usd $ 0 , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["A":|[], "B":|[]] } @@ -1971,15 +1971,15 @@ test_Hcompta = Balance.Balance { Balance.balance_by_account = Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + Data.List.map (id *** Data.Map.map Amount.sum) $ [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) , ("B":|[], Amount.from_List []) ] , Balance.balance_by_unit = Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s)) [ Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.amount_sum $ Amount.usd $ 1 + { Balance.unit_sum_amount = Amount.sum $ Amount.usd $ 1 , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["A":|[]] } @@ -1992,20 +1992,20 @@ test_Hcompta = Balance.Balance { Balance.balance_by_account = Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + Data.List.map (id *** Data.Map.map Amount.sum) $ [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) , ("B":|[], Amount.from_List [ Amount.eur $ 1 ]) ] , Balance.balance_by_unit = Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s)) [ Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.amount_sum $ Amount.usd $ 1 + { Balance.unit_sum_amount = Amount.sum $ Amount.usd $ 1 , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["A":|[]] } , Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.amount_sum $ Amount.eur $ 1 + { Balance.unit_sum_amount = Amount.sum $ Amount.eur $ 1 , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["B":|[]] } @@ -2018,20 +2018,20 @@ test_Hcompta = Balance.Balance { Balance.balance_by_account = Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + Data.List.map (id *** Data.Map.map Amount.sum) $ [ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) , ("B":|[], Amount.from_List [ Amount.usd $ -1, Amount.eur $ 1 ]) ] , Balance.balance_by_unit = Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s)) [ Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.amount_sum $ Amount.usd $ 0 + { Balance.unit_sum_amount = Amount.sum $ Amount.usd $ 0 , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["A":|[], "B":|[]] } , Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.amount_sum $ Amount.eur $ 1 + { Balance.unit_sum_amount = Amount.sum $ Amount.eur $ 1 , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["B":|[]] } @@ -2044,25 +2044,25 @@ test_Hcompta = Balance.Balance { Balance.balance_by_account = Lib.TreeMap.from_List const $ - Data.List.map (id *** Data.Map.map Balance.amount_sum) $ + Data.List.map (id *** Data.Map.map Amount.sum) $ [ ("A":|[], Amount.from_List [ Amount.usd $ 1, Amount.eur $ 2, Amount.gbp $ 3 ]) , ("B":|[], Amount.from_List [ Amount.usd $ -1, Amount.eur $ -2, Amount.gbp $ -3 ]) ] , Balance.balance_by_unit = Data.Map.fromList $ - Data.List.map (\s -> (Amount.unit $ Balance.amount_sum_balance $ Balance.unit_sum_amount s, s)) + Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s)) [ Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.amount_sum $ Amount.usd $ 0 + { Balance.unit_sum_amount = Amount.sum $ Amount.usd $ 0 , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["A":|[], "B":|[]] } , Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.amount_sum $ Amount.eur $ 0 + { Balance.unit_sum_amount = Amount.sum $ Amount.eur $ 0 , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["A":|[], "B":|[]] } , Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.amount_sum $ Amount.gbp $ 0 + { Balance.unit_sum_amount = Amount.sum $ Amount.gbp $ 0 , Balance.unit_sum_accounts = Data.Map.fromList $ Data.List.map (,()) ["A":|[], "B":|[]] } @@ -2113,7 +2113,7 @@ test_Hcompta = ~?= (Left [ Balance.Unit_Sum - { Balance.unit_sum_amount = Balance.amount_sum $ Amount.usd $ 2 + { Balance.unit_sum_amount = Amount.sum $ Amount.usd $ 2 , Balance.unit_sum_accounts = Data.Map.fromList []} ]) , "{A+$1 B-$1 B-1€}" ~: -- 2.47.2 From 4c198a188a234e3c6435f585141610228a0fbbf0 Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Tue, 23 Jun 2015 17:04:59 +0200 Subject: [PATCH 16/16] Ajout : GL (General Ledger). --- cli/Hcompta/CLI.hs | 1 - cli/Hcompta/CLI/Command.hs | 8 +- cli/Hcompta/CLI/Command/Add.hs | 1 - cli/Hcompta/CLI/Command/Balance.hs | 67 +- cli/Hcompta/CLI/Command/GL.hs | 292 +++++++++ cli/Hcompta/CLI/Command/Register.hs | 1 - cli/Hcompta/CLI/Command/Stats.hs | 1 - cli/Hcompta/CLI/Lang.hs | 12 +- cli/hcompta-cli.cabal | 2 +- lib/Hcompta/Amount.hs | 63 +- lib/Hcompta/Amount/Write.hs | 157 +++++ lib/Hcompta/Balance.hs | 61 +- lib/Hcompta/Date/Read.hs | 8 +- lib/Hcompta/Date/Write.hs | 68 ++ lib/Hcompta/Filter.hs | 71 ++- lib/Hcompta/Filter/Read.hs | 47 ++ lib/Hcompta/Format.hs | 1 - lib/Hcompta/Format/Ledger.hs | 54 +- lib/Hcompta/Format/Ledger/Write.hs | 212 +------ lib/Hcompta/GL.hs | 247 ++++++++ lib/Hcompta/Lib/TreeMap.hs | 68 ++ lib/Test/Main.hs | 922 ++++++++++++++-------------- lib/hcompta-lib.cabal | 5 +- 23 files changed, 1614 insertions(+), 755 deletions(-) delete mode 100644 cli/Hcompta/CLI.hs delete mode 100644 cli/Hcompta/CLI/Command/Add.hs create mode 100644 cli/Hcompta/CLI/Command/GL.hs delete mode 100644 cli/Hcompta/CLI/Command/Register.hs delete mode 100644 cli/Hcompta/CLI/Command/Stats.hs create mode 100644 lib/Hcompta/Amount/Write.hs create mode 100644 lib/Hcompta/Date/Write.hs delete mode 100644 lib/Hcompta/Format.hs create mode 100644 lib/Hcompta/GL.hs diff --git a/cli/Hcompta/CLI.hs b/cli/Hcompta/CLI.hs deleted file mode 100644 index 6563efb..0000000 --- a/cli/Hcompta/CLI.hs +++ /dev/null @@ -1 +0,0 @@ -module Hcompta.CLI where diff --git a/cli/Hcompta/CLI/Command.hs b/cli/Hcompta/CLI/Command.hs index 107c180..d3d8bd5 100644 --- a/cli/Hcompta/CLI/Command.hs +++ b/cli/Hcompta/CLI/Command.hs @@ -13,15 +13,16 @@ import System.Environment (getProgName) import System.Exit (exitWith, ExitCode(..)) import qualified System.IO as IO -import Hcompta.CLI.Context (Context) import qualified Hcompta.CLI.Args as Args import qualified Hcompta.CLI.Command.Balance as Command.Balance -import qualified Hcompta.CLI.Command.Print as Command.Print +import qualified Hcompta.CLI.Command.GL as Command.GL +import qualified Hcompta.CLI.Command.Print as Command.Print +import Hcompta.CLI.Context (Context) import qualified Hcompta.CLI.Context as Context import qualified Hcompta.CLI.Lang as Lang import qualified Hcompta.CLI.Write as Write -import qualified Hcompta.Lib.Leijen as W import Hcompta.Lib.Leijen ((<>)) +import qualified Hcompta.Lib.Leijen as W usage :: IO String usage = do @@ -87,6 +88,7 @@ run context cmd args = case cmd of "print" -> Command.Print.run context args "balance" -> Command.Balance.run context args + "gl" -> Command.GL.run context args _ -> usage >>= Write.fatal context . ((W.text "unknown command: " <> (W.text $ TL.pack cmd) <> W.line) <>) . W.text . TL.pack diff --git a/cli/Hcompta/CLI/Command/Add.hs b/cli/Hcompta/CLI/Command/Add.hs deleted file mode 100644 index 82e1069..0000000 --- a/cli/Hcompta/CLI/Command/Add.hs +++ /dev/null @@ -1 +0,0 @@ -module Hcompta.Cli.Command.Add where diff --git a/cli/Hcompta/CLI/Command/Balance.hs b/cli/Hcompta/CLI/Command/Balance.hs index d56c8a6..b2b42c3 100644 --- a/cli/Hcompta/CLI/Command/Balance.hs +++ b/cli/Hcompta/CLI/Command/Balance.hs @@ -26,6 +26,11 @@ import System.Exit (exitWith, ExitCode(..)) import qualified System.IO as IO -- import Text.Show.Pretty (ppShow) +import Hcompta.Account (Account) +import Hcompta.Amount (Amount) +import qualified Hcompta.Amount as Amount +import qualified Hcompta.Amount.Write as Amount.Write +import Hcompta.Amount.Unit (Unit) import qualified Hcompta.Balance as Balance import qualified Hcompta.CLI.Args as Args import qualified Hcompta.CLI.Context as Context @@ -33,21 +38,15 @@ import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger import qualified Hcompta.CLI.Lang as Lang import qualified Hcompta.CLI.Lib.Leijen.Table as Table import qualified Hcompta.CLI.Write as Write +import qualified Hcompta.Filter as Filter +import qualified Hcompta.Filter.Read as Filter.Read import qualified Hcompta.Format.Ledger as Ledger import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal import qualified Hcompta.Format.Ledger.Read as Ledger.Read import qualified Hcompta.Format.Ledger.Write as Ledger.Write -import qualified Hcompta.Lib.TreeMap as Lib.TreeMap --- import qualified Hcompta.Lib.Foldable as Lib.Foldable -import qualified Hcompta.Lib.Leijen as W import Hcompta.Lib.Leijen (toDoc, ToDoc(..)) --- import qualified Hcompta.Account as Account -import Hcompta.Account (Account) -import qualified Hcompta.Amount as Amount -import Hcompta.Amount (Amount) -import Hcompta.Amount.Unit (Unit) -import qualified Hcompta.Filter as Filter -import qualified Hcompta.Filter.Read as Filter.Read +import qualified Hcompta.Lib.Leijen as W +import qualified Hcompta.Lib.TreeMap as Lib.TreeMap data Ctx = Ctx @@ -87,15 +86,6 @@ options = (ReqArg (\s _context ctx -> do return $ ctx{ctx_input=s:ctx_input ctx}) "FILE") "read data from given file, can be use multiple times" - , Option "t" ["transaction-filter"] - (ReqArg (\s context ctx -> do - ctx_transaction_filter <- - liftIO $ Filter.Read.read Filter.Read.test_transaction s - >>= \f -> case f of - Left ko -> Write.fatal context $ ko - Right ok -> return ok - return $ ctx{ctx_transaction_filter}) "FILTER") - "filter on posting" , Option "p" ["posting-filter"] (ReqArg (\s context ctx -> do ctx_posting_filter <- @@ -104,18 +94,27 @@ options = Left ko -> Write.fatal context $ ko Right ok -> return ok return $ ctx{ctx_posting_filter}) "FILTER") - "filter on balance" + "filter at posting level" , Option "" ["redundant"] (OptArg (\arg context ctx -> do - redundant <- case arg of + ctx_redundant <- case arg of Nothing -> return $ True Just "yes" -> return $ True Just "no" -> return $ False Just _ -> Write.fatal context $ W.text "--redundant option expects \"yes\", or \"no\" as value" - return $ ctx{ctx_redundant=redundant}) + return $ ctx{ctx_redundant}) "[yes|no]") "also print accounts with zero amount or the same amounts than its ascending account" + , Option "t" ["transaction-filter"] + (ReqArg (\s context ctx -> do + ctx_transaction_filter <- + liftIO $ Filter.Read.read Filter.Read.test_transaction s + >>= \f -> case f of + Left ko -> Write.fatal context $ ko + Right ok -> return ok + return $ ctx{ctx_transaction_filter}) "FILTER") + "filter at transaction level" ] run :: Context.Context -> [String] -> IO () @@ -277,16 +276,16 @@ write_by_accounts ctx = (\(amount_positive, amount_negative, amount) -> zipWith (:) [ Table.cell - { Table.cell_content = maybe W.empty Ledger.Write.amount amount_positive - , Table.cell_width = maybe 0 Ledger.Write.amount_length amount_positive + { Table.cell_content = maybe W.empty Amount.Write.amount amount_positive + , Table.cell_width = maybe 0 Amount.Write.amount_length amount_positive } , Table.cell - { Table.cell_content = maybe W.empty Ledger.Write.amount amount_negative - , Table.cell_width = maybe 0 Ledger.Write.amount_length amount_negative + { Table.cell_content = maybe W.empty Amount.Write.amount amount_negative + , Table.cell_width = maybe 0 Amount.Write.amount_length amount_negative } , Table.cell - { Table.cell_content = Ledger.Write.amount $ amount - , Table.cell_width = Ledger.Write.amount_length $ amount + { Table.cell_content = Amount.Write.amount $ amount + , Table.cell_width = Amount.Write.amount_length $ amount } , Table.cell { Table.cell_content = Ledger.Write.account posting_type account @@ -315,18 +314,18 @@ write_by_amounts = zipWith (:) [ let amt = Amount.sum_positive amount_sum in Table.cell - { Table.cell_content = maybe W.empty Ledger.Write.amount amt - , Table.cell_width = maybe 0 Ledger.Write.amount_length amt + { Table.cell_content = maybe W.empty Amount.Write.amount amt + , Table.cell_width = maybe 0 Amount.Write.amount_length amt } , let amt = Amount.sum_negative amount_sum in Table.cell - { Table.cell_content = maybe W.empty Ledger.Write.amount amt - , Table.cell_width = maybe 0 Ledger.Write.amount_length amt + { Table.cell_content = maybe W.empty Amount.Write.amount amt + , Table.cell_width = maybe 0 Amount.Write.amount_length amt } , let amt = Amount.sum_balance amount_sum in Table.cell - { Table.cell_content = Ledger.Write.amount amt - , Table.cell_width = Ledger.Write.amount_length amt + { Table.cell_content = Amount.Write.amount amt + , Table.cell_width = Amount.Write.amount_length amt } , Table.cell { Table.cell_content = W.empty diff --git a/cli/Hcompta/CLI/Command/GL.hs b/cli/Hcompta/CLI/Command/GL.hs new file mode 100644 index 0000000..4e301eb --- /dev/null +++ b/cli/Hcompta/CLI/Command/GL.hs @@ -0,0 +1,292 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +module Hcompta.CLI.Command.GL where + +import Control.Applicative ((<$>)) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Except (runExceptT) +import qualified Data.Either +import qualified Data.Foldable +import Data.Foldable (foldr) +import Data.Functor.Compose (Compose(..)) +import qualified Data.List +import qualified Data.Map.Strict as Data.Map +import qualified Data.Sequence +import qualified Data.Text as Text +import qualified Data.Text.Lazy as TL +import Prelude hiding (foldr) +import System.Console.GetOpt + ( ArgDescr(..) + , OptDescr(..) + , usageInfo + ) +import System.Environment as Env (getProgName) +import System.Exit (exitWith, ExitCode(..)) +import qualified System.IO as IO + +import Hcompta.Account (Account) +import Hcompta.Amount (Amount) +import qualified Hcompta.Amount as Amount +import qualified Hcompta.Amount.Write as Amount.Write +import qualified Hcompta.CLI.Args as Args +import qualified Hcompta.CLI.Context as Context +import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger +import qualified Hcompta.CLI.Lang as Lang +import qualified Hcompta.CLI.Lib.Leijen.Table as Table +import qualified Hcompta.CLI.Write as Write +import Hcompta.Date (Date) +import qualified Hcompta.Date.Write as Date.Write +import qualified Hcompta.Filter as Filter +import qualified Hcompta.Filter.Read as Filter.Read +import qualified Hcompta.Format.Ledger as Ledger +import qualified Hcompta.Format.Ledger.Read as Ledger.Read +import qualified Hcompta.Format.Ledger.Write as Ledger.Write +import Hcompta.Lib.Leijen (toDoc, ToDoc(..)) +import qualified Hcompta.Lib.Leijen as W +import qualified Hcompta.Lib.TreeMap as Lib.TreeMap +import Hcompta.GL (GL(..)) +import qualified Hcompta.GL as GL + +data Ctx + = Ctx + { ctx_input :: [FilePath] + , ctx_transaction_filter :: Filter.Test_Bool (Filter.Test_Transaction Ledger.Transaction) + , ctx_posting_filter :: Filter.Test_Bool (Filter.Test_Posting Ledger.Posting) + } deriving (Show) + +nil :: Ctx +nil = + Ctx + { ctx_input = [] + , ctx_transaction_filter = Filter.Any + , ctx_posting_filter = Filter.Any + } + +usage :: IO String +usage = do + bin <- Env.getProgName + return $ unlines $ + [ "SYNTAX " + , " "++bin++" gl [option..]" + , "" + , usageInfo "OPTIONS" options + ] + +options :: Args.Options Ctx +options = + [ Option "h" ["help"] + (NoArg (\_context _ctx -> do + usage >>= IO.hPutStr IO.stderr + exitWith ExitSuccess)) + "show this help" + , Option "i" ["input"] + (ReqArg (\s _context ctx -> do + return $ ctx{ctx_input=s:ctx_input ctx}) "FILE") + "read data from given file, can be use multiple times" + , Option "p" ["posting-filter"] + (ReqArg (\s context ctx -> do + ctx_posting_filter <- + liftIO $ Filter.Read.read Filter.Read.test_posting s + >>= \f -> case f of + Left ko -> Write.fatal context $ ko + Right ok -> return ok + return $ ctx{ctx_posting_filter}) "FILTER") + "filter at posting level" + , Option "t" ["transaction-filter"] + (ReqArg (\s context ctx -> do + ctx_transaction_filter <- + liftIO $ Filter.Read.read Filter.Read.test_transaction s + >>= \f -> case f of + Left ko -> Write.fatal context $ ko + Right ok -> return ok + return $ ctx{ctx_transaction_filter}) "FILTER") + "filter at transaction level" + ] + +run :: Context.Context -> [String] -> IO () +run context args = do + (ctx, text_filters) <- Args.parse context usage options (nil, args) + read_journals <- do + CLI.Ledger.paths context $ ctx_input ctx + >>= do + mapM $ \path -> do + liftIO $ runExceptT $ Ledger.Read.file path + >>= \x -> case x of + Left ko -> return $ Left (path, ko) + Right ok -> return $ Right ok + >>= return . Data.Either.partitionEithers + case read_journals of + (errs@(_:_), _journals) -> + (flip mapM_) errs $ \(_path, err) -> do + Write.fatal context $ err + ([], journals) -> do + gl_filter <- + foldr Filter.And Filter.Any <$> do + (flip mapM) text_filters $ \s -> + liftIO $ Filter.Read.read + Filter.Read.test_gl + s + >>= \f -> case f of + Left ko -> Write.fatal context $ ko + Right ok -> return ok + Write.debug context $ "transaction_filter: " ++ show (ctx_transaction_filter ctx) + Write.debug context $ "posting_filter: " ++ show (ctx_posting_filter ctx) + Write.debug context $ "gl_filter: " ++ show gl_filter + let gl = + ledger_gl + (ctx_transaction_filter ctx) + (ctx_posting_filter ctx) + gl_filter + journals + style_color <- Write.with_color context IO.stdout + W.displayIO IO.stdout $ + W.renderPretty style_color 1.0 maxBound $ do + toDoc () $ + let title = + TL.toStrict . W.displayT . + W.renderCompact False . + toDoc (Context.lang context) in + zipWith id + [ Table.column (title Lang.Message_Account) Table.Align_Left + , Table.column (title Lang.Message_Date) Table.Align_Left + , Table.column (title Lang.Message_Debit) Table.Align_Right + , Table.column (title Lang.Message_Credit) Table.Align_Right + , Table.column (title Lang.Message_Total_debit) Table.Align_Right + , Table.column (title Lang.Message_Total_credit) Table.Align_Right + , Table.column (title Lang.Message_Balance) Table.Align_Right + , Table.column (title Lang.Message_Description) Table.Align_Left + ] $ + write_gl gl (repeat []) + +ledger_gl + :: Filter.Test_Bool (Filter.Test_Transaction Ledger.Transaction) + -> Filter.Test_Bool (Filter.Test_Posting Ledger.Posting) + -> Filter.Test_Bool (Filter.Test_GL (Account, Date, Amount.Sum Amount, Amount.Sum Amount)) + -> [Ledger.Journal] + -> GL Ledger.Transaction +ledger_gl + transaction_filter + posting_filter + gl_filter + journals = + let gl = + Data.Foldable.foldl + (\jr j -> + Data.Foldable.foldl + (\tr t -> + case Filter.test transaction_filter t of + False -> tr + True -> + GL.general_ledger + t{ Ledger.transaction_postings = + Data.Map.map + (Data.Foldable.foldMap + (\p -> + Data.Map.foldrWithKey + (\u a -> (:) p{Ledger.posting_amounts=Data.Map.singleton u a}) + [] + (Ledger.posting_amounts p) + ) + ) $ + Data.Map.mapMaybe + (\ps -> case Data.List.filter (Filter.test posting_filter) ps of + [] -> Nothing + x -> Just x) + (Ledger.transaction_postings t) + } + tr + ) + jr (Compose $ Ledger.journal_transactions j) + ) + GL.nil + journals in + GL.GL $ + Lib.TreeMap.map_Maybe_with_Path + (\acct expanded_lines -> + case Data.Map.mapMaybeWithKey + (\date seq_lines -> + case Data.Foldable.foldMap + (\line@GL.GL_Line + { GL.gl_line_transaction = _t + , GL.gl_line_posting = p + , GL.gl_line_sum = s + } -> + if Filter.test gl_filter + ( acct + , date + , Amount.sum $ snd $ Data.Map.elemAt 0 $ Ledger.posting_amounts p + , snd . Data.Map.elemAt 0 <$> s + ) + then Data.Sequence.singleton line + else Data.Sequence.empty + ) seq_lines of + m | Data.Sequence.null m -> Nothing + m -> Just m + ) + (GL.inclusive expanded_lines) of + m | Data.Map.null m -> Nothing + m -> Just m + ) $ + GL.expanded gl + +write_gl + :: GL Ledger.Transaction + -> [[Table.Cell]] + -> [[Table.Cell]] +write_gl (GL gl) = + flip (Lib.TreeMap.foldr_with_Path + (\acct -> + flip $ Data.Map.foldrWithKey + (\date -> + flip (Data.Foldable.foldr + (\GL.GL_Line + { GL.gl_line_transaction = t + , GL.gl_line_posting = p + , GL.gl_line_sum = s + } -> + flip (Data.Map.foldrWithKey + (\unit amt -> do + let ptype = Ledger.Posting_Type_Regular + let descr = Ledger.transaction_description t + zipWith (:) + [ Table.cell + { Table.cell_content = Ledger.Write.account ptype acct + , Table.cell_width = Ledger.Write.account_length ptype acct + } + , Table.cell + { Table.cell_content = Date.Write.date date + , Table.cell_width = Date.Write.date_length date + } + , Table.cell + { Table.cell_content = maybe W.empty Amount.Write.amount (Amount.sumable_positive amt) + , Table.cell_width = maybe 0 Amount.Write.amount_length (Amount.sumable_positive amt) + } + , Table.cell + { Table.cell_content = maybe W.empty Amount.Write.amount (Amount.sumable_negative amt) + , Table.cell_width = maybe 0 Amount.Write.amount_length (Amount.sumable_negative amt) + } + , Table.cell + { Table.cell_content = maybe W.empty Amount.Write.amount (maybe Nothing (Data.Map.lookup unit) $ Amount.sum_positive s) + , Table.cell_width = maybe 0 Amount.Write.amount_length (maybe Nothing (Data.Map.lookup unit) $ Amount.sum_positive s) + } + , Table.cell + { Table.cell_content = maybe W.empty Amount.Write.amount (maybe Nothing (Data.Map.lookup unit) $ Amount.sum_negative s) + , Table.cell_width = maybe 0 Amount.Write.amount_length (maybe Nothing (Data.Map.lookup unit) $ Amount.sum_negative s) + } + , Table.cell + { Table.cell_content = maybe W.empty Amount.Write.amount (Data.Map.lookup unit $ Amount.sum_balance s) + , Table.cell_width = maybe 0 Amount.Write.amount_length (Data.Map.lookup unit $ Amount.sum_balance s) + } + , Table.cell + { Table.cell_content = toDoc () descr + , Table.cell_width = Text.length descr + } + ] + )) + (Ledger.posting_amounts p) + )) + ) + )) + gl diff --git a/cli/Hcompta/CLI/Command/Register.hs b/cli/Hcompta/CLI/Command/Register.hs deleted file mode 100644 index a6febf6..0000000 --- a/cli/Hcompta/CLI/Command/Register.hs +++ /dev/null @@ -1 +0,0 @@ -module Hcompta.Cli.Command.Register where diff --git a/cli/Hcompta/CLI/Command/Stats.hs b/cli/Hcompta/CLI/Command/Stats.hs deleted file mode 100644 index 442b0d7..0000000 --- a/cli/Hcompta/CLI/Command/Stats.hs +++ /dev/null @@ -1 +0,0 @@ -module Hcompta.Cli.Command.Stats where diff --git a/cli/Hcompta/CLI/Lang.hs b/cli/Hcompta/CLI/Lang.hs index 761c134..52207d5 100644 --- a/cli/Hcompta/CLI/Lang.hs +++ b/cli/Hcompta/CLI/Lang.hs @@ -5,25 +5,25 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Hcompta.CLI.Lang where -import Prelude hiding (error) import Control.Monad (liftM) import qualified Data.List import Data.Maybe (catMaybes, fromMaybe) import qualified Data.Text import Data.Text (Text) import qualified Data.Text.Lazy as TL +import Prelude hiding (error) import System.Environment (getEnvironment) import System.IO.Memoize (once) import qualified Text.Parsec as Parsec import qualified Text.Parsec.Error as Parsec.Error -import qualified Hcompta.Format.Ledger.Write as Ledger.Write -import Hcompta.Amount.Unit (Unit) import Hcompta.Amount (Amount) +import Hcompta.Amount.Unit (Unit) +import qualified Hcompta.Amount.Write as Amount.Write import qualified Hcompta.Date.Read as Date.Read import qualified Hcompta.Filter.Read as Filter.Read -import qualified Hcompta.Lib.Leijen as W import Hcompta.Lib.Leijen (ToDoc(..), (<>)) +import qualified Hcompta.Lib.Leijen as W import qualified Hcompta.Lib.Parsec as Lib.Parsec data Lang @@ -73,9 +73,9 @@ instance ToDoc m Int where instance ToDoc m Integer where toDoc _ = W.integer instance ToDoc m Unit where - toDoc _ = Ledger.Write.unit + toDoc _ = Amount.Write.unit instance ToDoc m Amount where - toDoc _ = Ledger.Write.amount + toDoc _ = Amount.Write.amount instance ToDoc Lang Date.Read.Error where toDoc FR e = case e of diff --git a/cli/hcompta-cli.cabal b/cli/hcompta-cli.cabal index 71edea6..733ef8f 100644 --- a/cli/hcompta-cli.cabal +++ b/cli/hcompta-cli.cabal @@ -54,10 +54,10 @@ Library ghc-options: -ddump-ds -ddump-simple -ddump-splices -ddump-stg -ddump-to-file -- default-language: Haskell2010 exposed-modules: - Hcompta.CLI Hcompta.CLI.Args Hcompta.CLI.Command Hcompta.CLI.Command.Balance + Hcompta.CLI.Command.GL Hcompta.CLI.Command.Print Hcompta.CLI.Context Hcompta.CLI.Format.Ledger diff --git a/lib/Hcompta/Amount.hs b/lib/Hcompta/Amount.hs index f324a19..f3164e5 100644 --- a/lib/Hcompta/Amount.hs +++ b/lib/Hcompta/Amount.hs @@ -10,10 +10,12 @@ module Hcompta.Amount where import Data.Data import qualified Data.List import qualified Data.Map.Strict as Data.Map +import Data.Map.Strict (Map) import qualified Data.Foldable import Data.Typeable () import qualified Hcompta.Balance as Balance +import qualified Hcompta.GL as GL import qualified Hcompta.Amount.Quantity as Quantity import qualified Hcompta.Amount.Style as Style import qualified Hcompta.Amount.Unit as Unit @@ -57,6 +59,20 @@ instance Balance.Amount Amount where amount_add = (+) amount_negate = negate +instance Balance.Amount (Map Unit Amount) where + type Amount_Unit (Map Unit Amount) = Unit + amount_null = Data.Foldable.all ((==) Quantity.zero . quantity) + amount_add = Data.Map.unionWith (+) + amount_negate = Data.Map.map negate + +instance GL.Amount Amount where + type Amount_Unit Amount = Unit + amount_add = (+) + +instance GL.Amount (Map Unit Amount) where + type Amount_Unit (Map Unit Amount) = Unit + amount_add = Data.Map.unionWith (+) + -- | An 'Amount' is a partially valid 'Num' instance: -- -- * (+) operator requires both operand to have the same 'Unit' (homogeneity constraint). @@ -336,6 +352,20 @@ instance Sumable Amount where EQ -> Nothing _ -> Just a +instance Sumable (Map Unit Amount) where + type Sumable_Unit (Map Unit Amount) = Unit + -- sumable_add = (+) + sumable_positive a = + let r = Data.Map.mapMaybe sumable_positive a in + if Data.Map.null r + then Nothing + else Just r + sumable_negative a = + let r = Data.Map.mapMaybe sumable_negative a in + if Data.Map.null r + then Nothing + else Just r + instance Sumable amount => Sumable (Sum amount) where type Sumable_Unit (Sum amount) = Sumable_Unit amount sumable_negative amt = @@ -356,6 +386,11 @@ data Sum amount | Sum_Both amount amount deriving (Data, Eq, Show, Typeable) +instance Functor Sum where + fmap f (Sum_Negative a) = Sum_Negative (f a) + fmap f (Sum_Positive a) = Sum_Positive (f a) + fmap f (Sum_Both a0 a1) = Sum_Both (f a0) (f a1) + instance Balance.Amount a => Balance.Amount (Sum a) where type Amount_Unit (Sum a) = Balance.Amount_Unit a @@ -374,7 +409,7 @@ instance Balance.Amount a (Sum_Positive p0, Sum_Positive p1) -> Sum_Positive (Balance.amount_add p0 p1) (Sum_Positive p , Sum_Both n1 p1) -> Sum_Both n1 (Balance.amount_add p p1) - (Sum_Both n0 p0, Sum_Negative p1) -> Sum_Both n0 (Balance.amount_add p0 p1) + (Sum_Both n0 p0, Sum_Negative n) -> Sum_Both (Balance.amount_add n0 n) p0 (Sum_Both n0 p0, Sum_Positive p1) -> Sum_Both n0 (Balance.amount_add p0 p1) (Sum_Both n0 p0, Sum_Both n1 p1) -> Sum_Both (Balance.amount_add n0 n1) (Balance.amount_add p0 p1) amount_negate amt = @@ -383,6 +418,22 @@ instance Balance.Amount a Sum_Positive p -> Sum_Negative $ Balance.amount_negate p Sum_Both n p -> Sum_Both (Balance.amount_negate p) (Balance.amount_negate n) +instance GL.Amount (Sum (Map Unit Amount)) where + type Amount_Unit (Sum (Map Unit Amount)) = Unit + amount_add a0 a1 = + case (a0, a1) of + (Sum_Negative n0, Sum_Negative n1) -> Sum_Negative (GL.amount_add n0 n1) + (Sum_Negative n , Sum_Positive p) -> Sum_Both n p + (Sum_Negative n0, Sum_Both n1 p) -> Sum_Both (GL.amount_add n0 n1) p + + (Sum_Positive p , Sum_Negative n) -> Sum_Both n p + (Sum_Positive p0, Sum_Positive p1) -> Sum_Positive (GL.amount_add p0 p1) + (Sum_Positive p , Sum_Both n1 p1) -> Sum_Both n1 (GL.amount_add p p1) + + (Sum_Both n0 p0, Sum_Negative n) -> Sum_Both (GL.amount_add n0 n) p0 + (Sum_Both n0 p0, Sum_Positive p1) -> Sum_Both n0 (GL.amount_add p0 p1) + (Sum_Both n0 p0, Sum_Both n1 p1) -> Sum_Both (GL.amount_add n0 n1) (GL.amount_add p0 p1) + sum :: Sumable amount => amount -> Sum amount @@ -395,8 +446,7 @@ sum amt = (Nothing, Nothing) -> Sum_Both amt amt sum_negative - :: Balance.Amount amount - => Sum amount -> Maybe amount + :: Sum amount -> Maybe amount sum_negative amt = case amt of Sum_Negative n -> Just n @@ -404,8 +454,7 @@ sum_negative amt = Sum_Both n _ -> Just n sum_positive - :: Balance.Amount amount - => Sum amount -> Maybe amount + :: Sum amount -> Maybe amount sum_positive amt = case amt of Sum_Negative _ -> Nothing @@ -413,10 +462,10 @@ sum_positive amt = Sum_Both _ p -> Just p sum_balance - :: Balance.Amount amount + :: GL.Amount amount => Sum amount -> amount sum_balance amt = case amt of Sum_Negative n -> n Sum_Positive p -> p - Sum_Both n p -> Balance.amount_add n p + Sum_Both n p -> GL.amount_add n p diff --git a/lib/Hcompta/Amount/Write.hs b/lib/Hcompta/Amount/Write.hs new file mode 100644 index 0000000..505696b --- /dev/null +++ b/lib/Hcompta/Amount/Write.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +module Hcompta.Amount.Write where + +import Data.Decimal (DecimalRaw(..)) +import qualified Data.List +import Data.Maybe (fromMaybe) +import qualified Data.Text.Lazy as TL +import qualified Data.Text as Text +import qualified Hcompta.Lib.Leijen as W +import Hcompta.Lib.Leijen (Doc, (<>)) +import GHC.Exts (Int(..)) +import GHC.Integer.Logarithms (integerLogBase#) + +import qualified Hcompta.Amount as Amount +import Hcompta.Amount (Amount) +import qualified Hcompta.Amount.Quantity as Quantity +import Hcompta.Amount.Quantity (Quantity) +import qualified Hcompta.Amount.Style as Amount.Style +import qualified Hcompta.Amount.Unit as Unit +import Hcompta.Amount.Unit (Unit) + +-- * Write 'Amount' + +amount :: Amount -> Doc +amount Amount.Amount + { Amount.quantity=qty + , Amount.style = sty@(Amount.Style.Style + { Amount.Style.unit_side + , Amount.Style.unit_spaced + }) + , Amount.unit=unit_ + } = do + case unit_side of + Just Amount.Style.Side_Left -> + (unit unit_) + <> (case unit_spaced of { Just True | unit_ /= "" -> W.space; _ -> W.empty }) + _ -> W.empty + <> quantity sty qty + <> case unit_side of + (Just Amount.Style.Side_Right) -> + (case unit_spaced of { Just True | unit_ /= "" -> W.space; _ -> W.empty }) + <> unit unit_ + Nothing -> + (case unit_spaced of { Just True | unit_ /= "" -> W.space; _ -> W.empty }) + <> unit unit_ + _ -> W.empty + +unit :: Unit -> Doc +unit = W.yellow . W.strict_text . Unit.text + +quantity :: Amount.Style -> Quantity -> Doc +quantity Amount.Style.Style + { Amount.Style.fractioning + , Amount.Style.grouping_integral + , Amount.Style.grouping_fractional + , Amount.Style.precision + } qty = do + let Decimal e n = Quantity.round precision qty + let num = Prelude.show $ abs $ n + let sign = W.bold $ W.yellow $ W.strict_text (if n < 0 then "-" else "") + case e == 0 || precision == 0 of + True -> sign <> do W.bold $ W.blue $ (W.strict_text $ Text.pack num) + False -> do + let num_len = length num + let padded = + Data.List.concat + [ replicate (fromIntegral e + 1 - num_len) '0' + , num + , replicate (fromIntegral precision - fromIntegral e) '0' + ] + let (int, frac) = Data.List.splitAt (max 1 (num_len - fromIntegral precision)) padded + let default_fractioning = + Data.List.head $ + del_grouping_sep grouping_integral $ + del_grouping_sep grouping_fractional $ + ['.', ','] + sign <> do + W.bold $ W.blue $ do + W.text (TL.pack $ maybe id (\g -> reverse . group g . reverse) grouping_integral $ int) <> do + (W.yellow $ W.char (fromMaybe default_fractioning fractioning)) <> do + W.text (TL.pack $ maybe id group grouping_fractional frac) + where + group :: Amount.Style.Grouping -> [Char] -> [Char] + group (Amount.Style.Grouping sep sizes_) = + Data.List.concat . reverse . + Data.List.map reverse . fst . + Data.List.foldl + (flip (\digit -> \x -> case x of + ([], sizes) -> ([[digit]], sizes) + (digits:groups, []) -> ((digit:digits):groups, []) + (digits:groups, curr_sizes@(size:sizes)) -> + if length digits < size + then ( (digit:digits):groups, curr_sizes) + else ([digit]:[sep]:digits:groups, if sizes == [] then curr_sizes else sizes) + )) + ([], sizes_) + del_grouping_sep grouping = + case grouping of + Just (Amount.Style.Grouping sep _) -> Data.List.delete sep + _ -> id + +-- ** Measure 'Amount' + +amount_length :: Amount -> Int +amount_length Amount.Amount + { Amount.quantity = qty + , Amount.style = sty@(Amount.Style.Style + { Amount.Style.unit_spaced + }) + , Amount.unit = unit_ + } = do + Unit.length unit_ + + (case unit_spaced of { Just True | unit_ /= "" -> 1; _ -> 0 }) + + quantity_length sty qty + +quantity_length :: Amount.Style -> Quantity -> Int +quantity_length Amount.Style.Style + { Amount.Style.grouping_integral + , Amount.Style.grouping_fractional + , Amount.Style.precision + } qty = + let Decimal e n = Quantity.round precision qty in + let sign_len = if n < 0 then 1 else 0 in + let fractioning_len = if e > 0 then 1 else 0 in + let num_len = if n == 0 then 0 else (1 +) $ I# (integerLogBase# 10 (abs n)) in + let pad_left_len = max 0 (fromIntegral e + 1 - num_len) in + let pad_right_len = max 0 (fromIntegral precision - fromIntegral e) in + let padded_len = pad_left_len + num_len + pad_right_len in + let int_len = max 1 (num_len - fromIntegral precision) in + let frac_len = max 0 (padded_len - int_len) in + ( sign_len + + fractioning_len + + padded_len + + maybe 0 (group int_len) grouping_integral + + maybe 0 (group frac_len) grouping_fractional + ) + where + group :: Int -> Amount.Style.Grouping -> Int + group num_len (Amount.Style.Grouping _sep sizes_) = + if num_len <= 0 + then 0 + else loop 0 num_len sizes_ + where + loop :: Int -> Int -> [Int] -> Int + loop pad len = + \x -> case x of + [] -> 0 + sizes@[size] -> + let l = len - size in + if l <= 0 then pad + else loop (pad + 1) l sizes + size:sizes -> + let l = len - size in + if l <= 0 then pad + else loop (pad + 1) l sizes diff --git a/lib/Hcompta/Balance.hs b/lib/Hcompta/Balance.hs index 3665b74..1db4ebb 100644 --- a/lib/Hcompta/Balance.hs +++ b/lib/Hcompta/Balance.hs @@ -26,19 +26,15 @@ import Hcompta.Account (Account) -- ** Class 'Amount' class - ( Data (Amount_Unit a) - , Data a - , Eq a - , Ord (Amount_Unit a) - , Show (Amount_Unit a) - , Show a + ( Data (Amount_Unit a) + , Ord (Amount_Unit a) + , Show (Amount_Unit a) , Typeable (Amount_Unit a) - , Typeable a ) => Amount a where type Amount_Unit a - amount_null :: a -> Bool - amount_add :: a -> a -> a - amount_negate :: a -> a + amount_null :: a -> Bool + amount_add :: a -> a -> a + amount_negate :: a -> a -- ** Class 'Posting' @@ -66,10 +62,17 @@ data Amount amount => Balance amount { balance_by_account :: Balance_by_Account amount (Amount_Unit amount) , balance_by_unit :: Balance_by_Unit amount (Amount_Unit amount) } -deriving instance Amount amount => Data (Balance amount) -deriving instance Amount amount => Eq (Balance amount) -deriving instance Amount amount => Show (Balance amount) -deriving instance Typeable1 Balance -- FIXME: use 'Typeable' when dropping GHC-7.6 support +deriving instance ( Amount amount + , Data amount + ) => Data (Balance amount) +deriving instance ( Amount amount + , Eq amount + ) => Eq (Balance amount) +deriving instance ( Amount amount + , Show amount + ) => Show (Balance amount) +deriving instance Typeable1 Balance + -- FIXME: use 'Typeable' when dropping GHC-7.6 support type Balance_by_Account amount unit = TreeMap Account.Name @@ -227,10 +230,17 @@ union_by_unit = newtype Amount amount => Deviation amount = Deviation (Balance_by_Unit amount (Amount_Unit amount)) -deriving instance Amount amount => Data (Deviation amount) -deriving instance Amount amount => Eq (Deviation amount) -deriving instance Amount amount => Show (Deviation amount) -deriving instance Typeable1 Deviation -- FIXME: use 'Typeable' when dropping GHC-7.6 support +deriving instance ( Amount amount + , Data amount + ) => Data (Deviation amount) +deriving instance ( Amount amount + , Eq amount + ) => Eq (Deviation amount) +deriving instance ( Amount amount + , Show amount + ) => Show (Deviation amount) +deriving instance Typeable1 Deviation + -- FIXME: use 'Typeable' when dropping GHC-7.6 support -- | Return the 'balance_by_unit' of the given 'Balance' with: -- @@ -357,10 +367,17 @@ data Amount amount => Account_Sum_Expanded amount { exclusive :: Map (Amount_Unit amount) amount , inclusive :: Map (Amount_Unit amount) amount -- ^ 'amount_add' folded over 'exclusive' and 'inclusive' of 'Lib.TreeMap.node_descendants' } -deriving instance Amount amount => Data (Account_Sum_Expanded amount) -deriving instance Amount amount => Eq (Account_Sum_Expanded amount) -deriving instance Amount amount => Show (Account_Sum_Expanded amount) -deriving instance Typeable1 Account_Sum_Expanded -- FIXME: use 'Typeable' when dropping GHC-7.6 support +deriving instance ( Amount amount + , Data amount + ) => Data (Account_Sum_Expanded amount) +deriving instance ( Amount amount + , Eq amount + ) => Eq (Account_Sum_Expanded amount) +deriving instance ( Amount amount + , Show amount + ) => Show (Account_Sum_Expanded amount) +deriving instance Typeable1 Account_Sum_Expanded + -- FIXME: use 'Typeable' when dropping GHC-7.6 support -- | Return the given 'Balance_by_Account' with: -- diff --git a/lib/Hcompta/Date/Read.hs b/lib/Hcompta/Date/Read.hs index 07c8694..80a161c 100644 --- a/lib/Hcompta/Date/Read.hs +++ b/lib/Hcompta/Date/Read.hs @@ -29,7 +29,7 @@ data Error | Error_invalid_time_of_day (Int, Int, Integer) deriving (Eq, Show) --- | Read a 'Date' in @[YYYY/]MM/DD [HH:MM[:SS][TZ]]@ format. +-- | Read a 'Date' in @[YYYY\/]MM\/DD [HH:MM[:SS][TZ]]@ format. date :: (Stream s (R.Error_State e m) Char, Monad m) => (Error -> e) -> Maybe Integer -> ParsecT s u (R.Error_State e m) Date @@ -74,15 +74,15 @@ date err def_year = (do return $ Time.localTimeToUTC tz (Time.LocalTime day tod) ) "date" --- | Parse the year, month and day separator: '/' or '-'. +-- | Parse the year, month and day separator: "/" or "-". date_separator :: Stream s m Char => ParsecT s u m Char date_separator = R.satisfy (\c -> c == '/' || c == '-') --- | Parse the hour, minute and second separator: ':'. +-- | Parse the hour, minute and second separator: ":". hour_separator :: Stream s m Char => ParsecT s u m Char hour_separator = R.char ':' --- | Parse either '-' into 'negate', or '+' or '' into 'id'. +-- | Parse either "-" into 'negate', or "+" or "" into 'id'. sign :: (Stream s m Char, Num i) => ParsecT s u m (i -> i) sign = (R.char '-' >> return negate) diff --git a/lib/Hcompta/Date/Write.hs b/lib/Hcompta/Date/Write.hs new file mode 100644 index 0000000..5ff4c22 --- /dev/null +++ b/lib/Hcompta/Date/Write.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE MagicHash #-} +module Hcompta.Date.Write where + +import Data.Fixed (showFixed) +import qualified Data.Text as Text +import qualified Data.Time.LocalTime as Time +import GHC.Exts (Int(..)) +import GHC.Integer.Logarithms (integerLogBase#) + +import qualified Hcompta.Lib.Leijen as W +import Hcompta.Lib.Leijen (Doc, (<>)) +import qualified Hcompta.Date as Date +import Hcompta.Date (Date) + +-- * Write 'Date' + +date :: Date -> Doc +date dat = do + let (y, mo, d) = Date.gregorian dat + (if y == 0 then W.empty else W.integer y <> sep '/') <> do + int2 mo <> do + sep '/' <> int2 d <> do + (case Date.tod dat of + Time.TimeOfDay 0 0 0 -> W.empty + Time.TimeOfDay h m s -> + W.space <> int2 h <> do + sep ':' <> int2 m <> do + (case s of + 0 -> W.empty + _ -> sep ':' <> do + (if s < 10 then W.char '0' else W.empty) <> do + W.strict_text $ Text.pack $ showFixed True s)) + -- (case tz_min of + -- 0 -> W.empty + -- _ | tz_name /= "" -> W.space <> do W.strict_text $ Text.pack tz_name + -- _ -> W.space <> do W.strict_text $ Text.pack $ Time.timeZoneOffsetString tz) + where + int2 :: Int -> Doc + int2 i = if i < 10 then W.char '0' <> W.int i else W.int i + sep :: Char -> Doc + sep = W.bold . W.dullblack . W.char + +-- ** Measure 'Date' + +date_length :: Date -> Int +date_length dat = do + let (y, _, _) = Date.gregorian dat + (case y of + 0 -> 0 + _ -> + (if y < 0 then 1 else 0) -- sign + + (1 + (I# (integerLogBase# 10 (abs y)))) -- year + + 1) -- / + + 2 -- month + + 1 -- / + + 2 -- dom + + (case Date.tod dat of + Time.TimeOfDay 0 0 0 -> 0 + Time.TimeOfDay _ _ s -> + 1 -- _ + + 2 -- hour + + 1 -- : + + 2 -- min + + (case s of + 0 -> 0 + _ -> 1 + 2 -- : sec + ) + ) diff --git a/lib/Hcompta/Filter.hs b/lib/Hcompta/Filter.hs index f7e1f12..de3c5fc 100644 --- a/lib/Hcompta/Filter.hs +++ b/lib/Hcompta/Filter.hs @@ -38,6 +38,7 @@ import qualified Hcompta.Account as Account import Hcompta.Account (Account) -- import qualified Hcompta.Date as Date import qualified Hcompta.Balance as Balance +import qualified Hcompta.GL as GL -- * Requirements' interface @@ -72,7 +73,7 @@ instance Amount Amount.Amount where amount_quantity = Amount.quantity amount_unit = Amount.unit -instance (Amount a, Balance.Amount a) +instance (Amount a, GL.Amount a) => Amount (Amount.Sum a) where type Amount_Unit (Amount.Sum a) = Amount_Unit a type Amount_Quantity (Amount.Sum a) = Amount_Quantity a @@ -111,10 +112,40 @@ instance (Amount a, Balance.Amount a) => Balance (Account, Amount.Sum a) where type Balance_Amount (Account, Amount.Sum a) = a balance_account = fst - balance_amount = Amount.sum_balance . snd + balance_amount (_, amt) = + case amt of + Amount.Sum_Negative n -> n + Amount.Sum_Positive p -> p + Amount.Sum_Both n p -> Balance.amount_add n p balance_positive = Amount.sum_positive . snd balance_negative = Amount.sum_negative . snd +-- ** Class 'GL' + +class Amount (GL_Amount r) + => GL r where + type GL_Amount r + register_account :: r -> Account + register_date :: r -> Date + register_amount_positive :: r -> Maybe (GL_Amount r) + register_amount_negative :: r -> Maybe (GL_Amount r) + register_amount_balance :: r -> GL_Amount r + register_sum_positive :: r -> Maybe (GL_Amount r) + register_sum_negative :: r -> Maybe (GL_Amount r) + register_sum_balance :: r -> GL_Amount r + +instance (Amount a, GL.Amount a) + => GL (Account, Date, Amount.Sum a, Amount.Sum a) where + type GL_Amount (Account, Date, Amount.Sum a, Amount.Sum a) = a + register_account (x, _, _, _) = x + register_date (_, x, _, _) = x + register_amount_positive (_, _, x, _) = Amount.sum_positive x + register_amount_negative (_, _, x, _) = Amount.sum_negative x + register_amount_balance (_, _, x, _) = Amount.sum_balance x + register_sum_positive (_, _, _, x) = Amount.sum_positive x + register_sum_negative (_, _, _, x) = Amount.sum_negative x + register_sum_balance (_, _, _, x) = Amount.sum_balance x + -- * Class 'Test' class Test p x where @@ -429,3 +460,39 @@ instance Balance b test (Test_Balance_Negative f) b = Data.Foldable.any (test f) $ balance_negative b + +-- ** Type 'Test_GL' + +data GL r + => Test_GL r + = Test_GL_Account Test_Account + | Test_GL_Amount_Positive (Test_Amount (GL_Amount r)) + | Test_GL_Amount_Negative (Test_Amount (GL_Amount r)) + | Test_GL_Amount_Balance (Test_Amount (GL_Amount r)) + | Test_GL_Sum_Positive (Test_Amount (GL_Amount r)) + | Test_GL_Sum_Negative (Test_Amount (GL_Amount r)) + | Test_GL_Sum_Balance (Test_Amount (GL_Amount r)) + deriving (Typeable) +deriving instance GL r => Eq (Test_GL r) +deriving instance GL r => Show (Test_GL r) + +instance GL r + => Test (Test_GL r) r where + test (Test_GL_Account f) r = + test f $ register_account r + test (Test_GL_Amount_Positive f) r = + Data.Foldable.any (test f) $ + register_amount_positive r + test (Test_GL_Amount_Negative f) r = + Data.Foldable.any (test f) $ + register_amount_negative r + test (Test_GL_Amount_Balance f) r = + test f $ register_amount_balance r + test (Test_GL_Sum_Positive f) r = + Data.Foldable.any (test f) $ + register_sum_positive r + test (Test_GL_Sum_Negative f) r = + Data.Foldable.any (test f) $ + register_sum_negative r + test (Test_GL_Sum_Balance f) r = + test f $ register_sum_balance r diff --git a/lib/Hcompta/Filter/Read.hs b/lib/Hcompta/Filter/Read.hs index 76e95a1..1d77aa2 100644 --- a/lib/Hcompta/Filter/Read.hs +++ b/lib/Hcompta/Filter/Read.hs @@ -306,6 +306,12 @@ test_account = do R.many1_separated (test_account_section make_test_text) $ R.char account_section_sep +test_account_operator + :: Stream s m Char + => ParsecT s u m String +test_account_operator = + test_text_operator + -- ** Read 'Test_Amount' test_amount :: Stream s m Char @@ -576,3 +582,44 @@ test_balance_terms = ( Filter.Test_Balance_Account <$> test_account ) ] + +-- ** Read 'Test_GL' +test_gl + :: (Stream s m Char, Filter.GL t, GL_Amount t ~ Amount) + => ParsecT s Context m (Test_Bool (Test_GL t)) +test_gl = + Data.Foldable.foldr Filter.And Filter.Any <$> + do R.many $ + R.spaces + >> R.lookAhead R.anyToken + >> test_bool test_gl_terms + +test_gl_terms + :: (Stream s m Char, Filter.GL t, GL_Amount t ~ Amount) + => [ParsecT s Context m (ParsecT s Context m (Test_GL t))] +test_gl_terms = + [ jump [ "account" ] test_account_operator + ( Filter.Test_GL_Account + <$> test_account ) + , jump [ "debit" ] test_amount_operator + ( Filter.Test_GL_Amount_Positive + <$> test_amount ) + , jump [ "credit" ] test_amount_operator + ( Filter.Test_GL_Amount_Negative + <$> test_amount ) + , jump [ "amount" ] test_amount_operator + ( Filter.Test_GL_Amount_Balance + <$> test_amount ) + , jump [ "total_debit" ] test_amount_operator + ( Filter.Test_GL_Sum_Positive + <$> test_amount ) + , jump [ "total_credit" ] test_amount_operator + ( Filter.Test_GL_Sum_Negative + <$> test_amount ) + , jump [ "total" ] test_amount_operator + ( Filter.Test_GL_Sum_Balance + <$> test_amount ) + , return + ( Filter.Test_GL_Account + <$> test_account ) + ] diff --git a/lib/Hcompta/Format.hs b/lib/Hcompta/Format.hs deleted file mode 100644 index 8a4c8f4..0000000 --- a/lib/Hcompta/Format.hs +++ /dev/null @@ -1 +0,0 @@ -module Hcompta.Format where diff --git a/lib/Hcompta/Format/Ledger.hs b/lib/Hcompta/Format/Ledger.hs index 745c393..e237417 100644 --- a/lib/Hcompta/Format/Ledger.hs +++ b/lib/Hcompta/Format/Ledger.hs @@ -1,28 +1,30 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} module Hcompta.Format.Ledger where import Data.Data (Data(..)) -import Data.Typeable (Typeable) -import Text.Parsec.Pos (SourcePos, initialPos) -import qualified Data.Map.Strict as Data.Map -import Data.Map.Strict (Map) +import Data.Functor.Compose (Compose(..)) import qualified Data.List as Data.List +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Data.Map +import Data.Text (Text) import qualified Data.Time.Clock as Time import qualified Data.Time.Clock.POSIX as Time +import Data.Typeable (Typeable) +import Text.Parsec.Pos (SourcePos, initialPos) -import Hcompta.Lib.Parsec () -import qualified Hcompta.Balance as Balance -import Hcompta.Date (Date) -import qualified Hcompta.Date as Date import Hcompta.Account (Account) --- import qualified Hcompta.Account as Account import Hcompta.Amount (Amount) import qualified Hcompta.Amount as Amount +import qualified Hcompta.Balance as Balance +import Hcompta.Date (Date) +import qualified Hcompta.Date as Date import qualified Hcompta.Filter as Filter -import Data.Text (Text) +import Hcompta.Lib.Parsec () +import qualified Hcompta.GL as GL type Code = Text type Description = Text @@ -90,6 +92,25 @@ instance Filter.Transaction Transaction where transaction_postings = transaction_postings transaction_tags = transaction_tags +{- +instance Filter.GL (GL.GL_Line Transaction) where + type GL_Amount (GL.GL_Line Transaction) = Amount + register_account = GL.posting_account . GL.register_line_posting + register_date = GL.transaction_date . GL.register_line_transaction + register_amount_positive = Amount.sum_positive . GL.posting_amount . GL.register_line_posting + register_amount_negative = Amount.sum_negative . GL.posting_amount . GL.register_line_posting + register_amount_balance = Amount.sum_balance . GL.posting_amount . GL.register_line_posting + register_sum_positive = Amount.sum_positive . GL.register_line_sum + register_sum_negative = Amount.sum_negative . GL.register_line_sum + register_sum_balance = Amount.sum_balance . GL.register_line_sum +-} + +instance GL.Transaction Transaction where + type Transaction_Posting Transaction = Posting + type Transaction_Postings Transaction = Compose (Map Account) [] + transaction_date = fst . transaction_dates + transaction_postings = Compose . transaction_postings + type Transaction_by_Date = Data.Map.Map Date [Transaction] @@ -144,16 +165,21 @@ instance Filter.Posting Posting where posting_account = posting_account posting_amounts = posting_amounts +instance GL.Posting Posting where + type Posting_Amount Posting = Amount.Sum (Map Amount.Unit Amount) + posting_account = posting_account + posting_amount = Amount.sum . posting_amounts + -- ** The 'Posting' mappings type Posting_by_Account - = Data.Map.Map Account [Posting] + = Map Account [Posting] type Posting_by_Amount_and_Account - = Data.Map.Map Amount.By_Unit Posting_by_Account + = Map Amount.By_Unit Posting_by_Account type Posting_by_Signs_and_Account - = Data.Map.Map Amount.Signs Posting_by_Account + = Map Amount.Signs Posting_by_Account -- | Return a Data.'Data.Map.Map' associating the given 'Posting's with their respective 'Account'. posting_by_Account :: [Posting] -> Posting_by_Account @@ -192,7 +218,7 @@ type Tag = (Tag_Name, Tag_Value) type Tag_Name = Text type Tag_Value = Text -type Tag_by_Name = Data.Map.Map Tag_Name [Tag_Value] +type Tag_by_Name = Map Tag_Name [Tag_Value] -- | Return a 'Data.Map.Map' associating the 'Value's of the given 'Tag's with their respective 'Name'. tag_by_Name :: [Tag] -> Tag_by_Name diff --git a/lib/Hcompta/Format/Ledger/Write.hs b/lib/Hcompta/Format/Ledger/Write.hs index 2f203b5..7ad8703 100644 --- a/lib/Hcompta/Format/Ledger/Write.hs +++ b/lib/Hcompta/Format/Ledger/Write.hs @@ -1,44 +1,30 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MagicHash #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Hcompta.Format.Ledger.Write where import Control.Applicative ((<$>), (<*)) --- import Control.Arrow ((***)) -import Data.Decimal (DecimalRaw(..)) import qualified Data.Char (isSpace) -import Data.Fixed (showFixed) import qualified Data.Functor.Compose import qualified Data.Foldable import Data.Foldable (Foldable) import qualified Data.List import qualified Data.List.NonEmpty import qualified Data.Map.Strict as Data.Map -import Data.Maybe (fromMaybe) import qualified Data.Text.Lazy as TL import qualified Data.Text as Text -import qualified Data.Time.Calendar as Time (toGregorian) -import qualified Data.Time.LocalTime as Time import qualified Hcompta.Lib.Leijen as W import Hcompta.Lib.Leijen (Doc, (<>)) import System.IO (Handle) import qualified Text.Parsec as R hiding (satisfy, char) import Text.Parsec (Stream, ParsecT) -import GHC.Exts (Int(..)) -import GHC.Integer.Logarithms (integerLogBase#) import qualified Hcompta.Account as Account import Hcompta.Account (Account) import qualified Hcompta.Amount as Amount -import Hcompta.Amount (Amount) -import qualified Hcompta.Amount.Quantity as Quantity -import Hcompta.Amount.Quantity (Quantity) -import qualified Hcompta.Amount.Style as Amount.Style -import qualified Hcompta.Amount.Unit as Unit -import Hcompta.Amount.Unit (Unit) +import qualified Hcompta.Amount.Write as Amount.Write import qualified Hcompta.Format.Ledger as Ledger import Hcompta.Format.Ledger ( Comment @@ -47,14 +33,11 @@ import Hcompta.Format.Ledger , Tag , Transaction(..) ) --- import qualified Hcompta.Date as Date -import Hcompta.Date (Date) --- import Hcompta.Format.Ledger.Journal as Journal +import qualified Hcompta.Date.Write as Date.Write import qualified Hcompta.Format.Ledger.Read as Read import qualified Hcompta.Lib.Parsec as R - --- * Printing 'Account' +-- * Write 'Account' account :: Posting_Type -> Account -> Doc account type_ = @@ -80,7 +63,7 @@ account type_ = account_name :: Account.Name -> Doc account_name = W.strict_text --- ** Mesuring 'Account' +-- ** Measure 'Account' account_length :: Posting_Type -> Account -> Int account_length type_ acct = @@ -92,99 +75,7 @@ account_length type_ acct = Posting_Type_Virtual -> 2 Posting_Type_Virtual_Balanced -> 2 --- * Printing 'Amount' - -amount :: Amount -> Doc -amount Amount.Amount - { Amount.quantity=qty - , Amount.style = sty@(Amount.Style.Style - { Amount.Style.unit_side - , Amount.Style.unit_spaced - }) - , Amount.unit=unit_ - } = do - case unit_side of - Just Amount.Style.Side_Left -> - (unit unit_) - <> (case unit_spaced of { Just True | unit_ /= "" -> W.space; _ -> W.empty }) - _ -> W.empty - <> quantity sty qty - <> case unit_side of - (Just Amount.Style.Side_Right) -> - (case unit_spaced of { Just True | unit_ /= "" -> W.space; _ -> W.empty }) - <> unit unit_ - Nothing -> - (case unit_spaced of { Just True | unit_ /= "" -> W.space; _ -> W.empty }) - <> unit unit_ - _ -> W.empty - -unit :: Unit -> Doc -unit = W.yellow . W.strict_text . Unit.text - -quantity :: Amount.Style -> Quantity -> Doc -quantity Amount.Style.Style - { Amount.Style.fractioning - , Amount.Style.grouping_integral - , Amount.Style.grouping_fractional - , Amount.Style.precision - } qty = do - let Decimal e n = Quantity.round precision qty - let num = Prelude.show $ abs $ n - let sign = W.bold $ W.yellow $ W.strict_text (if n < 0 then "-" else "") - case e == 0 || precision == 0 of - True -> sign <> do W.bold $ W.blue $ (W.strict_text $ Text.pack num) - False -> do - let num_len = length num - let padded = - Data.List.concat - [ replicate (fromIntegral e + 1 - num_len) '0' - , num - , replicate (fromIntegral precision - fromIntegral e) '0' - ] - let (int, frac) = Data.List.splitAt (max 1 (num_len - fromIntegral precision)) padded - let default_fractioning = - Data.List.head $ - del_grouping_sep grouping_integral $ - del_grouping_sep grouping_fractional $ - ['.', ','] - sign <> do - W.bold $ W.blue $ do - W.text (TL.pack $ maybe id (\g -> reverse . group g . reverse) grouping_integral $ int) <> do - (W.yellow $ W.char (fromMaybe default_fractioning fractioning)) <> do - W.text (TL.pack $ maybe id group grouping_fractional frac) - where - group :: Amount.Style.Grouping -> [Char] -> [Char] - group (Amount.Style.Grouping sep sizes_) = - Data.List.concat . reverse . - Data.List.map reverse . fst . - Data.List.foldl - (flip (\digit -> \x -> case x of - ([], sizes) -> ([[digit]], sizes) - (digits:groups, []) -> ((digit:digits):groups, []) - (digits:groups, curr_sizes@(size:sizes)) -> - if length digits < size - then ( (digit:digits):groups, curr_sizes) - else ([digit]:[sep]:digits:groups, if sizes == [] then curr_sizes else sizes) - )) - ([], sizes_) - del_grouping_sep grouping = - case grouping of - Just (Amount.Style.Grouping sep _) -> Data.List.delete sep - _ -> id - --- ** Mesuring 'Amount' - -amount_length :: Amount -> Int -amount_length Amount.Amount - { Amount.quantity = qty - , Amount.style = sty@(Amount.Style.Style - { Amount.Style.unit_spaced - }) - , Amount.unit = unit_ - } = do - Unit.length unit_ - + (case unit_spaced of { Just True | unit_ /= "" -> 1; _ -> 0 }) - + quantity_length sty qty +-- ** Measure 'Amount's amounts_length :: Amount.By_Unit -> Int amounts_length amts = @@ -192,83 +83,10 @@ amounts_length amts = then 0 else Data.Map.foldr - (\n -> (3 +) . (+) (amount_length n)) + (\n -> (3 +) . (+) (Amount.Write.amount_length n)) (-3) amts -quantity_length :: Amount.Style -> Quantity -> Int -quantity_length Amount.Style.Style - { Amount.Style.grouping_integral - , Amount.Style.grouping_fractional - , Amount.Style.precision - } qty = - let Decimal e n = Quantity.round precision qty in - let sign_len = if n < 0 then 1 else 0 in - let fractioning_len = if e > 0 then 1 else 0 in - let num_len = if n == 0 then 0 else (1 +) $ I# (integerLogBase# 10 (abs n)) in - let pad_left_len = max 0 (fromIntegral e + 1 - num_len) in - let pad_right_len = max 0 (fromIntegral precision - fromIntegral e) in - let padded_len = pad_left_len + num_len + pad_right_len in - let int_len = max 1 (num_len - fromIntegral precision) in - let frac_len = max 0 (padded_len - int_len) in - ( sign_len - + fractioning_len - + padded_len - + maybe 0 (group int_len) grouping_integral - + maybe 0 (group frac_len) grouping_fractional - ) - where - group :: Int -> Amount.Style.Grouping -> Int - group num_len (Amount.Style.Grouping _sep sizes_) = - if num_len <= 0 - then 0 - else loop 0 num_len sizes_ - where - loop :: Int -> Int -> [Int] -> Int - loop pad len = - \x -> case x of - [] -> 0 - sizes@[size] -> - let l = len - size in - if l <= 0 then pad - else loop (pad + 1) l sizes - size:sizes -> - let l = len - size in - if l <= 0 then pad - else loop (pad + 1) l sizes - --- * Printing 'Date' - -date :: Date -> Doc -date utc = do - let (y, mo, d) = Time.toGregorian day - (if y == 0 then W.empty else W.integer y <> sep '/') <> do - int2 mo <> do - sep '/' <> int2 d <> do - (case tod of - Time.TimeOfDay 0 0 0 -> W.empty - Time.TimeOfDay h m s -> - W.space <> int2 h <> do - sep ':' <> int2 m <> do - (case s of - 0 -> W.empty - _ -> sep ':' <> do - (if s < 10 then W.char '0' else W.empty) <> do - W.strict_text $ Text.pack $ showFixed True s)) <> do - (case tz_min of - 0 -> W.empty - _ | tz_name /= "" -> W.space <> do W.strict_text $ Text.pack tz_name - _ -> W.space <> do W.strict_text $ Text.pack $ Time.timeZoneOffsetString tz) - where - Time.ZonedTime - (Time.LocalTime day tod) - tz@(Time.TimeZone tz_min _ tz_name) = - Time.utcToZonedTime Time.utc utc - int2 :: Int -> Doc - int2 i = if i < 10 then W.char '0' <> W.int i else W.int i - sep :: Char -> Doc - sep = W.bold . W.dullblack . W.char - --- * Printing 'Comment' +-- * Write 'Comment' comment :: Comment -> Doc comment com = @@ -319,7 +137,7 @@ comments prefix = Data.List.intersperse W.line . Data.List.map (\c -> prefix <> comment c) --- * Printing 'Tag' +-- * Write 'Tag' tag :: Tag -> Doc tag (n, v) = @@ -327,7 +145,7 @@ tag (n, v) = <> W.char Read.tag_value_sep <> (W.dullred $ W.strict_text v) --- * Printing 'Posting' +-- * Write 'Posting' posting :: Posting_Lengths -> Posting_Type -> Posting -> Doc posting max_posting_length type_ @@ -350,7 +168,7 @@ posting max_posting_length type_ W.fill (2 + max_posting_length - (len_acct + len_amts)) (W.space <> W.space) <> do W.intercalate (W.space <> (W.bold $ W.yellow $ W.char Read.amount_sep) <> W.space) - amount posting_amounts + Amount.Write.amount posting_amounts <> (case cmts of [] -> W.empty [c] -> W.space <> comment c @@ -361,7 +179,7 @@ status = \x -> case x of True -> W.char '!' False -> W.empty --- ** Mesuring 'Posting' +-- ** Measure 'Posting' type Posting_Lengths = (Int) @@ -379,7 +197,7 @@ postings_lengths type_ ps pl = ) pl (Data.Functor.Compose.Compose ps) --- * Printing 'Transaction' +-- * Write 'Transaction' transaction :: Transaction -> Doc transaction t = transaction_with_lengths (transaction_lengths t 0) t @@ -417,7 +235,7 @@ transaction_with_lengths (W.hcat $ Data.List.intersperse (W.char Read.date_sep) - (Data.List.map date (first_date:dates))) <> do + (Data.List.map Date.Write.date (first_date:dates))) <> do (case status_ of True -> W.space <> status status_ False -> W.empty) <> do @@ -446,7 +264,7 @@ code = \x -> case x of "" -> W.empty t -> W.space <> W.char '(' <> W.strict_text t <> W.char ')' --- ** Mesuring 'Transaction' +-- ** Measure 'Transaction' type Transaction_Lengths = Posting_Lengths @@ -465,7 +283,7 @@ transaction_lengths , (Posting_Type_Virtual_Balanced, transaction_balanced_virtual_postings) ] --- * Printing 'Journal' +-- * Write 'Journal' journal :: Journal -> Doc journal Journal { journal_transactions } = diff --git a/lib/Hcompta/GL.hs b/lib/Hcompta/GL.hs new file mode 100644 index 0000000..b1af1a4 --- /dev/null +++ b/lib/Hcompta/GL.hs @@ -0,0 +1,247 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} -- FIXME: to be removed when dropping GHC-7.6 support +module Hcompta.GL where -- General Ledger + +import Control.Exception (assert) +import Data.Data +import qualified Data.Foldable +import Data.Foldable (Foldable) +import Data.Functor.Compose (Compose(..)) +import Data.Maybe (fromMaybe) +import qualified Data.Sequence +import Data.Sequence (Seq, (><), (|>), ViewR(..)) +import qualified Data.Traversable +import qualified Data.Map.Strict as Data.Map +import Data.Map.Strict (Map) +import Data.Typeable () + +import qualified Hcompta.Account as Account +import Hcompta.Account (Account) +import Hcompta.Date (Date) +import qualified Hcompta.Lib.TreeMap as TreeMap +import Hcompta.Lib.TreeMap (TreeMap) + +-- * Requirements' interface + +-- ** Class 'Amount' +class + ( Data (Amount_Unit a) + , Data a + , Eq a + , Ord (Amount_Unit a) + , Show (Amount_Unit a) + , Show a + , Typeable (Amount_Unit a) + ) => Amount a where + type Amount_Unit a + amount_add :: a -> a -> a + +-- ** Class 'Posting' + +-- | A 'posting' used to produce a 'GL' +-- must be an instance of this class. +class Amount (Posting_Amount p) + => Posting p where + type Posting_Amount p + posting_account :: p -> Account + posting_amount :: p -> Posting_Amount p + +instance (Amount amount) + => Posting (Account, amount) + where + type Posting_Amount (Account, amount) = amount + posting_account (x, _) = x + posting_amount (_, x) = x + +-- ** Class 'Transaction' + +class + ( Posting (Transaction_Posting t) + , Data (Transaction_Posting t) + , Eq (Transaction_Posting t) + , Show (Transaction_Posting t) + , Foldable (Transaction_Postings t) + ) => Transaction t where + type Transaction_Posting t + type Transaction_Postings t :: * -> * + transaction_date :: t -> Date + transaction_postings :: t -> Transaction_Postings t (Transaction_Posting t) + +instance + ( Posting posting + , Data posting + , Eq posting + , Show posting + ) => Transaction (Date, Map Account ([] posting)) + where + type Transaction_Posting (Date, Map Account ([] posting)) = posting + type Transaction_Postings (Date, Map Account ([] posting)) = Compose (Map Account) [] + transaction_date = fst + transaction_postings = Compose . snd + +-- * Type 'GL' + +newtype Transaction transaction + => GL transaction + = GL (TreeMap Account.Name (Map Date (Seq (GL_Line transaction)))) +deriving instance ( Transaction transaction + , Data transaction + , Typeable transaction + , Typeable GL_Line + ) => Data (GL transaction) +deriving instance ( Transaction transaction + , Eq transaction + ) => Eq (GL transaction) +deriving instance ( Transaction transaction + , Show transaction + ) => Show (GL transaction) +deriving instance Typeable1 GL + -- FIXME: use 'Typeable' when dropping GHC-7.6 support + +data + Transaction transaction + => GL_Line transaction + = GL_Line + { gl_line_transaction :: transaction + , gl_line_posting :: Transaction_Posting transaction + , gl_line_sum :: Posting_Amount (Transaction_Posting transaction) + } +deriving instance ( Transaction transaction + , Data transaction + , Typeable transaction + , Typeable GL_Line + ) => Data (GL_Line transaction) +deriving instance ( Transaction transaction + , Eq transaction + ) => Eq (GL_Line transaction) +deriving instance ( Transaction transaction + , Show transaction + ) => Show (GL_Line transaction) +deriving instance Typeable1 GL_Line + -- FIXME: use 'Typeable' when dropping GHC-7.6 support + +-- ** Constructors + +nil + :: Transaction transaction + => GL transaction +nil = GL TreeMap.empty + +-- | Return the given 'GL' +-- updated by the given 'Posting'. +general_ledger + :: Transaction transaction + => transaction + -> GL transaction + -> GL transaction +general_ledger t (GL gl) = + GL $ + Data.Foldable.foldr + ((\p -> + let first_line = + GL_Line + { gl_line_transaction = t + , gl_line_posting = p + , gl_line_sum = posting_amount p + } in + let single = + Data.Map.singleton (transaction_date t) $ + Data.Sequence.singleton first_line in + TreeMap.insert + (\_new old -> + let (nlt, leq, neq, ngt) = + case Data.Map.splitLookup (transaction_date t) old of + (olt, Nothing, ogt) | Data.Map.null olt -> + (olt, first_line, Data.Sequence.singleton first_line, ogt) + (olt, Nothing, ogt) -> + let line = + case Data.Sequence.viewr $ snd $ Data.Map.findMax olt of + (_:>GL_Line{gl_line_sum = s}) -> + first_line{gl_line_sum = amount_add s $ posting_amount p} + _ -> first_line + in (olt, line, Data.Sequence.singleton line, ogt) + (olt, Just oeq, ogt) -> + case Data.Sequence.viewr oeq of + (_:>GL_Line{gl_line_sum = s}) -> + let line = first_line{gl_line_sum = amount_add s $ posting_amount p} in + (olt, line, oeq |> line, ogt) + _ -> (olt, first_line, Data.Sequence.singleton first_line, ogt) + in + Data.Map.union nlt $ + Data.Map.insert (transaction_date t) neq $ + Data.Map.map (fmap (\l -> l{gl_line_sum = + amount_add (gl_line_sum leq) $ + gl_line_sum l})) ngt + ) + (posting_account p) + single + )) + gl + (transaction_postings t) + +-- * Type 'Expanded' + +-- | Descending propagation of 'Amount's accross 'Account's. +type Expanded transaction + = TreeMap Account.Name (GL_Line_Expanded transaction) +data Transaction transaction + => GL_Line_Expanded transaction + = GL_Line_Expanded + { exclusive :: Map Date (Seq (GL_Line transaction)) + , inclusive :: Map Date (Seq (GL_Line transaction)) -- ^ 'amount_add' folded over 'exclusive' and 'inclusive' of 'Lib.TreeMap.node_descendants' + } +deriving instance ( Transaction transaction + , Data transaction + ) => Data (GL_Line_Expanded transaction) +deriving instance ( Transaction transaction + , Eq transaction + ) => Eq (GL_Line_Expanded transaction) +deriving instance ( Transaction transaction + , Show transaction + ) => Show (GL_Line_Expanded transaction) +deriving instance Typeable1 GL_Line_Expanded + -- FIXME: use 'Typeable' when dropping GHC-7.6 support + +-- | Return the given 'GL' with: +-- +-- * all missing 'Account.ascending' 'Account's inserted, +-- +-- * and every mapped 'GL_Line' +-- added with any 'GL_Line' +-- of the 'Account's for which it is 'Account.ascending'. +expanded + :: Transaction transaction + => GL transaction + -> Expanded transaction +expanded (GL gl) = + let from_value = fromMaybe (assert False undefined) . TreeMap.node_value in + TreeMap.map_by_depth_first + (\descendants value -> + let nodes = TreeMap.nodes descendants in + let exclusive = fromMaybe Data.Map.empty value in + GL_Line_Expanded + { exclusive + , inclusive = + getCompose $ + snd $ + Data.Traversable.mapAccumL + (\ms line -> + let pamt = posting_amount $ gl_line_posting line in + case ms of + Nothing -> (Just pamt, line) + Just s -> + let ls = amount_add s pamt in + ( Just ls + , line{gl_line_sum=ls} ) + ) Nothing $ + Compose $ + Data.Map.foldr + (Data.Map.unionWith (><) . inclusive . from_value) + exclusive nodes + }) + gl diff --git a/lib/Hcompta/Lib/TreeMap.hs b/lib/Hcompta/Lib/TreeMap.hs index 30b305c..6cad8ad 100644 --- a/lib/Hcompta/Lib/TreeMap.hs +++ b/lib/Hcompta/Lib/TreeMap.hs @@ -246,6 +246,36 @@ map_by_depth_first f = }) . nodes +-- * Alter + +alterl_path :: Ord k => (Maybe x -> Maybe x) -> Path k -> TreeMap k x -> TreeMap k x +alterl_path fct = + go fct . list + where + go :: Ord k + => (Maybe x -> Maybe x) -> [k] + -> TreeMap k x -> TreeMap k x + go _f [] m = m + go f (k:p) (TreeMap m) = + TreeMap $ + Data.Map.alter + (\c -> + let (cv, cm) = + case c of + Just Node{node_value=v, node_descendants=d} -> (v, d) + Nothing -> (Nothing, empty) in + let fx = f cv in + let gm = go f p cm in + case (fx, size gm) of + (Nothing, 0) -> Nothing + (_, s) -> Just + Node + { node_value = fx + , node_descendants = gm + , node_size = s + 1 + } + ) k m + -- * Fold -- | Return the given accumulator folded by the given function @@ -312,6 +342,44 @@ foldr_with_Path_and_Node = let acc' = foldp (k:p) fct acc node_descendants in maybe acc' (\x -> fct (reverse $ path k p) n x acc') node_value) a m +-- | Return the given accumulator folded by the given function +-- applied on non-'Nothing' 'node_value's +-- from left to right along the given 'Path'. +foldl_path :: Ord k => (Path k -> x -> a -> a) -> Path k -> TreeMap k x -> a -> a +foldl_path fct = + go fct [] . list + where + go :: Ord k + => (Path k -> x -> a -> a) -> [k] -> [k] + -> TreeMap k x -> a -> a + go _f _ [] _t a = a + go f p (k:n) (TreeMap t) a = + case Data.Map.lookup k t of + Nothing -> a + Just Node{node_value=v, node_descendants=d} -> + case v of + Nothing -> go f (k:p) n d a + Just x -> go f (k:p) n d (f (reverse $ path k p) x a) + +-- | Return the given accumulator folded by the given function +-- applied on non-'Nothing' 'node_value's +-- from right to left along the given 'Path'. +foldr_path :: Ord k => (Path k -> x -> a -> a) -> Path k -> TreeMap k x -> a -> a +foldr_path fct = + go fct [] . list + where + go :: Ord k + => (Path k -> x -> a -> a) -> [k] -> [k] + -> TreeMap k x -> a -> a + go _f _ [] _t a = a + go f p (k:n) (TreeMap t) a = + case Data.Map.lookup k t of + Nothing -> a + Just Node{node_value=v, node_descendants=d} -> + case v of + Nothing -> go f (k:p) n d a + Just x -> f (reverse $ path k p) x $ go f (k:p) n d a + -- * Flatten -- | Return a 'Map' associating each 'Path' diff --git a/lib/Test/Main.hs b/lib/Test/Main.hs index b727eb9..81b7e80 100644 --- a/lib/Test/Main.hs +++ b/lib/Test/Main.hs @@ -21,23 +21,25 @@ import qualified Text.Parsec as P hiding (char, space, spaces, string) import qualified Text.Parsec.Pos as P -- import qualified Text.PrettyPrint.Leijen.Text as PP -import qualified Hcompta.Account as Account import Hcompta.Account (Account) -import qualified Hcompta.Amount as Amount +import qualified Hcompta.Account as Account import Hcompta.Amount (Amount) +import qualified Hcompta.Amount as Amount import qualified Hcompta.Amount.Read as Amount.Read +import qualified Hcompta.Amount.Write as Amount.Write import qualified Hcompta.Amount.Style as Amount.Style +import qualified Hcompta.Balance as Balance import qualified Hcompta.Date as Date import qualified Hcompta.Date.Read as Date.Read +import qualified Hcompta.Date.Write as Date.Write import qualified Hcompta.Filter as Filter import qualified Hcompta.Filter.Read as Filter.Read -import qualified Hcompta.Balance as Balance import qualified Hcompta.Format.Ledger as Format.Ledger import qualified Hcompta.Format.Ledger.Read as Format.Ledger.Read import qualified Hcompta.Format.Ledger.Write as Format.Ledger.Write -import qualified Hcompta.Lib.TreeMap as Lib.TreeMap -import qualified Hcompta.Lib.Parsec as P import qualified Hcompta.Lib.Foldable as Lib.Foldable +import qualified Hcompta.Lib.Parsec as P +import qualified Hcompta.Lib.TreeMap as Lib.TreeMap main :: IO () main = defaultMain $ hUnitTestToTests test_Hcompta @@ -795,6 +797,344 @@ test_Hcompta = }] ] ] + , "Write" ~: TestList + [ "amount" ~: TestList + [ "nil" ~: + ((Format.Ledger.Write.show + Format.Ledger.Write.Style + { Format.Ledger.Write.style_color=False + , Format.Ledger.Write.style_align=True + } $ + Amount.Write.amount + Amount.nil) + ~?= + "0") + , "nil @ prec=2" ~: + ((Format.Ledger.Write.show + Format.Ledger.Write.Style + { Format.Ledger.Write.style_color=False + , Format.Ledger.Write.style_align=True + } $ + Amount.Write.amount + Amount.nil + { Amount.style = Amount.Style.nil + { Amount.Style.precision = 2 } + }) + ~?= + "0.00") + , "123" ~: + ((Format.Ledger.Write.show + Format.Ledger.Write.Style + { Format.Ledger.Write.style_color=False + , Format.Ledger.Write.style_align=True + } $ + Amount.Write.amount + Amount.nil + { Amount.quantity = Decimal 0 123 + }) + ~?= + "123") + , "-123" ~: + ((Format.Ledger.Write.show + Format.Ledger.Write.Style + { Format.Ledger.Write.style_color=False + , Format.Ledger.Write.style_align=True + } $ + Amount.Write.amount + Amount.nil + { Amount.quantity = Decimal 0 (- 123) + }) + ~?= + "-123") + , "12.3 @ prec=0" ~: + ((Format.Ledger.Write.show + Format.Ledger.Write.Style + { Format.Ledger.Write.style_color=False + , Format.Ledger.Write.style_align=True + } $ + Amount.Write.amount + Amount.nil + { Amount.quantity = Decimal 1 123 + , Amount.style = Amount.Style.nil + { Amount.Style.fractioning = Just '.' + } + }) + ~?= + "12") + , "12.5 @ prec=0" ~: + ((Format.Ledger.Write.show + Format.Ledger.Write.Style + { Format.Ledger.Write.style_color=False + , Format.Ledger.Write.style_align=True + } $ + Amount.Write.amount + Amount.nil + { Amount.quantity = Decimal 1 125 + , Amount.style = Amount.Style.nil + { Amount.Style.fractioning = Just '.' + } + }) + ~?= + "13") + , "12.3 @ prec=1" ~: + ((Format.Ledger.Write.show + Format.Ledger.Write.Style + { Format.Ledger.Write.style_color=False + , Format.Ledger.Write.style_align=True + } $ + Amount.Write.amount + Amount.nil + { Amount.quantity = Decimal 1 123 + , Amount.style = Amount.Style.nil + { Amount.Style.fractioning = Just '.' + , Amount.Style.precision = 1 + } + }) + ~?= + "12.3") + , "1,234.56 @ prec=2" ~: + ((Format.Ledger.Write.show + Format.Ledger.Write.Style + { Format.Ledger.Write.style_color=False + , Format.Ledger.Write.style_align=True + } $ + Amount.Write.amount + Amount.nil + { Amount.quantity = Decimal 2 123456 + , Amount.style = Amount.Style.nil + { Amount.Style.fractioning = Just '.' + , Amount.Style.precision = 2 + , Amount.Style.grouping_integral = Just $ Amount.Style.Grouping ',' [3] + } + }) + ~?= + "1,234.56") + , "123,456,789,01,2.3456789 @ prec=7" ~: + ((Format.Ledger.Write.show + Format.Ledger.Write.Style + { Format.Ledger.Write.style_color=False + , Format.Ledger.Write.style_align=True + } $ + Amount.Write.amount + Amount.nil + { Amount.quantity = Decimal 7 1234567890123456789 + , Amount.style = Amount.Style.nil + { Amount.Style.fractioning = Just '.' + , Amount.Style.precision = 7 + , Amount.Style.grouping_integral = Just $ Amount.Style.Grouping ',' [1, 2, 3] + } + }) + ~?= + "123,456,789,01,2.3456789") + , "1234567.8,90,123,456,789 @ prec=12" ~: + ((Format.Ledger.Write.show + Format.Ledger.Write.Style + { Format.Ledger.Write.style_color=False + , Format.Ledger.Write.style_align=True + } $ + Amount.Write.amount + Amount.nil + { Amount.quantity = Decimal 12 1234567890123456789 + , Amount.style = Amount.Style.nil + { Amount.Style.fractioning = Just '.' + , Amount.Style.precision = 12 + , Amount.Style.grouping_fractional = Just $ Amount.Style.Grouping ',' [1, 2, 3] + } + }) + ~?= + "1234567.8,90,123,456,789") + , "1,2,3,4,5,6,7,89,012.3456789 @ prec=7" ~: + ((Format.Ledger.Write.show + Format.Ledger.Write.Style + { Format.Ledger.Write.style_color=False + , Format.Ledger.Write.style_align=True + } $ + Amount.Write.amount + Amount.nil + { Amount.quantity = Decimal 7 1234567890123456789 + , Amount.style = Amount.Style.nil + { Amount.Style.fractioning = Just '.' + , Amount.Style.precision = 7 + , Amount.Style.grouping_integral = Just $ Amount.Style.Grouping ',' [3, 2, 1] + } + }) + ~?= + "1,2,3,4,5,6,7,89,012.3456789") + , "1234567.890,12,3,4,5,6,7,8,9 @ prec=12" ~: + ((Format.Ledger.Write.show + Format.Ledger.Write.Style + { Format.Ledger.Write.style_color=False + , Format.Ledger.Write.style_align=True + } $ + Amount.Write.amount + Amount.nil + { Amount.quantity = Decimal 12 1234567890123456789 + , Amount.style = Amount.Style.nil + { Amount.Style.fractioning = Just '.' + , Amount.Style.precision = 12 + , Amount.Style.grouping_fractional = Just $ Amount.Style.Grouping ',' [3, 2, 1] + } + }) + ~?= + "1234567.890,12,3,4,5,6,7,8,9") + ] + , "amount_length" ~: TestList + [ "nil" ~: + ((Amount.Write.amount_length + Amount.nil) + ~?= + 1) + , "nil @ prec=2" ~: + ((Amount.Write.amount_length + Amount.nil + { Amount.style = Amount.Style.nil + { Amount.Style.precision = 2 } + }) + ~?= + 4) + , "123" ~: + ((Amount.Write.amount_length + Amount.nil + { Amount.quantity = Decimal 0 123 + }) + ~?= + 3) + , "-123" ~: + ((Amount.Write.amount_length + Amount.nil + { Amount.quantity = Decimal 0 (- 123) + }) + ~?= + 4) + , "12.3 @ prec=0" ~: + ((Amount.Write.amount_length + Amount.nil + { Amount.quantity = Decimal 1 123 + , Amount.style = Amount.Style.nil + { Amount.Style.fractioning = Just '.' + } + }) + ~?= + 2) + , "12.5 @ prec=0" ~: + ((Amount.Write.amount_length + Amount.nil + { Amount.quantity = Decimal 1 125 + , Amount.style = Amount.Style.nil + { Amount.Style.fractioning = Just '.' + } + }) + ~?= + 2) + , "12.3 @ prec=1" ~: + ((Amount.Write.amount_length + Amount.nil + { Amount.quantity = Decimal 1 123 + , Amount.style = Amount.Style.nil + { Amount.Style.fractioning = Just '.' + , Amount.Style.precision = 1 + } + }) + ~?= + 4) + , "1,234.56 @ prec=2" ~: + ((Amount.Write.amount_length + Amount.nil + { Amount.quantity = Decimal 2 123456 + , Amount.style = Amount.Style.nil + { Amount.Style.fractioning = Just '.' + , Amount.Style.precision = 2 + , Amount.Style.grouping_integral = Just $ Amount.Style.Grouping ',' [3] + } + }) + ~?= + 8) + , "123,456,789,01,2.3456789 @ prec=7" ~: + ((Amount.Write.amount_length + Amount.nil + { Amount.quantity = Decimal 7 1234567890123456789 + , Amount.style = Amount.Style.nil + { Amount.Style.fractioning = Just '.' + , Amount.Style.precision = 7 + , Amount.Style.grouping_integral = Just $ Amount.Style.Grouping ',' [1, 2, 3] + } + }) + ~?= + 24) + , "1234567.8,90,123,456,789 @ prec=12" ~: + ((Amount.Write.amount_length + Amount.nil + { Amount.quantity = Decimal 12 1234567890123456789 + , Amount.style = Amount.Style.nil + { Amount.Style.fractioning = Just '.' + , Amount.Style.precision = 12 + , Amount.Style.grouping_fractional = Just $ Amount.Style.Grouping ',' [1, 2, 3] + } + }) + ~?= + 24) + , "1,2,3,4,5,6,7,89,012.3456789 @ prec=7" ~: + ((Amount.Write.amount_length + Amount.nil + { Amount.quantity = Decimal 7 1234567890123456789 + , Amount.style = Amount.Style.nil + { Amount.Style.fractioning = Just '.' + , Amount.Style.precision = 7 + , Amount.Style.grouping_integral = Just $ Amount.Style.Grouping ',' [3, 2, 1] + } + }) + ~?= + 28) + , "1234567.890,12,3,4,5,6,7,8,9 @ prec=12" ~: + ((Amount.Write.amount_length + Amount.nil + { Amount.quantity = Decimal 12 1234567890123456789 + , Amount.style = Amount.Style.nil + { Amount.Style.fractioning = Just '.' + , Amount.Style.precision = 12 + , Amount.Style.grouping_fractional = Just $ Amount.Style.Grouping ',' [3, 2, 1] + } + }) + ~?= + 28) + , "1000000.000,00,0,0,0,0,0,0,0 @ prec=12" ~: + ((Amount.Write.amount_length + Amount.nil + { Amount.quantity = Decimal 12 1000000000000000000 + , Amount.style = Amount.Style.nil + { Amount.Style.fractioning = Just '.' + , Amount.Style.precision = 12 + , Amount.Style.grouping_fractional = Just $ Amount.Style.Grouping ',' [3, 2, 1] + } + }) + ~?= + 28) + , "999 @ prec=0" ~: + ((Amount.Write.amount_length $ + Amount.nil + { Amount.quantity = Decimal 0 999 + , Amount.style = Amount.Style.nil + { Amount.Style.precision = 0 + } + }) + ~?= + 3) + , "1000 @ prec=0" ~: + ((Amount.Write.amount_length $ + Amount.nil + { Amount.quantity = Decimal 0 1000 + , Amount.style = Amount.Style.nil + { Amount.Style.precision = 0 + } + }) + ~?= + 4) + , "10,00€ @ prec=2" ~: + ((Amount.Write.amount_length $ Amount.eur 10) + ~?= + 6) + ] + ] ] , "Date" ~: TestList [ "Read" ~: TestList @@ -904,6 +1244,125 @@ test_Hcompta = (Time.utc)] ] ] + , "Write" ~: TestList + [ "date" ~: TestList + [ "nil" ~: + ((Format.Ledger.Write.show + Format.Ledger.Write.Style + { Format.Ledger.Write.style_color=False + , Format.Ledger.Write.style_align=True + } $ + Date.Write.date + Date.nil) + ~?= + "1970/01/01") + , "2000/01/01 12:34:51 CET" ~: + (Format.Ledger.Write.show + Format.Ledger.Write.Style + { Format.Ledger.Write.style_color=False + , Format.Ledger.Write.style_align=True + } $ + Date.Write.date $ + Time.zonedTimeToUTC $ + Time.ZonedTime + (Time.LocalTime + (Time.fromGregorian 2000 01 01) + (Time.TimeOfDay 12 34 51)) + (Time.TimeZone 60 False "CET")) + ~?= + "2000/01/01 11:34:51" + , "2000/01/01 12:34:51 +0100" ~: + (Format.Ledger.Write.show + Format.Ledger.Write.Style + { Format.Ledger.Write.style_color=False + , Format.Ledger.Write.style_align=True + } $ + Date.Write.date $ + Time.zonedTimeToUTC $ + Time.ZonedTime + (Time.LocalTime + (Time.fromGregorian 2000 01 01) + (Time.TimeOfDay 12 34 51)) + (Time.TimeZone 60 False "")) + ~?= + "2000/01/01 11:34:51" + , "2000/01/01 01:02:03" ~: + (Format.Ledger.Write.show + Format.Ledger.Write.Style + { Format.Ledger.Write.style_color=False + , Format.Ledger.Write.style_align=True + } $ + Date.Write.date $ + Time.zonedTimeToUTC $ + Time.ZonedTime + (Time.LocalTime + (Time.fromGregorian 2000 01 01) + (Time.TimeOfDay 1 2 3)) + (Time.utc)) + ~?= + "2000/01/01 01:02:03" + , "01/01 01:02" ~: + (Format.Ledger.Write.show + Format.Ledger.Write.Style + { Format.Ledger.Write.style_color=False + , Format.Ledger.Write.style_align=True + } $ + Date.Write.date $ + Time.zonedTimeToUTC $ + Time.ZonedTime + (Time.LocalTime + (Time.fromGregorian 0 01 01) + (Time.TimeOfDay 1 2 0)) + (Time.utc)) + ~?= + "01/01 01:02" + , "01/01 01:00" ~: + (Format.Ledger.Write.show + Format.Ledger.Write.Style + { Format.Ledger.Write.style_color=False + , Format.Ledger.Write.style_align=True + } $ + Date.Write.date $ + Time.zonedTimeToUTC $ + Time.ZonedTime + (Time.LocalTime + (Time.fromGregorian 0 01 01) + (Time.TimeOfDay 1 0 0)) + (Time.utc)) + ~?= + "01/01 01:00" + , "01/01 00:01" ~: + (Format.Ledger.Write.show + Format.Ledger.Write.Style + { Format.Ledger.Write.style_color=False + , Format.Ledger.Write.style_align=True + } $ + Date.Write.date $ + Time.zonedTimeToUTC $ + Time.ZonedTime + (Time.LocalTime + (Time.fromGregorian 0 01 01) + (Time.TimeOfDay 0 1 0)) + (Time.utc)) + ~?= + "01/01 00:01" + , "01/01" ~: + (Format.Ledger.Write.show + Format.Ledger.Write.Style + { Format.Ledger.Write.style_color=False + , Format.Ledger.Write.style_align=True + } $ + Date.Write.date $ + Time.zonedTimeToUTC $ + Time.ZonedTime + (Time.LocalTime + (Time.fromGregorian 0 01 01) + (Time.TimeOfDay 0 0 0)) + (Time.utc)) + ~?= + "01/01" + ] + ] ] , "Filter" ~: TestList [ "test" ~: TestList @@ -3316,459 +3775,6 @@ test_Hcompta = ~?= "[A:B:C]") ] - , "amount" ~: TestList - [ "nil" ~: - ((Format.Ledger.Write.show - Format.Ledger.Write.Style - { Format.Ledger.Write.style_color=False - , Format.Ledger.Write.style_align=True - } $ - Format.Ledger.Write.amount - Amount.nil) - ~?= - "0") - , "nil @ prec=2" ~: - ((Format.Ledger.Write.show - Format.Ledger.Write.Style - { Format.Ledger.Write.style_color=False - , Format.Ledger.Write.style_align=True - } $ - Format.Ledger.Write.amount - Amount.nil - { Amount.style = Amount.Style.nil - { Amount.Style.precision = 2 } - }) - ~?= - "0.00") - , "123" ~: - ((Format.Ledger.Write.show - Format.Ledger.Write.Style - { Format.Ledger.Write.style_color=False - , Format.Ledger.Write.style_align=True - } $ - Format.Ledger.Write.amount - Amount.nil - { Amount.quantity = Decimal 0 123 - }) - ~?= - "123") - , "-123" ~: - ((Format.Ledger.Write.show - Format.Ledger.Write.Style - { Format.Ledger.Write.style_color=False - , Format.Ledger.Write.style_align=True - } $ - Format.Ledger.Write.amount - Amount.nil - { Amount.quantity = Decimal 0 (- 123) - }) - ~?= - "-123") - , "12.3 @ prec=0" ~: - ((Format.Ledger.Write.show - Format.Ledger.Write.Style - { Format.Ledger.Write.style_color=False - , Format.Ledger.Write.style_align=True - } $ - Format.Ledger.Write.amount - Amount.nil - { Amount.quantity = Decimal 1 123 - , Amount.style = Amount.Style.nil - { Amount.Style.fractioning = Just '.' - } - }) - ~?= - "12") - , "12.5 @ prec=0" ~: - ((Format.Ledger.Write.show - Format.Ledger.Write.Style - { Format.Ledger.Write.style_color=False - , Format.Ledger.Write.style_align=True - } $ - Format.Ledger.Write.amount - Amount.nil - { Amount.quantity = Decimal 1 125 - , Amount.style = Amount.Style.nil - { Amount.Style.fractioning = Just '.' - } - }) - ~?= - "13") - , "12.3 @ prec=1" ~: - ((Format.Ledger.Write.show - Format.Ledger.Write.Style - { Format.Ledger.Write.style_color=False - , Format.Ledger.Write.style_align=True - } $ - Format.Ledger.Write.amount - Amount.nil - { Amount.quantity = Decimal 1 123 - , Amount.style = Amount.Style.nil - { Amount.Style.fractioning = Just '.' - , Amount.Style.precision = 1 - } - }) - ~?= - "12.3") - , "1,234.56 @ prec=2" ~: - ((Format.Ledger.Write.show - Format.Ledger.Write.Style - { Format.Ledger.Write.style_color=False - , Format.Ledger.Write.style_align=True - } $ - Format.Ledger.Write.amount - Amount.nil - { Amount.quantity = Decimal 2 123456 - , Amount.style = Amount.Style.nil - { Amount.Style.fractioning = Just '.' - , Amount.Style.precision = 2 - , Amount.Style.grouping_integral = Just $ Amount.Style.Grouping ',' [3] - } - }) - ~?= - "1,234.56") - , "123,456,789,01,2.3456789 @ prec=7" ~: - ((Format.Ledger.Write.show - Format.Ledger.Write.Style - { Format.Ledger.Write.style_color=False - , Format.Ledger.Write.style_align=True - } $ - Format.Ledger.Write.amount - Amount.nil - { Amount.quantity = Decimal 7 1234567890123456789 - , Amount.style = Amount.Style.nil - { Amount.Style.fractioning = Just '.' - , Amount.Style.precision = 7 - , Amount.Style.grouping_integral = Just $ Amount.Style.Grouping ',' [1, 2, 3] - } - }) - ~?= - "123,456,789,01,2.3456789") - , "1234567.8,90,123,456,789 @ prec=12" ~: - ((Format.Ledger.Write.show - Format.Ledger.Write.Style - { Format.Ledger.Write.style_color=False - , Format.Ledger.Write.style_align=True - } $ - Format.Ledger.Write.amount - Amount.nil - { Amount.quantity = Decimal 12 1234567890123456789 - , Amount.style = Amount.Style.nil - { Amount.Style.fractioning = Just '.' - , Amount.Style.precision = 12 - , Amount.Style.grouping_fractional = Just $ Amount.Style.Grouping ',' [1, 2, 3] - } - }) - ~?= - "1234567.8,90,123,456,789") - , "1,2,3,4,5,6,7,89,012.3456789 @ prec=7" ~: - ((Format.Ledger.Write.show - Format.Ledger.Write.Style - { Format.Ledger.Write.style_color=False - , Format.Ledger.Write.style_align=True - } $ - Format.Ledger.Write.amount - Amount.nil - { Amount.quantity = Decimal 7 1234567890123456789 - , Amount.style = Amount.Style.nil - { Amount.Style.fractioning = Just '.' - , Amount.Style.precision = 7 - , Amount.Style.grouping_integral = Just $ Amount.Style.Grouping ',' [3, 2, 1] - } - }) - ~?= - "1,2,3,4,5,6,7,89,012.3456789") - , "1234567.890,12,3,4,5,6,7,8,9 @ prec=12" ~: - ((Format.Ledger.Write.show - Format.Ledger.Write.Style - { Format.Ledger.Write.style_color=False - , Format.Ledger.Write.style_align=True - } $ - Format.Ledger.Write.amount - Amount.nil - { Amount.quantity = Decimal 12 1234567890123456789 - , Amount.style = Amount.Style.nil - { Amount.Style.fractioning = Just '.' - , Amount.Style.precision = 12 - , Amount.Style.grouping_fractional = Just $ Amount.Style.Grouping ',' [3, 2, 1] - } - }) - ~?= - "1234567.890,12,3,4,5,6,7,8,9") - ] - , "amount_length" ~: TestList - [ "nil" ~: - ((Format.Ledger.Write.amount_length - Amount.nil) - ~?= - 1) - , "nil @ prec=2" ~: - ((Format.Ledger.Write.amount_length - Amount.nil - { Amount.style = Amount.Style.nil - { Amount.Style.precision = 2 } - }) - ~?= - 4) - , "123" ~: - ((Format.Ledger.Write.amount_length - Amount.nil - { Amount.quantity = Decimal 0 123 - }) - ~?= - 3) - , "-123" ~: - ((Format.Ledger.Write.amount_length - Amount.nil - { Amount.quantity = Decimal 0 (- 123) - }) - ~?= - 4) - , "12.3 @ prec=0" ~: - ((Format.Ledger.Write.amount_length - Amount.nil - { Amount.quantity = Decimal 1 123 - , Amount.style = Amount.Style.nil - { Amount.Style.fractioning = Just '.' - } - }) - ~?= - 2) - , "12.5 @ prec=0" ~: - ((Format.Ledger.Write.amount_length - Amount.nil - { Amount.quantity = Decimal 1 125 - , Amount.style = Amount.Style.nil - { Amount.Style.fractioning = Just '.' - } - }) - ~?= - 2) - , "12.3 @ prec=1" ~: - ((Format.Ledger.Write.amount_length - Amount.nil - { Amount.quantity = Decimal 1 123 - , Amount.style = Amount.Style.nil - { Amount.Style.fractioning = Just '.' - , Amount.Style.precision = 1 - } - }) - ~?= - 4) - , "1,234.56 @ prec=2" ~: - ((Format.Ledger.Write.amount_length - Amount.nil - { Amount.quantity = Decimal 2 123456 - , Amount.style = Amount.Style.nil - { Amount.Style.fractioning = Just '.' - , Amount.Style.precision = 2 - , Amount.Style.grouping_integral = Just $ Amount.Style.Grouping ',' [3] - } - }) - ~?= - 8) - , "123,456,789,01,2.3456789 @ prec=7" ~: - ((Format.Ledger.Write.amount_length - Amount.nil - { Amount.quantity = Decimal 7 1234567890123456789 - , Amount.style = Amount.Style.nil - { Amount.Style.fractioning = Just '.' - , Amount.Style.precision = 7 - , Amount.Style.grouping_integral = Just $ Amount.Style.Grouping ',' [1, 2, 3] - } - }) - ~?= - 24) - , "1234567.8,90,123,456,789 @ prec=12" ~: - ((Format.Ledger.Write.amount_length - Amount.nil - { Amount.quantity = Decimal 12 1234567890123456789 - , Amount.style = Amount.Style.nil - { Amount.Style.fractioning = Just '.' - , Amount.Style.precision = 12 - , Amount.Style.grouping_fractional = Just $ Amount.Style.Grouping ',' [1, 2, 3] - } - }) - ~?= - 24) - , "1,2,3,4,5,6,7,89,012.3456789 @ prec=7" ~: - ((Format.Ledger.Write.amount_length - Amount.nil - { Amount.quantity = Decimal 7 1234567890123456789 - , Amount.style = Amount.Style.nil - { Amount.Style.fractioning = Just '.' - , Amount.Style.precision = 7 - , Amount.Style.grouping_integral = Just $ Amount.Style.Grouping ',' [3, 2, 1] - } - }) - ~?= - 28) - , "1234567.890,12,3,4,5,6,7,8,9 @ prec=12" ~: - ((Format.Ledger.Write.amount_length - Amount.nil - { Amount.quantity = Decimal 12 1234567890123456789 - , Amount.style = Amount.Style.nil - { Amount.Style.fractioning = Just '.' - , Amount.Style.precision = 12 - , Amount.Style.grouping_fractional = Just $ Amount.Style.Grouping ',' [3, 2, 1] - } - }) - ~?= - 28) - , "1000000.000,00,0,0,0,0,0,0,0 @ prec=12" ~: - ((Format.Ledger.Write.amount_length - Amount.nil - { Amount.quantity = Decimal 12 1000000000000000000 - , Amount.style = Amount.Style.nil - { Amount.Style.fractioning = Just '.' - , Amount.Style.precision = 12 - , Amount.Style.grouping_fractional = Just $ Amount.Style.Grouping ',' [3, 2, 1] - } - }) - ~?= - 28) - , "999 @ prec=0" ~: - ((Format.Ledger.Write.amount_length $ - Amount.nil - { Amount.quantity = Decimal 0 999 - , Amount.style = Amount.Style.nil - { Amount.Style.precision = 0 - } - }) - ~?= - 3) - , "1000 @ prec=0" ~: - ((Format.Ledger.Write.amount_length $ - Amount.nil - { Amount.quantity = Decimal 0 1000 - , Amount.style = Amount.Style.nil - { Amount.Style.precision = 0 - } - }) - ~?= - 4) - , "10,00€ @ prec=2" ~: - ((Format.Ledger.Write.amount_length $ Amount.eur 10) - ~?= - 6) - ] - , "date" ~: TestList - [ "nil" ~: - ((Format.Ledger.Write.show - Format.Ledger.Write.Style - { Format.Ledger.Write.style_color=False - , Format.Ledger.Write.style_align=True - } $ - Format.Ledger.Write.date - Date.nil) - ~?= - "1970/01/01") - , "2000/01/01 12:34:51 CET" ~: - (Format.Ledger.Write.show - Format.Ledger.Write.Style - { Format.Ledger.Write.style_color=False - , Format.Ledger.Write.style_align=True - } $ - Format.Ledger.Write.date $ - Time.zonedTimeToUTC $ - Time.ZonedTime - (Time.LocalTime - (Time.fromGregorian 2000 01 01) - (Time.TimeOfDay 12 34 51)) - (Time.TimeZone 60 False "CET")) - ~?= - "2000/01/01 11:34:51" - , "2000/01/01 12:34:51 +0100" ~: - (Format.Ledger.Write.show - Format.Ledger.Write.Style - { Format.Ledger.Write.style_color=False - , Format.Ledger.Write.style_align=True - } $ - Format.Ledger.Write.date $ - Time.zonedTimeToUTC $ - Time.ZonedTime - (Time.LocalTime - (Time.fromGregorian 2000 01 01) - (Time.TimeOfDay 12 34 51)) - (Time.TimeZone 60 False "")) - ~?= - "2000/01/01 11:34:51" - , "2000/01/01 01:02:03" ~: - (Format.Ledger.Write.show - Format.Ledger.Write.Style - { Format.Ledger.Write.style_color=False - , Format.Ledger.Write.style_align=True - } $ - Format.Ledger.Write.date $ - Time.zonedTimeToUTC $ - Time.ZonedTime - (Time.LocalTime - (Time.fromGregorian 2000 01 01) - (Time.TimeOfDay 1 2 3)) - (Time.utc)) - ~?= - "2000/01/01 01:02:03" - , "01/01 01:02" ~: - (Format.Ledger.Write.show - Format.Ledger.Write.Style - { Format.Ledger.Write.style_color=False - , Format.Ledger.Write.style_align=True - } $ - Format.Ledger.Write.date $ - Time.zonedTimeToUTC $ - Time.ZonedTime - (Time.LocalTime - (Time.fromGregorian 0 01 01) - (Time.TimeOfDay 1 2 0)) - (Time.utc)) - ~?= - "01/01 01:02" - , "01/01 01:00" ~: - (Format.Ledger.Write.show - Format.Ledger.Write.Style - { Format.Ledger.Write.style_color=False - , Format.Ledger.Write.style_align=True - } $ - Format.Ledger.Write.date $ - Time.zonedTimeToUTC $ - Time.ZonedTime - (Time.LocalTime - (Time.fromGregorian 0 01 01) - (Time.TimeOfDay 1 0 0)) - (Time.utc)) - ~?= - "01/01 01:00" - , "01/01 00:01" ~: - (Format.Ledger.Write.show - Format.Ledger.Write.Style - { Format.Ledger.Write.style_color=False - , Format.Ledger.Write.style_align=True - } $ - Format.Ledger.Write.date $ - Time.zonedTimeToUTC $ - Time.ZonedTime - (Time.LocalTime - (Time.fromGregorian 0 01 01) - (Time.TimeOfDay 0 1 0)) - (Time.utc)) - ~?= - "01/01 00:01" - , "01/01" ~: - (Format.Ledger.Write.show - Format.Ledger.Write.Style - { Format.Ledger.Write.style_color=False - , Format.Ledger.Write.style_align=True - } $ - Format.Ledger.Write.date $ - Time.zonedTimeToUTC $ - Time.ZonedTime - (Time.LocalTime - (Time.fromGregorian 0 01 01) - (Time.TimeOfDay 0 0 0)) - (Time.utc)) - ~?= - "01/01" - ] , "transaction" ~: TestList [ "nil" ~: ((Format.Ledger.Write.show diff --git a/lib/hcompta-lib.cabal b/lib/hcompta-lib.cabal index fd7fd72..64ebf5c 100644 --- a/lib/hcompta-lib.cabal +++ b/lib/hcompta-lib.cabal @@ -56,26 +56,27 @@ Library Hcompta.Amount Hcompta.Amount.Quantity Hcompta.Amount.Read + Hcompta.Amount.Write Hcompta.Amount.Style Hcompta.Amount.Unit Hcompta.Balance Hcompta.Date Hcompta.Date.Read + Hcompta.Date.Write Hcompta.Filter Hcompta.Filter.Read - Hcompta.Format Hcompta.Format.CSV Hcompta.Format.Ledger Hcompta.Format.Ledger.Journal Hcompta.Format.Ledger.Read Hcompta.Format.Ledger.Write + Hcompta.GL Hcompta.Lib.Foldable Hcompta.Lib.Leijen Hcompta.Lib.Parsec Hcompta.Lib.Path Hcompta.Lib.Regex Hcompta.Lib.TreeMap - Hcompta.Stats build-depends: base >= 4.3 && < 5 , ansi-terminal >= 0.4 && < 0.7 -- 2.47.2