###
install: cabal/install lib/install cli/install web/install
cabal/install:
- cabal update $(CABAL_FLAGS) $(CABAL_UPDATE_FLAGS)
- cabal install -v $(CABAL_FLAGS) $(CABAL_INSTALL_FLAGS) cabal
+ cabal $(CABAL_FLAGS) update $(CABAL_UPDATE_FLAGS)
+ cabal $(CABAL_FLAGS) install -v $(CABAL_INSTALL_FLAGS) cabal
.PHONY: lib cli web
-lib lib/install:
- cabal install -v --force-reinstalls $(CABAL_FLAGS) $(CABAL_INSTALL_FLAGS) ./lib
+lib lib/install: cli/unregister web/unregister cli/unregister/sandbox web/unregister/sandbox
+ cabal $(CABAL_FLAGS) install -v $(CABAL_INSTALL_FLAGS) ./lib
cli cli/install:
- cabal install -v --force-reinstalls $(CABAL_FLAGS) $(CABAL_INSTALL_FLAGS) ./cli
+ cabal $(CABAL_FLAGS) install -v $(CABAL_INSTALL_FLAGS) ./cli
web web/install:
- cabal install -v $(CABAL_FLAGS) $(CABAL_INSTALL_FLAGS) alex happy
- cabal install -v --force-reinstalls $(CABAL_FLAGS) $(CABAL_INSTALL_FLAGS) ./web
+ cabal $(CABAL_FLAGS) install -v $(CABAL_INSTALL_FLAGS) alex happy
+ cabal $(CABAL_FLAGS) install -v $(CABAL_INSTALL_FLAGS) ./web
+
+%/recomp: CABAL_INSTALL_FLAGS+=--ghc-options -fforce-recomp
+%/recomp: %
+
#
## clean
###
test: lib/test cli/test web/test
lib/test:
- (cd lib && cabal test --show-details=always $(CABAL_FLAGS) $(CABAL_TEST_FLAGS))
+ (cd lib && cabal $(CABAL_FLAGS) test --show-details=always $(CABAL_TEST_FLAGS))
cli/test:
- (cd cli && cabal test --show-details=always $(CABAL_FLAGS) $(CABAL_TEST_FLAGS))
+ (cd cli && cabal $(CABAL_FLAGS) test --show-details=always $(CABAL_TEST_FLAGS))
web/test:
- (cd web && cabal test --show-details=always $(CABAL_FLAGS) $(CABAL_TEST_FLAGS))
+ (cd web && cabal $(CABAL_FLAGS) test --show-details=always $(CABAL_TEST_FLAGS))
%/install/test: CABAL_INSTALL_FLAGS+=--enable-tests
%/install/test: %/install
###
.PHONY: doc
doc: doc/xhtml lib/doc cli/doc web/doc
-%/prof: CABAL_INSTALL_FLAGS+=-fprof --ghc-options -fforce-recomp --enable-library-profiling --enable-executable-profiling
+%/prof: CABAL_INSTALL_FLAGS+=-fprof --enable-library-profiling --enable-executable-profiling
%/prof: $(CABAL_SANDBOX) %
lib/doc:
- (cd lib && cabal haddock --hyperlink-source $(CABAL_FLAGS) $(CABAL_HADDOCK_FLAGS))
+ (cd lib && cabal $(CABAL_FLAGS) haddock --hyperlink-source $(CABAL_HADDOCK_FLAGS))
cli/doc:
- (cd cli && cabal haddock --hyperlink-source $(CABAL_FLAGS) $(CABAL_HADDOCK_FLAGS))
+ (cd cli && cabal $(CABAL_FLAGS) haddock --hyperlink-source $(CABAL_HADDOCK_FLAGS))
web/doc:
- (cd web && cabal haddock --hyperlink-source $(CABAL_FLAGS) $(CABAL_HADDOCK_FLAGS))
+ (cd web && cabal $(CABAL_FLAGS) haddock --hyperlink-source $(CABAL_HADDOCK_FLAGS))
doc/%: .
$(MAKE) -C doc $*
%/dev: %
+#
+## dump
+###
+%/dump: CABAL_INSTALL_FLAGS+=-fdump
+%/dump: %
+
+
#
## prof
###
prof/commit/$(commit):
mkdir -p "$@"
-lib/install/prof: CABAL_INSTALL_FLAGS+=-fprof --ghc-options -fforce-recomp --enable-library-profiling
+lib/install/prof: CABAL_INSTALL_FLAGS+=-fprof --enable-library-profiling
lib/install/prof: cli/unregister/sandbox lib/install | $(CABAL_SANDBOX)
-cli/install/prof: CABAL_INSTALL_FLAGS+=-fprof --ghc-options -fforce-recomp --enable-library-profiling --enable-executable-profiling
+cli/install/prof: CABAL_INSTALL_FLAGS+=-fprof --enable-library-profiling --enable-executable-profiling
cli/install/prof: cli/install | $(CABAL_SANDBOX)
mv \
$(CABAL_SANDBOX)/bin/hcompta-cli \
$$(HCOMPTA_CLI_PROF) $$(HCOMPTA_FLAGS) \
$(command) $$(HCOMPTA_COMMAND_FLAGS) $$(filter %.ledger,$$^) \
>prof/$$*.ledger.$(command)
- mv hcompta-cli-prof.hp prof/commit/$(commit)/$$*.ledger.$(command).$(hC).hp
- mv hcompta-cli-prof.prof prof/commit/$(commit)/$$*.ledger.$(command).$(hC).prof
+ mv $(notdir $(HCOMPTA_CLI_PROF)).hp prof/commit/$(commit)/$$*.ledger.$(command).$(hC).hp
+ mv $(notdir $(HCOMPTA_CLI_PROF)).prof prof/commit/$(commit)/$$*.ledger.$(command).$(hC).prof
prof/$(command)/$(hC): \
$(addsuffix /$(command)/$(hC),$(wildcard prof/*.ledger))
prof/%.ledger/clean: \
$(foreach command,$(HCOMPTA_COMMANDS), \
- prof/%.ledger/$(command)/clean \
- )
+ prof/%.ledger/$(command)/clean )
$(foreach command,$(HCOMPTA_COMMANDS), \
%.ps: %.hp
(cd $(@D) && hp2ps -b -c -e$(GHC_PROF_PS_WIDTH) -g $(notdir $*.hp))
-#prof/%.ledger/clean:
-# $(call rmw, \
-# $(foreach command,$(HCOMPTA_COMMANDS), \
-# prof/$*.ledger.$(command) \
-# $(foreach hC,$(GHC_PROF_CATEGORIES),\
-# prof/commit/$(commit)/$*.ledger.$(command).$(hC).aux \
-# prof/commit/$(commit)/$*.ledger.$(command).$(hC).hp \
-# prof/commit/$(commit)/$*.ledger.$(command).$(hC).prof \
-# prof/commit/$(commit)/$*.ledger.$(command).$(hC).ps \
-# prof/commit/$(commit)/$*.ledger.$(command).$(hC).stats \
-# )))
-# $(call rmdirw,prof/commit/$(commit))
-
#
## not-threaded
###
%/not-threaded: %
-#
-## sandbox
-###
-$(CABAL_SANDBOX):
- cabal sandbox --sandbox="$@" init $(CABAL_FLAGS) $(CABAL_SANDBOX_FLAGS)
-
-%/sandbox: GHC_PKG:=cabal sandbox hc-pkg
-%/sandbox: %
-
-
#
## ghc-pkg
###
-
unregister: $(addsuffix /unregister,web cli lib)
-%/unregister:
+%/unregister: .
+ if $(GHC_PKG) list hcompta-$* | grep -q '^ * hcompta-$*-' ; \
+ then $(GHC_PKG) unregister hcompta-$* ; \
+ fi
+
+%/unregister/sandbox: GHC_PKG:=cabal sandbox hc-pkg
+%/unregister/sandbox: .
if $(GHC_PKG) list hcompta-$* | grep -q '^ * hcompta-$*-' ; \
then $(GHC_PKG) unregister hcompta-$* ; \
fi
+
+#
+## sandbox
+###
+$(CABAL_SANDBOX):
+ cabal $(CABAL_FLAGS) sandbox --sandbox="$@" $(CABAL_SANDBOX_FLAGS) init
+
+%/sandbox: GHC_PKG:=cabal sandbox hc-pkg
+%/sandbox: %
+
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Hcompta.CLI.Command.Balance where
import Prelude hiding (foldr)
+import Control.Applicative (Const(..))
import Control.Monad (liftM)
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 Data.Monoid ((<>))
+import qualified Data.Strict.Maybe as Strict
import qualified Data.Text.Lazy as TL
import System.Console.GetOpt
( ArgDescr(..)
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.Reduce as Filter.Reduce
import qualified Hcompta.Filter.Read as Filter.Read
import qualified Hcompta.Format.Ledger as Ledger
import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
CLI.Ledger.paths context $ ctx_input ctx ++ inputs
>>= do
mapM $ \path -> do
- liftIO $ runExceptT $ Ledger.Read.file path
+ liftIO $ runExceptT $ Ledger.Read.file
+ (Ledger.Read.context $ Ledger.journal
+ { Ledger.journal_transactions=Const
+ ( mempty
+ , ctx_filter_transaction ctx
+ , ctx_filter_posting ctx
+ ) })
+ path
>>= \x -> case x of
Left ko -> return $ Left (path, ko)
Right ok -> return $ Right ok
Write.debug context $ "filter: transaction: " ++ show (ctx_filter_transaction ctx)
Write.debug context $ "filter: posting: " ++ show (ctx_filter_posting ctx)
Write.debug context $ "filter: balance: " ++ show (ctx_filter_balance ctx)
- let (balance_by_account, balance_by_unit) =
+ let (balance_by_account, Balance.Balance_by_Unit balance_by_unit) =
ledger_balances ctx journals
style_color <- Write.with_color context IO.stdout
W.displayIO IO.stdout $
ledger_balances
:: Ctx
- -> [Ledger.Journal]
- -> ( Balance.Expanded (Amount.Sum Amount)
- , Balance.Balance_by_Unit (Amount.Sum Amount) Unit )
+ -> [Ledger.Journal (Const
+ ( Balance.Balance_by_Account (Amount.Sum Amount)
+ , Filter.Simplified (Filter.Filter_Bool (Filter.Filter_Transaction Ledger.Transaction))
+ , Filter.Simplified (Filter.Filter_Bool (Filter.Filter_Posting Ledger.Posting))
+ ))
+ Ledger.Transaction
+ ]
+ -> ( Balance.Expanded (Amount.Sum Amount)
+ , Balance.Balance_by_Unit (Amount.Sum Amount) )
ledger_balances ctx journals =
- let reducer_date =
- if ctx_reduce_date ctx
- then Filter.Reduce.bool_date <$> ctx_filter_transaction ctx
- else mempty in
let balance_by_account =
- foldr
- (Ledger.Journal.fold
- (\Ledger.Journal{Ledger.journal_transactions=ts} ->
- flip (foldr
- (\tr ->
- case Filter.test
- (Filter.simplify (ctx_filter_transaction ctx)
- (Nothing::Maybe Ledger.Transaction)) tr of
- False -> id
- True ->
- let filter_postings =
- Data.Foldable.concatMap $
- Data.List.filter $
- (Filter.test $ ctx_filter_posting ctx) in
- let balance =
- flip (foldr Balance.by_account) .
- map (\p ->
- ( Ledger.posting_account p
- , Data.Map.map 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)
- )) $ Compose $ Compose $
- case Filter.simplified reducer_date of
- Left reducer -> do
- let (ts_reduced, _date_sieve) = Filter.Reduce.map_date reducer ts
- ts_reduced
- Right True -> ts:[]
- Right False -> []
- )
- )
- (Balance.balance_by_account Balance.nil)
+ Data.List.foldl'
+ (flip $ Ledger.Journal.fold
+ (\Ledger.Journal{Ledger.journal_transactions=Const (b, _, _)} ->
+ mappend b))
+ mempty
journals in
let balance_expanded =
Lib.TreeMap.filter_with_Path_and_Node
(Data.Map.null
(Data.Map.filter
(not . Amount.is_zero . Amount.sum_balance)
- (Balance.inclusive balance))))
+ (Balance.get_Account_Sum $ 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 . Amount.sum_balance)
- (Balance.exclusive balance)))
+ (Balance.get_Account_Sum $ 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
+ ( Strict.maybe False
( not . Data.Foldable.all
( Amount.is_zero
. Amount.sum_balance )
+ . Balance.get_Account_Sum
. Balance.inclusive )
. Lib.TreeMap.node_value )
descendants) > 1
then
Data.Foldable.any
(Filter.test (ctx_filter_balance ctx) . (acct,)) $
+ Balance.get_Account_Sum $
Balance.inclusive balance
else False
) $
let balance_by_unit =
Balance.by_unit_of_expanded
balance_expanded
- (Balance.balance_by_unit Balance.nil) in
+ mempty in
( balance_expanded
, balance_by_unit
)
]
)
rows $
- let bal = Balance.inclusive balance in
+ let bal = Balance.get_Account_Sum $ Balance.inclusive balance in
Data.Map.foldrWithKey
(\unit amount acc ->
( maybe Nothing Amount.sum_positive $ Data.Map.lookup unit $ bal
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module Hcompta.CLI.Command.GL where
+import Control.Applicative (Const(..))
import Control.Monad (liftM)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Except (runExceptT)
import qualified Data.Either
import qualified Data.Foldable
-import Data.Functor.Compose (Compose(..))
-import qualified Data.List
import qualified Data.Map.Strict as Data.Map
import Data.Monoid ((<>))
import qualified Data.Sequence
+import qualified Data.Strict.Maybe as Strict
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL
import Prelude hiding (foldr)
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.Filter.Reduce as Filter.Reduce
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
CLI.Ledger.paths context $ ctx_input ctx ++ inputs
>>= do
mapM $ \path -> do
- liftIO $ runExceptT $ Ledger.Read.file path
+ liftIO $ runExceptT $ Ledger.Read.file
+ (Ledger.Read.context $ Ledger.journal
+ { Ledger.journal_transactions=Const
+ ( mempty
+ , ctx_filter_transaction ctx
+ , ctx_filter_posting ctx
+ ) })
+ path
>>= \x -> case x of
Left ko -> return $ Left (path, ko)
Right ok -> return $ Right ok
ledger_gl
:: Ctx
- -> [Ledger.Journal]
+ -> [Ledger.Journal (Const
+ ( GL.GL Ledger.Transaction
+ , Filter.Simplified (Filter.Filter_Bool (Filter.Filter_Transaction Ledger.Transaction))
+ , Filter.Simplified (Filter.Filter_Bool (Filter.Filter_Posting Ledger.Posting))
+ ))
+ Ledger.Transaction
+ ]
-> GL Ledger.Transaction
ledger_gl ctx journals =
- let reducer_date =
- if ctx_reduce_date ctx
- then Filter.Reduce.bool_date <$> ctx_filter_transaction ctx
- else mempty in
let gl =
Data.Foldable.foldl'
(flip $ Ledger.Journal.fold
- (\Ledger.Journal{Ledger.journal_transactions=ts} ->
- flip (Data.Foldable.foldl'
- (flip $ (\t ->
- case Filter.test (ctx_filter_transaction ctx) t of
- False -> id
- 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 $ ctx_filter_posting ctx) ps of
- [] -> Nothing
- x -> Just x)
- (Ledger.transaction_postings t)
- }
- ))) $ Compose $ Compose $
- case Filter.simplified reducer_date of
- Left reducer -> do
- let (ts_reduced, _date_sieve) = Filter.Reduce.map_date reducer ts
- ts_reduced
- Right True -> ts:[]
- Right False -> []
- )
- )
- GL.nil
- journals in
+ (\Ledger.Journal{Ledger.journal_transactions=Const (g, _, _)} ->
+ GL.union g))
+ mempty journals in
GL.GL $
Lib.TreeMap.map_Maybe_with_Path
(\acct expanded_lines ->
m -> Just m
)
(GL.inclusive expanded_lines) of
- m | Data.Map.null m -> Nothing
- m -> Just m
+ m | Data.Map.null m -> Strict.Nothing
+ m -> Strict.Just m
) $
GL.expanded gl
{-# LANGUAGE TupleSections #-}
module Hcompta.CLI.Command.Journal where
--- import Control.Applicative ((<$>))
-import Control.Monad (foldM, liftM)
+import Control.Applicative (Const(..))
+import Control.Monad ({-foldM,-} liftM)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Except (runExceptT)
import qualified Data.Either
import Data.Foldable ()
-import Data.Functor.Compose (Compose(..))
import qualified Data.List
-import qualified Data.Map.Strict as Data.Map
import System.Console.GetOpt
( ArgDescr(..)
, OptDescr(..)
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.Lib.Interval as Interval
+import qualified Hcompta.Journal as Journal
data Ctx
= Ctx
CLI.Ledger.paths context $ ctx_input ctx ++ inputs
>>= do
mapM $ \path -> do
- liftIO $ runExceptT $ Ledger.Read.file path
+ liftIO $ runExceptT $ Ledger.Read.file
+ (Ledger.Read.context $ Ledger.journal
+ { Ledger.journal_transactions=Const
+ ( mempty
+ , ctx_filter_transaction ctx
+ -- , ctx_filter_posting ctx
+ ) })
+ path
>>= \x -> case x of
Left ko -> return $ Left (path, ko)
Right ok -> return $ Right ok
{ Ledger.Write.style_align = ctx_align ctx
, Ledger.Write.style_color
}
- transactions <-
- foldM
- (flip (Ledger.Journal.foldM
- (\j j_ts -> do
- let ts = Ledger.journal_transactions j
- liftM
- (Data.Map.unionsWith (++) . (:) j_ts) $
- case Filter.simplified $ ctx_filter_transaction ctx of
- Right True -> return $ ts:[]
- Right False -> return $ []
- Left flt ->
- liftM
- (Data.List.map
- (Data.Map.mapMaybe
- (\lt ->
- case Data.List.filter (Filter.test flt) lt of
- [] -> Nothing
- l -> Just l
- ))) $
- case Filter.simplified reducer_date of
- Left reducer -> do
- let (ts_reduced, date_sieve) = Filter.Reduce.map_date reducer ts
- Write.debug context $ "filter: transaction: sieve: "
- ++ "journal=" ++ (show $ Ledger.journal_file j)
- ++ ": " ++ show (Interval.Pretty date_sieve)
- return ts_reduced
- Right True -> return $ ts:[]
- Right False -> return $ []
- )))
- Data.Map.empty
- journals
+ let journal = ledger_journal ctx journals
Ledger.Write.put sty IO.stdout $ do
- Ledger.Write.transactions (Compose transactions)
+ Ledger.Write.transactions journal
+
+ledger_journal
+ :: Ctx
+ -> [Ledger.Journal (Const
+ ( Journal.Journal Ledger.Transaction
+ , Filter.Simplified (Filter.Filter_Bool (Filter.Filter_Transaction Ledger.Transaction))
+ ))
+ Ledger.Transaction
+ ]
+ -> Journal.Journal Ledger.Transaction
+ledger_journal _ctx journals =
+ Data.List.foldl'
+ (flip $ Ledger.Journal.fold
+ (\Ledger.Journal{Ledger.journal_transactions=Const (ts, _)} ->
+ mappend ts))
+ mempty
+ journals
else
ghc-options: -O2
if flag(dump)
- ghc-options: -ddump-ds -ddump-simple -ddump-splices -ddump-stg -ddump-to-file
+ ghc-options: -ddump-ds -ddump-simpl -ddump-splices -ddump-stg -ddump-to-file
if flag(prof)
cpp-options: -DPROFILING
ghc-options: -fprof-auto
, containers
-- , directory
, hcompta-lib
- , HUnit
+ -- , HUnit
, io-memoize >= 1.1
-- NOTE: needed for System.IO.Memoize.once
, parsec
-- , safe >= 0.2
+ , strict
-- , template-haskell
, text
, transformers >= 0.4 && < 0.5
-- NOTE: needed for Data.Map.Strict
-- , directory
, hcompta-lib
- , HUnit
+ -- , HUnit
, io-memoize >= 1.1
-- NOTE: needed for System.IO.Memoize.once
, parsec
-- , safe >= 0.2
+ , strict
-- , template-haskell
, text
, transformers >= 0.4 && < 0.5
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hcompta.Amount where
+import Control.DeepSeq
import Data.Data
import qualified Data.List
import qualified Data.Map.Strict as Data.Map
data Amount
= Amount
- { quantity :: Quantity
- , style :: Style
- , unit :: Unit
+ { quantity :: !Quantity
+ , style :: !Style
+ , unit :: !Unit
} deriving (Data, Show, Typeable)
+instance NFData (Amount) where
+ rnf (Amount q s u) = rnf q `seq` rnf s `seq` rnf u
instance Eq Amount where
(==)
-- | Sum separately keeping track of negative and positive 'amount's.
data Sum amount
- = Sum_Negative amount
- | Sum_Positive amount
- | Sum_Both amount amount
+ = Sum_Negative !amount
+ | Sum_Positive !amount
+ | Sum_Both !amount !amount
deriving (Data, Eq, Show, Typeable)
+instance NFData amount => NFData (Sum amount) where
+ rnf (Sum_Negative a) = rnf a
+ rnf (Sum_Positive a) = rnf a
+ rnf (Sum_Both a0 a1) = rnf a0 `seq` rnf a1
instance Functor Sum where
fmap f (Sum_Negative a) = Sum_Negative (f a)
{-# LANGUAGE DeriveDataTypeable #-}
module Hcompta.Amount.Style where
+import Control.DeepSeq
import Data.Data
import Data.Word (Word8)
import Data.Typeable ()
, unit_side :: Maybe Side
, unit_spaced :: Maybe Spacing
} deriving (Data, Eq, Ord, Read, Show, Typeable)
+instance NFData Style where
+ rnf (Style f gi gf p ui up) =
+ rnf f `seq`
+ rnf gi `seq`
+ rnf gf `seq`
+ rnf p `seq`
+ rnf ui `seq`
+ rnf up
type Fractioning
= Char
data Grouping
= Grouping Char [Int]
deriving (Data, Eq, Ord, Read, Show, Typeable)
+instance NFData Grouping where
+ rnf (Grouping s d) = rnf s `seq` rnf d
type Precision
= Word8
= Side_Left
| Side_Right
deriving (Data, Eq, Ord, Read, Show, Typeable)
+instance NFData Side where
+ rnf Side_Left = ()
+ rnf Side_Right = ()
-- * Constructors
{-# LANGUAGE OverloadedStrings #-}
module Hcompta.Amount.Unit where
+import Control.DeepSeq
import Data.Data
import Data.String (IsString)
import qualified Data.Text as Text
newtype Unit
= Unit Text
deriving (Data, Eq, IsString, Ord, Show, Typeable)
+instance NFData Unit where
+ rnf (Unit t) = rnf t
-- NOTE: maybe consider using text-show package
text :: Unit -> Text
+{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-deprecations #-} -- FIXME: to be removed when dropping GHC-7.6 support
module Hcompta.Balance where
+import Control.Applicative (Const(..))
import Control.Exception (assert)
import Data.Data
import qualified Data.Foldable
-- import Data.Foldable (Foldable(..))
import qualified Data.Map.Strict as Data.Map
import Data.Map.Strict (Map)
-import Data.Maybe (fromMaybe)
+import qualified Data.Strict.Maybe as Strict
import Data.Typeable ()
+import Hcompta.Lib.Consable (Consable(..))
import qualified Hcompta.Lib.Foldable as Lib.Foldable
import qualified Hcompta.Lib.TreeMap as Lib.TreeMap
import Hcompta.Lib.TreeMap (TreeMap)
posting_amounts :: p -> Map (Amount_Unit (Posting_Amount p)) (Posting_Amount p)
posting_set_amounts :: Map (Amount_Unit (Posting_Amount p)) (Posting_Amount p) -> p -> p
+{-
instance (Amount amount, unit ~ Amount_Unit amount)
=> Posting (Account, Map unit amount)
where
posting_account = fst
posting_amounts = snd
posting_set_amounts amounts (acct, _) = (acct, amounts)
+-}
+
+instance (Amount amount)
+ => Posting (Account, Account_Sum amount)
+ where
+ type Posting_Amount (Account, Account_Sum amount) = amount
+ posting_account = fst
+ posting_amounts (_, Account_Sum x) = x
+ posting_set_amounts amounts (acct, _) = (acct, Account_Sum amounts)
-- * Type 'Balance'
-- | Sum by 'Account' and sum by 'unit' of some 'Posting's.
-data Amount amount => Balance amount
+data Amount amount
+ => Balance amount
= Balance
- { balance_by_account :: Balance_by_Account amount (Amount_Unit amount)
- , balance_by_unit :: Balance_by_Unit amount (Amount_Unit amount)
+ { balance_by_account :: !(Balance_by_Account amount)
+ , balance_by_unit :: !(Balance_by_Unit amount)
}
deriving instance ( Amount amount
, Data amount
deriving instance Typeable1 Balance
-- FIXME: use 'Typeable' when dropping GHC-7.6 support
-type Balance_by_Account amount unit
+instance Amount amount => Monoid (Balance amount) where
+ mempty = empty
+ mappend = union
+
+-- ** Type 'Balance_by_Account'
+type Balance_by_Account amount
= TreeMap Account.Name
- (Account_Sum amount unit)
+ (Account_Sum amount)
+-- *** Type 'Account_Sum'
-- | A sum of 'amount's,
-- concerning a single 'Account'.
-type Account_Sum amount unit
- = Data.Map.Map unit amount
+newtype Amount amount
+ => Account_Sum amount
+ = Account_Sum (Map (Amount_Unit amount) amount)
+get_Account_Sum :: Amount amount => Account_Sum amount -> Map (Amount_Unit amount) amount
+get_Account_Sum (Account_Sum m) = m
+deriving instance ( Amount amount
+ , Data amount
+ ) => Data (Account_Sum amount)
+deriving instance ( Amount amount
+ , Eq amount
+ ) => Eq (Account_Sum amount)
+deriving instance ( Amount amount
+ , Show amount
+ ) => Show (Account_Sum amount)
+deriving instance Typeable1 Account_Sum
+ -- FIXME: use 'Typeable' when dropping GHC-7.6 support
+
+instance Amount amount
+ => Monoid (Account_Sum amount) where
+ mempty = Account_Sum mempty
+ mappend
+ (Account_Sum a0)
+ (Account_Sum a1) =
+ Account_Sum $ Data.Map.unionWith amount_add a0 a1
+
+{- NOTE: overlapping with the instance below.
+instance
+ ( Posting posting
+ , amount ~ Posting_Amount posting
+ )
+ => Consable (Const (Balance_by_Account amount)) posting where
+ mcons p = Const . by_account p . getConst
+-}
+instance
+ ( Foldable foldable
+ , Posting posting
+ , amount ~ Posting_Amount posting
+ )
+ => Consable (Const (Balance_by_Account amount))
+ (foldable posting) where
+ mcons ps (Const !bal) =
+ Const $ Data.Foldable.foldr by_account bal ps
+
+-- ** Type 'Balance_by_Unit'
+newtype Amount amount
+ => Balance_by_Unit amount
+ = Balance_by_Unit (Map (Amount_Unit amount) (Unit_Sum amount))
+deriving instance ( Amount amount
+ , Data amount
+ ) => Data (Balance_by_Unit amount)
+deriving instance ( Amount amount
+ , Eq amount
+ ) => Eq (Balance_by_Unit amount)
+deriving instance ( Amount amount
+ , Show amount
+ ) => Show (Balance_by_Unit amount)
+deriving instance Typeable1 Balance_by_Unit
+ -- FIXME: use 'Typeable' when dropping GHC-7.6 support
+
+instance Amount amount
+ => Monoid (Balance_by_Unit amount) where
+ mempty = Balance_by_Unit mempty
+ mappend = union_by_unit
-type Balance_by_Unit amount unit
- = Map unit (Unit_Sum amount)
+-- *** Type 'Unit_Sum'
-- | A sum of 'amount's with their 'Account's involved,
-- concerning a single 'unit'.
data Unit_Sum amount
= Unit_Sum
- { unit_sum_amount :: amount -- ^ The sum of 'amount's for a single 'unit'.
- , unit_sum_accounts :: Map Account () -- ^ The 'Account's involved to build 'unit_sum_amount'.
+ { unit_sum_amount :: !amount -- ^ The sum of 'amount's for a single 'unit'.
+ , unit_sum_accounts :: !(Map Account ()) -- ^ The 'Account's involved to build 'unit_sum_amount'.
} deriving (Data, Eq, Show, Typeable)
-- ** Constructors
-nil :: Amount amount => Balance amount
-nil =
+empty :: Amount amount => Balance amount
+empty =
Balance
- { balance_by_account = Lib.TreeMap.empty
- , balance_by_unit = Data.Map.empty
+ { balance_by_account = mempty
+ , balance_by_unit = mempty
}
-- | Return the 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)
+union
+ (Balance b0a b0u)
+ (Balance b1a b1u) =
+ Balance
+ { balance_by_account = union_by_account b0a b1a
+ , balance_by_unit = union_by_unit b0u b1u
}
-- | Return the given 'Balance_by_Account'
by_account ::
( Posting posting
, amount ~ Posting_Amount posting
- , unit ~ Amount_Unit amount )
+ , unit ~ Amount_Unit amount
+ )
=> posting
- -> Balance_by_Account amount unit
- -> Balance_by_Account amount unit
+ -> Balance_by_Account amount
+ -> Balance_by_Account amount
by_account post =
- Lib.TreeMap.insert
- (Data.Map.unionWith (flip amount_add))
+ Lib.TreeMap.insert mappend
(posting_account post)
- (posting_amounts post)
+ (Account_Sum $ posting_amounts post)
-- | Return the given 'Balance_by_Unit'
-- updated by the given 'Posting'.
, amount ~ Posting_Amount posting
, unit ~ Amount_Unit amount )
=> posting
- -> Balance_by_Unit amount unit
- -> Balance_by_Unit amount unit
-by_unit post bal =
- 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)
- })
- bal $
+ -> Balance_by_Unit amount
+ -> Balance_by_Unit amount
+by_unit post =
+ union_by_unit $
+ Balance_by_Unit $
Data.Map.map
(\amount -> Unit_Sum
{ unit_sum_amount = amount
( Amount amount
, unit ~ Amount_Unit amount
)
- => Balance_by_Account amount unit
- -> Balance_by_Unit amount unit
- -> Balance_by_Unit amount unit
+ => Balance_by_Account amount
+ -> Balance_by_Unit amount
+ -> Balance_by_Unit amount
by_unit_of_by_account =
flip $ Lib.TreeMap.foldr_with_Path $ curry by_unit
-- | 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))
+union_by_account :: Amount amount
+ => Balance_by_Account amount
+ -> Balance_by_Account amount
+ -> Balance_by_Account amount
+union_by_account = Lib.TreeMap.union mappend
-- | 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 =
+ => Balance_by_Unit amount
+ -> Balance_by_Unit amount
+ -> Balance_by_Unit amount
+union_by_unit
+ (Balance_by_Unit a0)
+ (Balance_by_Unit a1) =
+ Balance_by_Unit $
Data.Map.unionWith
(\new old -> Unit_Sum
{ unit_sum_amount = amount_add
(unit_sum_accounts old)
(unit_sum_accounts new)
})
+ a0 a1
-- * Type 'Deviation'
-- is not zero and possible 'Account' to 'infer_equilibrium'.
newtype Amount amount
=> Deviation amount
- = Deviation (Balance_by_Unit amount (Amount_Unit amount))
+ = Deviation (Balance_by_Unit amount)
deriving instance ( Amount amount
- , Data amount
+ , Data amount
) => Data (Deviation amount)
deriving instance ( Amount amount
- , Eq amount
+ , Eq amount
) => Eq (Deviation amount)
deriving instance ( Amount amount
- , Show amount
+ , Show amount
) => Show (Deviation amount)
deriving instance Typeable1 Deviation
-- FIXME: use 'Typeable' when dropping GHC-7.6 support
:: Amount amount
=> Balance amount
-> Deviation amount
-deviation bal = do
- let all_accounts = Lib.TreeMap.flatten (const ()) (balance_by_account bal)
+deviation Balance
+ { balance_by_account=ba
+ , balance_by_unit=Balance_by_Unit bu
+ } = do
+ let all_accounts = Lib.TreeMap.flatten (const ()) ba
let max_accounts = Data.Map.size all_accounts
Deviation $
Data.Map.foldlWithKey
- (\m unit Unit_Sum{unit_sum_amount, unit_sum_accounts} ->
+ (\(Balance_by_Unit m) unit Unit_Sum{unit_sum_amount, unit_sum_accounts} ->
+ Balance_by_Unit $
if amount_null unit_sum_amount
then m
else
, unit_sum_accounts = diff
} m
)
- Data.Map.empty
- (balance_by_unit bal)
+ mempty
+ bu
-- ** The equilibrium
, Either [Unit_Sum (Posting_Amount posting)] (Map Account [posting])
)
infer_equilibrium posts = do
- let bal_initial = Data.Foldable.foldr postings nil posts
- let Deviation dev = deviation bal_initial
+ let bal_initial = Data.Foldable.foldr postings empty posts
+ let Deviation (Balance_by_Unit dev) = deviation bal_initial
let (bal_adjusted, eithers) =
Data.Map.foldrWithKey
(\unit unit_sum@(Unit_Sum{unit_sum_amount, unit_sum_accounts})
let acct = fst $ Data.Map.elemAt 0 unit_sum_accounts in
let amt = amount_negate unit_sum_amount in
let amts = Data.Map.singleton unit amt in
- ( balance (acct, amts) bal
+ ( balance (acct, Account_Sum amts) bal
, Right (acct, unit, amt) : lr
)
_ -> (bal, Left [unit_sum] : lr))
-- | Return 'True' if and only if the given 'Deviation' maps no 'unit'.
is_at_equilibrium :: Amount amount => Deviation amount -> Bool
-is_at_equilibrium (Deviation dev) = Data.Map.null dev
+is_at_equilibrium (Deviation (Balance_by_Unit dev)) = Data.Map.null dev
-- | Return 'True' if and only if the given 'Deviation'
-- maps only to 'Unit_Sum's whose 'unit_sum_accounts'
-- maps exactly one 'Account'.
is_equilibrium_inferrable :: Amount amount => Deviation amount -> Bool
-is_equilibrium_inferrable (Deviation dev) =
+is_equilibrium_inferrable (Deviation (Balance_by_Unit dev)) =
Data.Foldable.all
(\Unit_Sum{unit_sum_accounts} -> Data.Map.size unit_sum_accounts == 1)
dev
-- maps to at least one 'Unit_Sum' whose 'unit_sum_accounts'
-- maps more than one 'Account'.
is_equilibrium_non_inferrable :: Amount amount => Deviation amount -> Bool
-is_equilibrium_non_inferrable (Deviation dev) =
+is_equilibrium_non_inferrable (Deviation (Balance_by_Unit dev)) =
Data.Foldable.any
(\Unit_Sum{unit_sum_accounts} -> Data.Map.size unit_sum_accounts > 1)
dev
= TreeMap Account.Name (Account_Sum_Expanded amount)
data Amount amount => Account_Sum_Expanded amount
= Account_Sum_Expanded
- { exclusive :: Map (Amount_Unit amount) amount
- , inclusive :: Map (Amount_Unit amount) amount -- ^ 'amount_add' folded over 'exclusive' and 'inclusive' of 'Lib.TreeMap.node_descendants'
+ { exclusive :: !(Account_Sum amount)
+ , inclusive :: !(Account_Sum amount) -- ^ 'amount_add' folded over 'exclusive' and 'inclusive' of 'Lib.TreeMap.node_descendants'
}
deriving instance ( Amount amount
, Data amount
deriving instance Typeable1 Account_Sum_Expanded
-- FIXME: use 'Typeable' when dropping GHC-7.6 support
+instance Amount amount => Monoid (Account_Sum_Expanded amount) where
+ mempty = Account_Sum_Expanded mempty mempty
+ mappend
+ (Account_Sum_Expanded e0 i0)
+ (Account_Sum_Expanded e1 i1) =
+ Account_Sum_Expanded
+ (mappend e0 e1)
+ (mappend i0 i1)
+
-- | Return the given 'Balance_by_Account' with:
--
-- * all missing 'Account.ascending' 'Account's inserted,
-- of the 'Account's for which it is 'Account.ascending'.
expanded
:: Amount amount
- => Balance_by_Account amount (Amount_Unit amount)
+ => Balance_by_Account amount
-> Expanded amount
expanded =
- let from_value = fromMaybe (assert False undefined) . Lib.TreeMap.node_value in
Lib.TreeMap.map_by_depth_first
(\descendants value ->
- let nodes = Lib.TreeMap.nodes descendants in
- let exclusive = fromMaybe Data.Map.empty value in
+ let exclusive = Strict.fromMaybe mempty value in
Account_Sum_Expanded
{ exclusive
, inclusive =
- Data.Map.foldr
- (Data.Map.unionWith amount_add . inclusive . from_value)
- exclusive nodes
+ Data.Map.foldl'
+ ( flip $ mappend . inclusive
+ . Strict.fromMaybe (assert False undefined)
+ . Lib.TreeMap.node_value)
+ exclusive $
+ Lib.TreeMap.nodes descendants
})
-- | Return a 'Balance_by_Unit'
, unit ~ Amount_Unit amount
)
=> Expanded amount
- -> Balance_by_Unit amount unit
- -> Balance_by_Unit amount unit
+ -> Balance_by_Unit amount
+ -> Balance_by_Unit amount
by_unit_of_expanded =
go []
where
Data.Map.foldrWithKey
(\k Lib.TreeMap.Node{Lib.TreeMap.node_value, Lib.TreeMap.node_descendants} acc ->
case node_value of
- Nothing -> go (k:p) node_descendants acc
- Just a ->
+ Strict.Nothing -> go (k:p) node_descendants acc
+ Strict.Just a ->
let account = Lib.TreeMap.reverse $ Lib.TreeMap.path k p in
by_unit (account, inclusive a) acc)
bal m
+{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
module Hcompta.Filter where
-- import Control.Applicative (pure, (<$>), (<*>))
+import Control.Applicative (Const(..))
import Data.Data
import qualified Data.Fixed
import qualified Data.Foldable
-- import Data.Foldable (Foldable(..))
-import qualified Data.Functor.Compose
+-- import Data.Functor.Compose (Compose(..))
-- import qualified Data.List
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Data.Map
import qualified Data.List.NonEmpty as NonEmpty
-- import Data.List.NonEmpty (NonEmpty(..))
+import Hcompta.Lib.Consable (Consable(..))
import Hcompta.Lib.Interval (Interval)
import qualified Hcompta.Lib.Interval as Interval
import qualified Hcompta.Lib.Regex as Regex
-- import qualified Hcompta.Date as Date
import qualified Hcompta.Balance as Balance
import qualified Hcompta.GL as GL
+import qualified Hcompta.Journal as Journal
-- * Requirements' interface
, Show (Amount_Unit a)
, Unit (Amount_Unit a)
)
- => Amount a where
+ => Amount a where
type Amount_Unit a
type Amount_Quantity a
amount_unit :: a -> Amount_Unit a
-- ** Class 'Posting'
class Amount (Posting_Amount p)
- => Posting p where
+ => Posting p where
type Posting_Amount p
posting_account :: p -> Account
posting_amounts :: p -> Map (Amount_Unit (Posting_Amount p)) (Posting_Amount p)
-- ** Class 'Transaction'
-class Posting (Transaction_Posting t)
- => Transaction t where
- type Transaction_Posting t
+class
+ ( Posting (Transaction_Posting t)
+ , Foldable (Transaction_Postings t)
+ )
+ => Transaction t where
+ type Transaction_Posting t
+ type Transaction_Postings t :: * -> *
transaction_date :: t -> Date
transaction_description :: t -> Text
- transaction_postings :: t -> Map Account [Transaction_Posting t]
+ transaction_postings :: t -> Transaction_Postings t (Transaction_Posting t)
transaction_tags :: t -> Map Text [Text]
-- ** Class 'Balance'
class Amount (Balance_Amount b)
- => Balance b where
+ => Balance b where
type Balance_Amount b
balance_account :: b -> Account
balance_amount :: b -> Balance_Amount b
balance_negative :: b -> Maybe (Balance_Amount b)
instance (Amount a, Balance.Amount a)
- => Balance (Account, Amount.Sum a) where
+ => Balance (Account, Amount.Sum a) where
type Balance_Amount (Account, Amount.Sum a) = a
balance_account = fst
balance_amount (_, amt) =
-- ** Class 'GL'
class Amount (GL_Amount r)
- => GL r where
+ => GL r where
type GL_Amount r
gl_account :: r -> Account
gl_date :: r -> Date
gl_sum_balance :: r -> GL_Amount r
instance (Amount a, GL.Amount a)
- => GL (Account, Date, Amount.Sum a, Amount.Sum a) where
+ => GL (Account, Date, Amount.Sum a, Amount.Sum a) where
type GL_Amount (Account, Date, Amount.Sum a, Amount.Sum a) = a
gl_account (x, _, _, _) = x
gl_date (_, x, _, _) = x
type Filter_Quantity q
= Filter_Ord q
-data Amount a
+data Amount a
=> Filter_Amount a
= Filter_Amount
{ filter_amount_quantity :: Filter_Quantity (Amount_Quantity a)
-- ** Type 'Filter_Posting'
-data Posting posting
+data Posting posting
=> Filter_Posting posting
= Filter_Posting_Account Filter_Account
| Filter_Posting_Amount (Filter_Amount (Posting_Amount posting))
-- ** Type 'Filter_Transaction'
-data Transaction t
+data Transaction t
=> Filter_Transaction t
= Filter_Transaction_Description Filter_Text
| Filter_Transaction_Posting (Filter_Posting (Transaction_Posting t))
test f $ transaction_description t
test (Filter_Transaction_Posting f) t =
Data.Foldable.any (test f) $
- Data.Functor.Compose.Compose $
transaction_postings t
test (Filter_Transaction_Date f) t =
test f $ transaction_date t
(Data.Monoid.Any False) $
transaction_tags t
+instance
+ ( Transaction transaction
+ , Journal.Transaction transaction
+ )
+ => Consable (Const
+ ( Journal.Journal transaction
+ , Simplified
+ (Filter_Bool
+ (Filter_Transaction transaction))
+ ))
+ transaction where
+ mcons t (Const (!j, ft)) =
+ Const . (, ft) $
+ if test ft t
+ then Journal.journal t j
+ else j
+
+instance
+ ( Foldable foldable
+ , Transaction transaction
+ , Journal.Transaction transaction
+ )
+ => Consable (Const
+ ( Journal.Journal transaction
+ , Simplified
+ (Filter_Bool
+ (Filter_Transaction transaction))
+ ))
+ (foldable transaction) where
+ mcons ts (Const (!j, ft)) =
+ Const . (, ft) $
+ case simplified ft of
+ Right False -> j
+ Right True ->
+ Data.Foldable.foldr
+ Journal.journal
+ j ts
+ Left f ->
+ Data.Foldable.foldr
+ (\t ->
+ if test f t
+ then Journal.journal t
+ else id
+ ) j ts
+
-- ** Type 'Filter_Balance'
-data Balance b
+data Balance b
=> Filter_Balance b
= Filter_Balance_Account Filter_Account
| Filter_Balance_Amount (Filter_Amount (Balance_Amount b))
Data.Foldable.any (test f) $
balance_negative b
+instance
+ ( Balance.Posting posting
+ , Posting posting
+ , amount ~ Balance.Posting_Amount posting
+ )
+ => Consable (Const
+ ( Balance.Balance_by_Account amount
+ , Simplified
+ (Filter_Bool
+ (Filter_Posting posting))
+ ))
+ posting where
+ mcons p (Const (!b, fp)) =
+ Const . (, fp) $
+ case simplified fp of
+ Right False -> b
+ Right True -> Balance.by_account p b
+ Left f ->
+ if test f p
+ then Balance.by_account p b
+ else b
+
+instance
+ ( Transaction transaction
+ , posting ~ Transaction_Posting transaction
+ , amount ~ Balance.Posting_Amount posting
+ , Balance.Amount amount
+ , Balance.Posting posting
+ )
+ => Consable (Const
+ ( Balance.Balance_by_Account amount
+ , Simplified
+ (Filter_Bool
+ (Filter_Transaction transaction))
+ , Simplified
+ (Filter_Bool
+ (Filter_Posting posting))
+ ))
+ transaction where
+ mcons t (Const (!bal, ft, fp)) =
+ Const . (, ft, fp) $
+ case simplified ft of
+ Right False -> bal
+ Right True -> filter_postings $ transaction_postings t
+ Left f ->
+ if test f t
+ then filter_postings $ transaction_postings t
+ else bal
+ where filter_postings ps =
+ case simplified fp of
+ Right False -> bal
+ Right True ->
+ Data.Foldable.foldl'
+ (flip Balance.by_account)
+ bal ps
+ Left ff ->
+ Data.Foldable.foldl'
+ (\b p -> if test ff p then Balance.by_account p b else b)
+ bal ps
+instance
+ ( Foldable foldable
+ , Balance.Posting posting
+ , Posting posting
+ , amount ~ Balance.Posting_Amount posting
+ )
+ => Consable (Const
+ ( Balance.Balance_by_Account amount
+ , Simplified
+ (Filter_Bool
+ (Filter_Posting posting))
+ ))
+ (foldable posting) where
+ mcons ps (Const (!bal, fp)) =
+ Const . (, fp) $
+ case simplified fp of
+ Right False -> bal
+ Right True ->
+ Data.Foldable.foldl'
+ (flip Balance.by_account) bal ps
+ Left f ->
+ Data.Foldable.foldl' (\b p ->
+ if test f p
+ then Balance.by_account p b
+ else b) bal ps
+
-- ** Type 'Filter_GL'
-data GL r
+data GL r
=> Filter_GL r
= Filter_GL_Account Filter_Account
| Filter_GL_Amount_Positive (Filter_Amount (GL_Amount r))
gl_sum_negative r
test (Filter_GL_Sum_Balance f) r =
test f $ gl_sum_balance r
+
+instance
+ ( GL.Transaction transaction
+ , Transaction transaction
+ , Posting posting
+ , posting ~ GL.Transaction_Posting transaction
+ )
+ => Consable (Const
+ ( GL.GL transaction
+ , Simplified
+ (Filter_Bool
+ (Filter_Transaction transaction))
+ , Simplified
+ (Filter_Bool
+ (Filter_Posting posting))
+ ))
+ transaction where
+ mcons t (Const (!gl, ft, fp)) =
+ Const . (, ft, fp) $
+ case simplified ft of
+ Right False -> gl
+ Right True ->
+ case simplified fp of
+ Right False -> gl
+ Right True -> GL.general_ledger t gl
+ Left f ->
+ GL.general_ledger
+ (GL.transaction_postings_filter (test f) t)
+ gl
+ Left f ->
+ if test f t
+ then
+ case simplified fp of
+ Right False -> gl
+ Right True -> GL.general_ledger t gl
+ Left ff ->
+ GL.general_ledger
+ (GL.transaction_postings_filter (test ff) t)
+ gl
+ else gl
+instance
+ ( Foldable foldable
+ , GL.Transaction transaction
+ , Transaction transaction
+ , Posting posting
+ , posting ~ GL.Transaction_Posting transaction
+ )
+ => Consable (Const
+ ( GL.GL transaction
+ , Simplified
+ (Filter_Bool
+ (Filter_Transaction transaction))
+ , Simplified
+ (Filter_Bool
+ (Filter_Posting posting))
+ ))
+ (foldable transaction) where
+ mcons ts (Const (!gl, ft, fp)) =
+ Const . (, ft, fp) $
+ case simplified ft of
+ Right False -> gl
+ Right True ->
+ case simplified fp of
+ Right False -> gl
+ Right True ->
+ Data.Foldable.foldr
+ (GL.general_ledger)
+ gl ts
+ Left f ->
+ Data.Foldable.foldr
+ ( GL.general_ledger
+ . GL.transaction_postings_filter (test f) )
+ gl ts
+ Left f ->
+ Data.Foldable.foldr
+ (\t ->
+ if test f t
+ then
+ case simplified fp of
+ Right False -> id
+ Right True -> GL.general_ledger t
+ Left ff -> GL.general_ledger $
+ GL.transaction_postings_filter (test ff) t
+ else id
+ ) gl ts
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
module Hcompta.Format.Ledger where
+-- import Control.Applicative (Const(..))
import Data.Data (Data(..))
+-- import qualified Data.Foldable as Data.Foldable
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.Account (Account)
import Hcompta.Amount (Amount)
import qualified Hcompta.Amount as Amount
+-- import Hcompta.Balance (Balance(..))
import qualified Hcompta.Balance as Balance
import Hcompta.Date (Date)
import qualified Hcompta.Date as Date
import qualified Hcompta.Filter as Filter
+import Hcompta.Lib.Consable
import Hcompta.Lib.Parsec ()
+-- import Hcompta.GL (GL(..))
import qualified Hcompta.GL as GL
+import qualified Hcompta.Journal as Journal
type Code = Text
type Description = Text
-- * The 'Journal' type
-data Journal
- = Journal
+data Consable ts t
+ => Journal ts t
+ = Journal
{ journal_file :: FilePath
- , journal_includes :: [Journal]
- , journal_last_read_time :: Time.UTCTime
- , journal_transactions :: Map Date [Transaction]
+ , journal_includes :: [Journal ts t]
+ , journal_last_read_time :: Date
+ , journal_transactions :: !(ts t)
, journal_unit_styles :: Map Amount.Unit Amount.Style
} deriving (Data, Eq, Show, Typeable)
-journal :: Journal
+journal :: Consable ts t => Journal ts t
journal =
Journal
{ journal_file = ""
, journal_includes = []
- , journal_last_read_time = Time.posixSecondsToUTCTime 0
- , journal_transactions = Data.Map.empty
+ , journal_last_read_time = Date.nil
+ , journal_transactions = mempty
, journal_unit_styles = Data.Map.empty
}
, transaction_comments_after = []
, transaction_dates = (Date.nil, [])
, transaction_description = ""
- , transaction_postings = Data.Map.empty
- , transaction_virtual_postings = Data.Map.empty
- , transaction_balanced_virtual_postings = Data.Map.empty
+ , transaction_postings = mempty
+ , transaction_virtual_postings = mempty
+ , transaction_balanced_virtual_postings = mempty
, transaction_sourcepos = initialPos ""
, transaction_status = False
- , transaction_tags = Data.Map.empty
+ , transaction_tags = mempty
}
instance Filter.Transaction Transaction where
- type Transaction_Posting Transaction = Posting
+ type Transaction_Posting Transaction = Posting
+ type Transaction_Postings Transaction = Compose [] (Compose (Map Account) [])
transaction_date = fst . transaction_dates
transaction_description = transaction_description
- transaction_postings = transaction_postings
+ transaction_postings t =
+ Compose
+ [ Compose $ transaction_postings t
+ , Compose $ transaction_virtual_postings t
+ , Compose $ transaction_balanced_virtual_postings t
+ ]
transaction_tags = transaction_tags
+instance Journal.Transaction Transaction where
+ transaction_date = fst . transaction_dates
+
{-
instance Filter.GL (GL.GL_Line Transaction) where
type GL_Amount (GL.GL_Line Transaction) = Amount
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_Postings Transaction = Compose [] (Compose (Map Account) [])
+ transaction_date = fst . transaction_dates
+ transaction_postings t =
+ Compose
+ [ Compose $ transaction_postings t
+ , Compose $ transaction_virtual_postings t
+ , Compose $ transaction_balanced_virtual_postings t
+ ]
+ transaction_postings_filter f t =
+ t{ transaction_postings =
+ Data.Map.mapMaybe
+ (\p -> case filter f p of
+ [] -> Nothing
+ ps -> Just ps)
+ (transaction_postings t)
+ , transaction_virtual_postings =
+ Data.Map.mapMaybe
+ (\p -> case filter f p of
+ [] -> Nothing
+ ps -> Just ps)
+ (transaction_virtual_postings t)
+ , transaction_balanced_virtual_postings =
+ Data.Map.mapMaybe
+ (\p -> case filter f p of
+ [] -> Nothing
+ ps -> Just ps)
+ (transaction_balanced_virtual_postings t)
+ }
-- | Return a 'Data.Map.Map' associating
-- the given 'Transaction's with their respective 'Date'.
-transaction_by_Date :: [Transaction] -> Map Date [Transaction]
+transaction_by_Date :: [Transaction] -> (Compose (Map Date) []) Transaction
transaction_by_Date =
+ Compose .
Data.Map.fromListWith (flip (++)) .
Data.List.map (\t -> (fst $ transaction_dates t, [t]))
tag_by_Name =
Data.Map.fromListWith (flip (++)) .
Data.List.map (\(n, v) -> (n, [v]))
+
+-- Instances 'Consable'
+
+-- 'Transaction's
+instance Consable [] Transaction where
+ mcons = (:)
+
+{-
+-- 'Balance'
+instance Consable (Const
+ ( Balance (Amount.Sum Amount)
+ , Filter.Simplified (Filter.Filter_Bool (Filter.Filter_Transaction Transaction))
+ , Filter.Simplified (Filter.Filter_Bool (Filter.Filter_Posting Posting))
+ ))
+ Transaction where
+ mcons t c@(Const (bal, ft, fp)) =
+ if Filter.test ft t
+ then Const . (, ft, fp) $
+ balance (Compose $ transaction_postings t) $
+ balance (Compose $ transaction_virtual_postings t) $
+ balance (Compose $ transaction_balanced_virtual_postings t) $
+ bal
+ else c
+ where balance =
+ flip $ Data.Foldable.foldr $ \p ->
+ if Filter.test fp p
+ then Balance.balance
+ ( posting_account p
+ , Balance.Account_Sum $ Data.Map.map Amount.sum (posting_amounts p)
+ )
+ else id
+
+-- 'Balance.Balance_by_Account'
+instance Consable (Const
+ ( Balance.Balance_by_Account (Amount.Sum Amount) ))
+ Transaction where
+ mcons t (Const bal) =
+ (\(Const b) -> Const b) $
+ mcons (Compose $ transaction_postings t) $
+ mcons (Compose $ transaction_virtual_postings t) $
+ mcons (Compose $ transaction_balanced_virtual_postings t) $
+ Const bal
+
+-- 'Balance.Balance_by_Unit'
+instance Consable (Const
+ ( Balance.Balance_by_Unit (Amount.Sum Amount) ))
+ Transaction where
+ mcons t (Const ts) = Const $
+ Data.Foldable.foldl' (flip Balance.by_unit)
+ ts (Compose $ transaction_postings t)
+-}
import qualified Control.Monad
import Data.Foldable hiding (fold)
import qualified Data.List
-import qualified Data.Map.Strict as Data.Map
import qualified Data.Monoid (getFirst, First(..))
-- import Data.Monoid (Monoid, mappend)
+import qualified Data.Map.Strict as Data.Map
import Prelude hiding (traverse)
import Data.Typeable ()
-import qualified Hcompta.Format.Ledger as Ledger
+import qualified Hcompta.Amount.Style as Amount.Style
import Hcompta.Format.Ledger (Journal(..))
+import qualified Hcompta.Format.Ledger as Ledger
+import Hcompta.Lib.Consable (Consable(..))
-- * Extractors
-- | Return the given accumulator folded over
-- the given 'Journal' and its 'journal_includes' 'Journal's.
-fold :: (Journal -> a -> a) -> Journal -> a -> a
+fold :: Consable ts t => (Journal ts t -> a -> a) -> Journal ts t -> a -> a
fold f j@Journal{journal_includes} a =
Data.List.foldl'
(flip (fold f)) (f j a)
-- | Return the given accumulator folded over
-- the given 'Journal' and its 'journal_includes' 'Journal's.
-foldM :: Monad m => (Journal -> a -> m a) -> Journal -> a -> m a
+foldM :: (Monad m, Consable ts t) => (Journal ts t -> a -> m a) -> Journal ts t -> a -> m a
foldM f j@Journal{journal_includes} a = do
ma <- f j a
Control.Monad.foldM
-- | Return the given accumulator folded with the given function
-- over the given 'Journal' and its 'journal_includes' 'Journal's.
-fold_map :: Monoid a => (Journal -> a -> a) -> Journal -> a -> a
+fold_map :: (Monoid a, Consable ts t) => (Journal ts t -> a -> a) -> Journal ts t -> a -> a
fold_map f j@(Journal{journal_includes}) =
(f j) `mappend` foldMap (fold_map f) journal_includes
-- | Return the first non-'Nothing' value returned by the given function
-- when applied to the given 'Journal' or its 'journal_includes' 'Journal's,
-- with the parent 'Journal's.
-find :: (Journal -> Maybe a) -> Journal -> Maybe (a, [Journal])
+find :: Consable ts t => (Journal ts t -> Maybe a) -> Journal ts t -> Maybe (a, [Journal ts t])
find f =
(\x -> case x of
Nothing -> Nothing
-- | Return the given 'Journal' and its 'journal_includes' 'Journal's
-- mapped by the given function.
-traverse :: (Journal -> Journal) -> Journal -> Journal
+traverse :: Consable ts t => (Journal ts t -> Journal ts t) -> Journal ts t -> Journal ts t
traverse f =
(\x -> case x of
j@Journal{journal_includes} ->
-- * Constructors
-union :: Journal -> Journal -> Journal
-union
- Journal{ journal_transactions=t0 }
- j@Journal{ journal_transactions=t1 } =
- j{ journal_transactions = Data.Map.unionWith (++) t0 t1 }
+union :: Consable ts t => Journal ts t -> Journal ts t -> Journal ts t
+union j0 j1 =
+ j1{ journal_transactions = mappend (journal_transactions j0) (journal_transactions j1)
+ , journal_unit_styles = Data.Map.unionWith Amount.Style.union (journal_unit_styles j0) (journal_unit_styles j1)
+ , journal_last_read_time = min (journal_last_read_time j0) (journal_last_read_time j1)
+ }
-unions :: Foldable t => t Journal -> Journal
-unions = Data.Foldable.foldl' union Ledger.journal
+unions :: (Foldable f, Consable ts t) => f (Journal ts t) -> Journal ts t
+unions = Data.Foldable.foldl' (flip union) Ledger.journal
-- | Return the 'Journal' with its 'journal_transactions'
-- recursively completed by the 'journal_transactions'
-- of its 'journal_includes', now empty.
-flatten :: Journal -> Journal
+flatten :: Consable ts t => Journal ts t -> Journal ts t
flatten jnl =
- Ledger.journal
- { journal_transactions =
- Data.Map.unionsWith (++) $
- flat journal_transactions jnl
- , journal_includes = []
+ jnl
+ { journal_includes = []
+ , journal_transactions = flat journal_transactions jnl
}
where
- flat :: (Journal -> a) -> Journal -> [a]
- flat g j = g j:Data.List.concatMap (flat g) (journal_includes j)
+ flat :: Consable ts t => (Journal ts t -> ts t) -> Journal ts t -> ts t
+ flat g j = mconcat $ g j : Data.List.map (flat g) (journal_includes j)
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
module Hcompta.Format.Ledger.Read where
-- import Control.Applicative ((<$>), (<*>), (<*))
, Tag, Tag_Name, Tag_Value, Tag_by_Name
, Transaction(..)
)
+import Hcompta.Lib.Consable (Consable(..))
import qualified Hcompta.Lib.Regex as Regex
import Hcompta.Lib.Regex (Regex)
import qualified Hcompta.Lib.Parsec as R
import qualified Hcompta.Lib.Path as Path
-data Context
+data Context ts t
= Context
{ context_account_prefix :: !(Maybe Account)
, context_aliases_exact :: !(Data.Map.Map Account Account)
, context_aliases_regex :: ![(Regex, Account)]
, context_date :: !Date
, context_unit_and_style :: !(Maybe (Amount.Unit, Amount.Style))
- , context_journal :: !Journal
+ , context_journal :: !(Journal ts t)
, context_year :: !Date.Year
} deriving (Show)
-nil_Context :: Context
-nil_Context =
+context :: Consable ts t => Journal ts t -> Context ts t
+context context_journal =
Context
{ context_account_prefix = Nothing
, context_aliases_exact = Data.Map.empty
, context_aliases_regex = []
, context_date = Date.nil
, context_unit_and_style = Nothing
- , context_journal = Ledger.journal
- , context_year = (\(year, _ , _) -> year) $
- Time.toGregorian $ Time.utctDay $
- journal_last_read_time Ledger.journal
+ , context_journal
+ , context_year = Date.year Date.nil
}
data Error
-- * Directives
-directive_alias :: Stream s m Char => ParsecT s Context m ()
+directive_alias :: (Consable ts t, Stream s m Char) => ParsecT s (Context ts t) m ()
directive_alias = do
_ <- R.string "alias"
R.skipMany1 $ R.space_horizontal
(regx, repl):context_aliases_regex ctx}
return ()
-
-- * Read 'Comment'
comment_begin :: Char
-- * Read 'Posting'
posting
- :: (Stream s (R.Error_State Error m) Char, Monad m)
- => ParsecT s Context (R.Error_State Error m) (Posting, Posting_Type)
+ :: (Consable ts t, Stream s (R.Error_State Error m) Char, Monad m)
+ => ParsecT s (Context ts t) (R.Error_State Error m) (Posting, Posting_Type)
posting = (do
ctx <- R.getState
sourcepos <- R.getPosition
-- * Read 'Transaction'
transaction
- :: (Stream s (R.Error_State Error m) Char, Monad m)
- => ParsecT s Context (R.Error_State Error m) Transaction
+ :: (Consable ts t, Stream s (R.Error_State Error m) Char, Monad m)
+ => ParsecT s (Context ts t) (R.Error_State Error m) Transaction
transaction = (do
ctx <- R.getState
transaction_sourcepos <- R.getPosition
date_sep :: Char
date_sep = '='
-code :: Stream s m Char => ParsecT s Context m Ledger.Code
+code :: (Consable ts t, Stream s m Char) => ParsecT s (Context ts t) m Ledger.Code
code = (do
fromString <$> do
R.skipMany $ R.space_horizontal
-- * Read directives
-default_year :: Stream s m Char => ParsecT s Context m ()
+default_year :: (Consable ts t, Stream s m Char) => ParsecT s (Context ts t) m ()
default_year = (do
year <- R.integer_of_digits 10 <$> R.many1 R.digit
R.skipMany R.space_horizontal >> R.new_line
R.setState context_{context_year=year}
) <?> "default year"
-default_unit_and_style :: Stream s m Char => ParsecT s Context m ()
+default_unit_and_style :: (Consable ts t, Stream s m Char) => ParsecT s (Context ts t) m ()
default_unit_and_style = (do
amount_ <- Amount.Read.amount
R.skipMany R.space_horizontal >> R.new_line
, Amount.style amount_ )}
) <?> "default unit and style"
-include
- :: Stream s (R.Error_State Error IO) Char
- => ParsecT s Context (R.Error_State Error IO) ()
+include ::
+ ( Consable ts Transaction
+ , Show (ts Transaction)
+ , Stream s (R.Error_State Error IO) Char
+ )
+ => ParsecT s (Context ts Transaction) (R.Error_State Error IO) ()
include = (do
sourcepos <- R.getPosition
filename <- R.manyTill R.anyChar (R.lookAhead R.new_line <|> R.eof)
-- * Read 'Journal'
-journal
- :: Stream s (R.Error_State Error IO) Char
+journal ::
+ ( Consable ts Transaction
+ , Show (ts Transaction)
+ , Stream s (R.Error_State Error IO) Char
+ )
=> FilePath
- -> ParsecT s Context (R.Error_State Error IO) Journal
+ -> ParsecT s (Context ts Transaction) (R.Error_State Error IO) (Journal ts Transaction)
journal file_ = (do
currentLocalTime <- liftIO $
Time.utcToLocalTime
journal_rec file_
) <?> "journal"
-journal_rec
- :: Stream s (R.Error_State Error IO) Char
+journal_rec ::
+ ( Consable ts Transaction
+ , Show (ts Transaction)
+ , Stream s (R.Error_State Error IO) Char
+ )
=> FilePath
- -> ParsecT s Context (R.Error_State Error IO) Journal
+ -> ParsecT s (Context ts Transaction) (R.Error_State Error IO) (Journal ts Transaction)
journal_rec file_ = do
last_read_time <- lift $ liftIO Time.getCurrentTime
R.skipMany $ do
context_' <- R.getState
let j = context_journal context_'
R.setState $ context_'{context_journal=
- j{journal_transactions=
- Data.Map.insertWith (flip (++))
- -- NOTE: flip-ing preserves order but slows down
- -- when many transactions have the very same date.
- (fst $ transaction_dates t) [t]
- (journal_transactions j)}}
+ j{journal_transactions=mcons t $ journal_transactions j}}
R.new_line <|> R.eof))
, R.try (comment >> return ())
]
return $
journal_
{ journal_file = file_
- , journal_last_read_time=last_read_time
+ , journal_last_read_time = last_read_time
, journal_includes = reverse $ journal_includes journal_
}
-- ** Read 'Journal' from a file
-file :: FilePath -> ExceptT [R.Error Error] IO Journal
-file path = do
+file
+ ::
+ ( Consable ts Transaction
+ , Show (ts Transaction)
+ )
+ => Context ts Transaction
+ -> FilePath
+ -> ExceptT [R.Error Error] IO (Journal ts Transaction)
+file ctx path = do
ExceptT $
Exception.catch
(liftM Right $ Text.IO.readFile path) $
\ko -> return $ Left $
[ R.Error_Custom (R.initialPos path) $ Error_reading_file path ko ]
- >>= liftIO . R.runParserT_with_Error (journal path) nil_Context path
+ >>= liftIO . R.runParserT_with_Error (journal path) ctx path
>>= \x -> case x of
Left ko -> throwE $ ko
Right ok -> ExceptT $ return $ Right ok
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
module Hcompta.Format.Ledger.Write where
-- import Control.Applicative ((<$>), (<*))
)
import qualified Hcompta.Date.Write as Date.Write
import qualified Hcompta.Format.Ledger.Read as Read
+import Hcompta.Lib.Consable (Consable(..))
import qualified Hcompta.Lib.Parsec as R
-- * Write 'Account'
transaction :: Transaction -> Doc
transaction t = transaction_with_lengths (transaction_lengths t 0) t
-transactions :: Foldable f => f Transaction -> Doc
+transactions ::
+ ( Foldable ts
+ , Consable ts Transaction
+ )
+ => ts Transaction -> Doc
transactions ts = do
let transaction_lengths_ =
Data.Foldable.foldr transaction_lengths 0 ts
-- * Write 'Journal'
-journal :: Journal -> Doc
-journal Journal { journal_transactions } =
- transactions (Data.Functor.Compose.Compose journal_transactions)
+journal ::
+ ( Foldable ts
+ , Consable ts Transaction
+ ) => Journal ts Transaction -> Doc
+journal Journal{ journal_transactions } =
+ transactions journal_transactions
-- * Rendering
+{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
-- | General Ledger
module Hcompta.GL where -- General Ledger
+import Control.Applicative (Const(..))
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.Strict.Maybe as Strict
import qualified Data.Traversable
import qualified Data.Map.Strict as Data.Map
import Data.Map.Strict (Map)
import qualified Hcompta.Account as Account
import Hcompta.Account (Account)
import Hcompta.Date (Date)
+import Hcompta.Lib.Consable
import qualified Hcompta.Lib.TreeMap as TreeMap
import Hcompta.Lib.TreeMap (TreeMap)
type Transaction_Postings t :: * -> *
transaction_date :: t -> Date
transaction_postings :: t -> Transaction_Postings t (Transaction_Posting t)
+ transaction_postings_filter :: (Transaction_Posting t -> Bool) -> t -> t
+{- NOTE: conflicting with the instance below.
instance
( Posting posting
, Data posting
type Transaction_Postings (Date, Map Account ([] posting)) = Compose (Map Account) []
transaction_date = fst
transaction_postings = Compose . snd
+-}
+
+instance
+ ( Posting posting
+ , Data posting
+ , Eq posting
+ , Show posting
+ ) => Transaction (Date, [posting])
+ where
+ type Transaction_Posting (Date, [posting]) = posting
+ type Transaction_Postings (Date, [posting]) = []
+ transaction_date = fst
+ transaction_postings = snd
+ transaction_postings_filter = fmap . filter
-- * Type 'GL'
) => Show (GL transaction)
deriving instance Typeable1 GL
-- FIXME: use 'Typeable' when dropping GHC-7.6 support
+instance Transaction transaction
+ => Monoid (GL transaction) where
+ mempty = empty
+ mappend = union
+
+instance Transaction transaction
+ => Consable (Const (GL transaction)) transaction where
+ mcons t (Const !gl) = Const $ general_ledger t gl
+instance
+ ( Foldable foldable
+ , Transaction transaction
+ )
+ => Consable (Const (GL transaction))
+ (foldable transaction) where
+ mcons ts (Const !gl) =
+ Const $ Data.Foldable.foldr general_ledger gl ts
data
Transaction transaction
-- ** Constructors
-nil
+empty
:: Transaction transaction
=> GL transaction
-nil = GL TreeMap.empty
+empty = GL TreeMap.empty
-- | Return the given 'GL'
-- updated by the given 'Transaction'.
gl
(transaction_postings t)
+union
+ :: Transaction transaction
+ => GL transaction
+ -> GL transaction
+ -> GL transaction
+union (GL gl0) (GL gl1) =
+ GL $
+ TreeMap.union
+ (Data.Map.unionWith mappend)
+ gl0 gl1
+
-- * Type 'Expanded'
-- | Descending propagation of 'Amount's accross 'Account's.
=> GL transaction
-> Expanded transaction
expanded (GL gl) =
- let from_value = fromMaybe (assert False undefined) . TreeMap.node_value in
+ let from_value = Strict.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
+ let exclusive = Strict.fromMaybe Data.Map.empty value in
GL_Line_Expanded
{ exclusive
, inclusive =
--- /dev/null
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Hcompta.Journal where
+
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Data.Map
+
+import Hcompta.Date (Date)
+import Hcompta.Lib.Consable (Consable(..))
+
+class Transaction t where
+ transaction_date :: t -> Date
+
+newtype Journal t
+ = Journal (Map Date [t])
+ deriving (Eq, Show)
+
+instance Foldable Journal where
+ foldMap f (Journal t) = foldMap (foldMap f) t
+
+instance Transaction t => Monoid (Journal t) where
+ mempty = Journal mempty
+ mappend (Journal x) (Journal y) =
+ Journal $ Data.Map.unionWith mappend x y
+
+instance Transaction t => Consable (Journal) t where
+ mcons t (Journal !ts) =
+ Journal $
+ Data.Map.insertWith mappend
+ (transaction_date t) [t] ts
+
+journal :: Transaction t => t -> Journal t -> Journal t
+journal = mcons
+
+transactions :: Transaction t => Journal t -> Map Date [t]
+transactions (Journal ts) = ts
--- /dev/null
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Hcompta.Lib.Consable where
+
+import Data.Monoid ()
+import Data.Functor.Compose (Compose(..))
+--import Control.Applicative (Const(..))
+
+class Monoid (ts t) => Consable ts t where
+ mcons :: t -> ts t -> ts t
+
+instance Monoid (f (g x)) => Monoid ((Compose f g) x) where
+ mempty = Compose mempty
+ mappend (Compose x) (Compose y) = Compose $ mappend x y
--- /dev/null
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Hcompta.Lib.Strict where
+
+import Control.DeepSeq (NFData(..))
+import Data.Data
+import qualified Data.Strict.Maybe as Strict
+
+deriving instance Data x => Data (Strict.Maybe x)
+instance Monoid x => Monoid (Strict.Maybe x) where
+ mempty = Strict.Nothing
+ mappend (Strict.Just x) (Strict.Just y) = Strict.Just (x `mappend` y)
+ mappend x Strict.Nothing = x
+ mappend Strict.Nothing y = y
+instance NFData x => NFData (Strict.Maybe x) where
+ rnf Strict.Nothing = ()
+ rnf (Strict.Just x) = rnf x
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE StandaloneDeriving #-}
--- | This module implements a 'TreeMap',
+-- | This module implements a strict 'TreeMap',
-- which is like a 'Map'
-- but whose key is now a 'NonEmpty' list of 'Map' keys (a 'Path')
-- enabling the possibility to gather mapped values
-- by 'Path' prefixes (inside a 'Node').
module Hcompta.Lib.TreeMap where
+import Control.DeepSeq (NFData(..))
-- import Control.Applicative ((<$>), (<*>), pure)
import Data.Data (Data)
-- import Data.Foldable (Foldable)
import qualified Data.Map.Strict as Data.Map
import Data.Map.Strict (Map)
-- import Data.Monoid (Monoid(..))
+import qualified Data.Strict.Maybe as Strict
-- import Data.Traversable (Traversable(..))
import Data.Typeable (Typeable)
import Prelude hiding (filter, null, reverse)
+import qualified Hcompta.Lib.Strict as Strict ()
+
-- * Type 'TreeMap'
newtype TreeMap k x
instance (Ord k, Monoid v) => Monoid (TreeMap k v) where
mempty = empty
- mappend = union const
+ mappend = union mappend
-- mconcat = Data.List.foldr mappend mempty
instance Ord k => Functor (TreeMap k) where
fmap f (TreeMap m) = TreeMap $ fmap (fmap f) m
foldMap f (TreeMap m) = foldMap (foldMap f) m
instance Ord k => Traversable (TreeMap k) where
traverse f (TreeMap m) = TreeMap <$> traverse (traverse f) m
+instance (Ord k, NFData k, NFData x) => NFData (TreeMap k x) where
+ rnf (TreeMap m) = rnf m
-- * Type 'Path'
data Ord k
=> Node k x
= Node
- { node_size :: Int -- ^ The number of non-'Nothing' 'node_value's reachable from this 'Node'.
- , node_value :: Maybe x -- ^ Some value, or 'Nothing' if this 'Node' is intermediary.
- , node_descendants :: TreeMap k x -- ^ Descendants 'Node's.
+ { node_size :: !Int -- ^ The number of non-'Strict.Nothing' 'node_value's reachable from this 'Node'.
+ , node_value :: !(Strict.Maybe x) -- ^ Some value, or 'Strict.Nothing' if this 'Node' is intermediary.
+ , node_descendants :: !(TreeMap k x) -- ^ Descendants 'Node's.
} deriving (Data, Eq, Read, Show, Typeable)
+
instance (Ord k, Monoid v) => Monoid (Node k v) where
mempty =
Node
- { node_value = Nothing
+ { node_value = Strict.Nothing
, node_size = 0
, node_descendants = TreeMap mempty
}
let x = x0 `mappend` x1 in
Node
{ node_value = x
- , node_size = size m + maybe 0 (const 1) x
+ , node_size = size m + Strict.maybe 0 (const 1) x
, node_descendants = union const m0 m1
}
-- mconcat = Data.List.foldr mappend mempty
-
instance Ord k => Functor (Node k) where
fmap f Node{node_value=x, node_descendants=m, node_size} =
Node
, node_descendants = Hcompta.Lib.TreeMap.map f m
, node_size
}
-
instance Ord k => Foldable (Node k) where
- foldMap f Node{node_value=Nothing, node_descendants=TreeMap m} =
+ foldMap f Node{node_value=Strict.Nothing, node_descendants=TreeMap m} =
foldMap (foldMap f) m
- foldMap f Node{node_value=Just x, node_descendants=TreeMap m} =
+ foldMap f Node{node_value=Strict.Just x, node_descendants=TreeMap m} =
f x `mappend` foldMap (foldMap f) m
-
instance Ord k => Traversable (Node k) where
- traverse f Node{node_value=Nothing, node_descendants=TreeMap m, node_size} =
- Node node_size <$> pure Nothing <*> (TreeMap <$> traverse (traverse f) m)
- traverse f Node{node_value=Just x, node_descendants=TreeMap m, node_size} =
- Node node_size <$> (Just <$> f x) <*> (TreeMap <$> traverse (traverse f) m)
+ traverse f Node{node_value=Strict.Nothing, node_descendants=TreeMap m, node_size} =
+ Node node_size <$> pure Strict.Nothing <*> (TreeMap <$> traverse (traverse f) m)
+ traverse f Node{node_value=Strict.Just x, node_descendants=TreeMap m, node_size} =
+ Node node_size <$> (Strict.Just <$> f x) <*> (TreeMap <$> traverse (traverse f) m)
+instance (Ord k, NFData k, NFData x) => NFData (Node k x) where
+ rnf (Node s v d) = rnf s `seq` rnf v `seq` rnf d
-- * Construct
leaf :: Ord k => x -> Node k x
leaf x =
Node
- { node_value = Just x
+ { node_value = Strict.Just x
, node_descendants = empty
, node_size = 1
}
-- | Return the given 'TreeMap' associating the given 'Path' with the given value,
-- merging values if the given 'TreeMap' already associates the given 'Path'
--- with a non-'Nothing' 'node_value'.
+-- with a non-'Strict.Nothing' 'node_value'.
insert :: Ord k => (x -> x -> x) -> Path k -> x -> TreeMap k x -> TreeMap k x
insert merge (k:|[]) x (TreeMap m) =
TreeMap $
Data.Map.insertWith
- (\_ Node{node_value=x1, node_descendants=m1, node_size=s1} ->
+ (\_ Node{node_value = x1, node_descendants = m1, node_size = s1} ->
Node
- { node_value = maybe (Just x) (Just . merge x) x1
+ { node_value = Strict.maybe (Strict.Just x) (Strict.Just . merge x) x1
, node_descendants = m1
- , node_size = maybe (s1 + 1) (const s1) x1
+ , node_size = Strict.maybe (s1 + 1) (const s1) x1
})
k (leaf x) m
insert merge (k:|k':ks) x (TreeMap m) =
TreeMap $
Data.Map.insertWith
- (\_ Node{node_value=x1, node_descendants=m1} ->
- let m' = insert merge (path k' ks) x m1 in
- Node{node_value=x1, node_descendants=m', node_size=size m' + maybe 0 (const 1) x1})
+ (\_ Node{node_value = x1, node_descendants = m1} ->
+ let m' = insert merge (path k' ks) x $ m1 in
+ let s' = size m' + Strict.maybe 0 (const 1) x1 in
+ Node{node_value=x1, node_descendants=m', node_size=s'})
k
(Node
- { node_value = Nothing
+ { node_value = Strict.Nothing
, node_descendants = insert merge (path k' ks) x empty
, node_size = 1
})
null :: TreeMap k x -> Bool
null (TreeMap m) = Data.Map.null m
--- | Return the number of non-'Nothing' 'node_value's in the given 'TreeMap'.
+-- | Return the number of non-'Strict.Nothing' 'node_value's in the given 'TreeMap'.
--
-- * Complexity: O(r) where r is the size of the root 'Map'.
size :: Ord k => TreeMap k x -> Int
-- * Find
-- | Return the value (if any) associated with the given 'Path'.
-find :: Ord k => Path k -> TreeMap k x -> Maybe x
-find (k:|[]) (TreeMap m) = maybe Nothing node_value $ Data.Map.lookup k m
+find :: Ord k => Path k -> TreeMap k x -> Strict.Maybe x
+find (k:|[]) (TreeMap m) = maybe Strict.Nothing node_value $ Data.Map.lookup k m
find (k:|k':ks) (TreeMap m) =
- maybe Nothing (find (path k' ks) . node_descendants) $
+ maybe Strict.Nothing (find (path k' ks) . node_descendants) $
Data.Map.lookup k m
-- * Union
-- | Return a 'TreeMap' associating the same 'Path's as both given 'TreeMap's,
-- merging values (in respective order) when a 'Path' leads
--- to a non-'Nothing' 'node_value' in both given 'TreeMap's.
+-- to a non-'Strict.Nothing' 'node_value' in both given 'TreeMap's.
union :: Ord k => (x -> x -> x) -> TreeMap k x -> TreeMap k x -> TreeMap k x
union merge (TreeMap tm0) (TreeMap tm1) =
TreeMap $
(\Node{node_value=x0, node_descendants=m0}
Node{node_value=x1, node_descendants=m1} ->
let m = union merge m0 m1 in
- let x = maybe x1 (\x0' -> maybe (Just x0') (Just . merge x0') x1) x0 in
+ let x = Strict.maybe x1 (\x0' -> Strict.maybe (Strict.Just x0') (Strict.Just . merge x0') x1) x0 in
Node
{ node_value = x
, node_descendants = m
- , node_size = size m + maybe 0 (const 1) x
+ , node_size = size m + Strict.maybe 0 (const 1) x
})
tm0 tm1
-- * Map
--- | Return the given 'TreeMap' with each non-'Nothing' 'node_value'
+-- | Return the given 'TreeMap' with each non-'Strict.Nothing' 'node_value'
-- mapped by the given function.
map :: Ord k => (x -> y) -> TreeMap k x -> TreeMap k y
map f =
TreeMap .
Data.Map.map
(\n@Node{node_value=x, node_descendants=m} ->
- n{ node_value=maybe Nothing (Just . f) x
+ n{ node_value=Strict.maybe Strict.Nothing (Strict.Just . f) x
, node_descendants=Hcompta.Lib.TreeMap.map f m
}) .
nodes
-- | Return the given 'TreeMap' with each 'node_value'
-- mapped by the given function supplied with
-- the already mapped 'node_descendants' of the current 'Node'.
-map_by_depth_first :: Ord k => (TreeMap k y -> Maybe x -> y) -> TreeMap k x -> TreeMap k y
+map_by_depth_first :: Ord k => (TreeMap k y -> Strict.Maybe x -> y) -> TreeMap k x -> TreeMap k y
map_by_depth_first f =
TreeMap .
Data.Map.map
- (\n@Node{node_value, node_descendants} ->
+ (\Node{node_value, node_descendants} ->
let m = map_by_depth_first f node_descendants in
- let x = f m node_value in
- n{ node_value = Just x
+ Node
+ { node_value = Strict.Just $ f m node_value
, node_descendants = m
, node_size = size m + 1
}) .
-- * Alter
-alterl_path :: Ord k => (Maybe x -> Maybe x) -> Path k -> TreeMap k x -> TreeMap k x
+alterl_path :: Ord k => (Strict.Maybe x -> Strict.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]
+ => (Strict.Maybe x -> Strict.Maybe x) -> [k]
-> TreeMap k x -> TreeMap k x
go _f [] m = m
go f (k:p) (TreeMap m) =
let (cv, cm) =
case c of
Just Node{node_value=v, node_descendants=d} -> (v, d)
- Nothing -> (Nothing, empty) in
+ Nothing -> (Strict.Nothing, empty) in
let fx = f cv in
let gm = go f p cm in
case (fx, size gm) of
- (Nothing, 0) -> Nothing
+ (Strict.Nothing, 0) -> Nothing
(_, s) -> Just
Node
{ node_value = fx
-- * Fold
-- | Return the given accumulator folded by the given function
--- applied on non-'Nothing' 'node_value's
+-- applied on non-'Strict.Nothing' 'node_value's
-- from left to right through the given 'TreeMap'.
foldl_with_Path :: Ord k => (a -> Path k -> x -> a) -> a -> TreeMap k x -> a
foldl_with_Path =
foldp p fct a (TreeMap m) =
Data.Map.foldlWithKey
(\acc k Node{node_value, node_descendants} ->
- let acc' = maybe acc (fct acc (reverse $ path k p)) node_value in
+ let acc' = Strict.maybe acc (fct acc (reverse $ path k p)) node_value in
foldp (k:p) fct acc' node_descendants) a m
-- | Return the given accumulator folded by the given function
--- applied on non-'Nothing' 'Node's and 'node_value's
+-- applied on non-'Strict.Nothing' 'Node's and 'node_value's
-- from left to right through the given 'TreeMap'.
foldl_with_Path_and_Node :: Ord k => (a -> Node k x -> Path k -> x -> a) -> a -> TreeMap k x -> a
foldl_with_Path_and_Node =
foldp p fct a (TreeMap m) =
Data.Map.foldlWithKey
(\acc k n@Node{node_value, node_descendants} ->
- let acc' = maybe acc (fct acc n (reverse $ path k p)) node_value in
+ let acc' = Strict.maybe acc (fct acc n (reverse $ path k p)) node_value in
foldp (k:p) fct acc' node_descendants) a m
-- | Return the given accumulator folded by the given function
--- applied on non-'Nothing' 'node_value's
+-- applied on non-'Strict.Nothing' 'node_value's
-- from right to left through the given 'TreeMap'.
foldr_with_Path :: Ord k => (Path k -> x -> a -> a) -> a -> TreeMap k x -> a
foldr_with_Path =
Data.Map.foldrWithKey
(\k Node{node_value, node_descendants} acc ->
let acc' = foldp (k:p) fct acc node_descendants in
- maybe acc' (\x -> fct (reverse $ path k p) x acc') node_value) a m
+ Strict.maybe acc' (\x -> fct (reverse $ path k p) x acc') node_value) a m
-- | Return the given accumulator folded by the given function
--- applied on non-'Nothing' 'Node's and 'node_value's
+-- applied on non-'Strict.Nothing' 'Node's and 'node_value's
-- from right to left through the given 'TreeMap'.
foldr_with_Path_and_Node :: Ord k => (Node k x -> Path k -> x -> a -> a) -> a -> TreeMap k x -> a
foldr_with_Path_and_Node =
Data.Map.foldrWithKey
(\k n@Node{node_value, node_descendants} acc ->
let acc' = foldp (k:p) fct acc node_descendants in
- maybe acc' (\x -> fct n (reverse $ path k p) x acc') node_value) a m
+ Strict.maybe acc' (\x -> fct n (reverse $ path k p) x acc') node_value) a m
-- | Return the given accumulator folded by the given function
--- applied on non-'Nothing' 'node_value's
+-- applied on non-'Strict.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 =
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)
+ Strict.Nothing -> go f (k:p) n d a
+ Strict.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
+-- applied on non-'Strict.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 =
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
+ Strict.Nothing -> go f (k:p) n d a
+ Strict.Just x -> f (reverse $ path k p) x $ go f (k:p) n d a
-- * Flatten
-- | Return a 'Map' associating each 'Path'
--- leading to a non-'Nothing' 'node_value' in the given 'TreeMap',
+-- leading to a non-'Strict.Nothing' 'node_value' in the given 'TreeMap',
-- with its value mapped by the given function.
flatten :: Ord k => (x -> y) -> TreeMap k x -> Map (Path k) y
flatten =
Data.Map.unions $
(
Data.Map.mapKeysMonotonic (reverse . flip path p) $
- Data.Map.mapMaybe (\Node{node_value=x} -> f <$> x) m
+ Data.Map.mapMaybe (\Node{node_value} ->
+ case node_value of
+ Strict.Nothing -> Nothing
+ Strict.Just x -> Just $ f x) m
) :
Data.Map.foldrWithKey
(\k -> (:) . flat_map (k:p) f . node_descendants)
-- * Filter
-- | Return the given 'TreeMap'
--- keeping only its non-'Nothing' 'node_value's
+-- keeping only its non-'Strict.Nothing' 'node_value's
-- passing the given predicate.
filter :: Ord k => (x -> Bool) -> TreeMap k x -> TreeMap k x
filter f =
map_Maybe_with_Path
- (\_p x -> if f x then Just x else Nothing)
+ (\_p x -> if f x then Strict.Just x else Strict.Nothing)
-- | Like 'filter' but with also the current 'Path' given to the predicate.
filter_with_Path :: Ord k => (Path k -> x -> Bool) -> TreeMap k x -> TreeMap k x
filter_with_Path f =
map_Maybe_with_Path
- (\p x -> if f p x then Just x else Nothing)
+ (\p x -> if f p x then Strict.Just x else Strict.Nothing)
-- | Like 'filter_with_Path' but with also the current 'Node' given to the predicate.
filter_with_Path_and_Node :: Ord k => (Node k x -> Path k -> x -> Bool) -> TreeMap k x -> TreeMap k x
filter_with_Path_and_Node f =
map_Maybe_with_Path_and_Node
- (\n p x -> if f n p x then Just x else Nothing)
+ (\n p x -> if f n p x then Strict.Just x else Strict.Nothing)
-- | Return the given 'TreeMap'
--- mapping its non-'Nothing' 'node_value's
--- and keeping only the non-'Nothing' results.
-map_Maybe :: Ord k => (x -> Maybe y) -> TreeMap k x -> TreeMap k y
+-- mapping its non-'Strict.Nothing' 'node_value's
+-- and keeping only the non-'Strict.Nothing' results.
+map_Maybe :: Ord k => (x -> Strict.Maybe y) -> TreeMap k x -> TreeMap k y
map_Maybe f = map_Maybe_with_Path (const f)
-- | Like 'map_Maybe' but with also the current 'Path' given to the predicate.
-map_Maybe_with_Path :: Ord k => (Path k -> x -> Maybe y) -> TreeMap k x -> TreeMap k y
+map_Maybe_with_Path :: Ord k => (Path k -> x -> Strict.Maybe y) -> TreeMap k x -> TreeMap k y
map_Maybe_with_Path f = map_Maybe_with_Path_and_Node (const f)
-- | Like 'map_Maybe_with_Path' but with also the current 'Node' given to the predicate.
-map_Maybe_with_Path_and_Node :: Ord k => (Node k x -> Path k -> x -> Maybe y) -> TreeMap k x -> TreeMap k y
+map_Maybe_with_Path_and_Node :: Ord k => (Node k x -> Path k -> x -> Strict.Maybe y) -> TreeMap k x -> TreeMap k y
map_Maybe_with_Path_and_Node =
go []
where
go :: Ord k
- => [k] -> (Node k x -> Path k -> x -> Maybe y)
+ => [k] -> (Node k x -> Path k -> x -> Strict.Maybe y)
-> TreeMap k x
-> TreeMap k y
go p test (TreeMap m) =
let node_descendants = go (k:p) test ns in
let node_size = size node_descendants in
case v of
- Just x ->
+ Strict.Just x ->
let node_value = test node (reverse $ path k p) x in
case node_value of
- Nothing | null node_descendants -> Nothing
- Nothing -> Just Node{node_value, node_descendants, node_size=1 + node_size}
- Just _ -> Just Node{node_value, node_descendants, node_size}
+ Strict.Nothing | null node_descendants -> Nothing
+ Strict.Nothing -> Just Node{node_value, node_descendants, node_size=1 + node_size}
+ Strict.Just _ -> Just Node{node_value, node_descendants, node_size}
_ ->
if null node_descendants
then Nothing
- else Just Node{node_value=Nothing, node_descendants, node_size}
+ else Just Node{node_value=Strict.Nothing, node_descendants, node_size}
) m
import Test.Framework.Providers.HUnit (hUnitTestToTests)
import Test.Framework.Runners.Console (defaultMain)
--- import Control.Applicative ((<*))
+-- import Control.Applicative (Const(..))
import Control.Arrow ((***))
import Control.Monad.IO.Class (liftIO)
import Data.Decimal (DecimalRaw(..))
import qualified Data.Either
import Data.Function (on)
+-- import Data.Functor.Compose (Compose(..))
import qualified Data.List
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.Map.Strict as Data.Map
import Data.Maybe (fromJust)
+import qualified Data.Strict.Maybe as Strict
import Data.Text (Text)
import qualified Data.Time.Calendar as Time
import qualified Data.Time.LocalTime as Time
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.Journal as Journal
import qualified Hcompta.Lib.Foldable as Lib.Foldable
import qualified Hcompta.Lib.Interval as Lib.Interval
import qualified Hcompta.Lib.Interval.Sieve as Lib.Interval.Sieve
(Lib.TreeMap.TreeMap $
Data.Map.fromList
[ ((0::Int), Lib.TreeMap.Node
- { Lib.TreeMap.node_value = Nothing
+ { Lib.TreeMap.node_value = Strict.Nothing
, Lib.TreeMap.node_size = 1
, Lib.TreeMap.node_descendants =
Lib.TreeMap.singleton ((1::Int):|[]) ()
[
]
, "map_by_depth_first" ~: TestList
- [
+ [ "[0, 0/1, 0/1/2, 1, 1/2/3]" ~:
+ (Lib.TreeMap.map_by_depth_first
+ (\descendants value ->
+ Data.Map.foldl'
+ (\acc v -> (++) acc $
+ Strict.fromMaybe undefined $
+ Lib.TreeMap.node_value v
+ )
+ (Strict.fromMaybe [] value)
+ (Lib.TreeMap.nodes descendants)
+ ) $
+ Lib.TreeMap.from_List const
+ [ (((0::Integer):|[]), [0])
+ , ((0:|1:[]), [0,1])
+ , ((0:|1:2:[]), [0,1,2])
+ , ((1:|[]), [1])
+ , ((1:|2:3:[]), [1,2,3])
+ ]
+ )
+ ~?=
+ (Lib.TreeMap.from_List const
+ [ ((0:|[]), [0,0,1,0,1,2])
+ , ((0:|1:[]), [0,1,0,1,2])
+ , ((0:|1:2:[]), [0,1,2])
+ , ((1:|[]), [1,1,2,3])
+ , ((1:|2:[]), [1,2,3])
+ , ((1:|2:3:[]), [1,2,3])
+ ])
+ , "[0/0]" ~:
+ (Lib.TreeMap.map_by_depth_first
+ (\descendants value ->
+ Data.Map.foldl'
+ (\acc v -> (++) acc $
+ Strict.fromMaybe undefined $
+ Lib.TreeMap.node_value v
+ )
+ (Strict.fromMaybe [] value)
+ (Lib.TreeMap.nodes descendants)
+ ) $
+ Lib.TreeMap.from_List const
+ [ (((0::Integer):|0:[]), [0,0])
+ ]
+ )
+ ~?=
+ (Lib.TreeMap.from_List const
+ [ ((0:|[]), [0,0])
+ , ((0:|0:[]), [0,0])
+ ])
]
, "flatten" ~: TestList
[ "[0, 0/1, 0/1/2]" ~:
[ "test" ~: TestList
[ "Filter_Account" ~: TestList
[ "A A" ~?
- Filter.filter
+ Filter.test
[ Filter.Filter_Account_Section_Text
(Filter.Filter_Text_Exact "A")
]
(("A":|[]::Account))
, "* A" ~?
- Filter.filter
+ Filter.test
[ Filter.Filter_Account_Section_Any
]
(("A":|[]::Account))
, ": A" ~?
- Filter.filter
+ Filter.test
[ Filter.Filter_Account_Section_Many
]
(("A":|[]::Account))
, ":A A" ~?
- Filter.filter
+ Filter.test
[ Filter.Filter_Account_Section_Many
, Filter.Filter_Account_Section_Text
(Filter.Filter_Text_Exact "A")
]
(("A":|[]::Account))
, "A: A" ~?
- Filter.filter
+ Filter.test
[ Filter.Filter_Account_Section_Text
(Filter.Filter_Text_Exact "A")
, Filter.Filter_Account_Section_Many
]
(("A":|[]::Account))
, "A: A:B" ~?
- Filter.filter
+ Filter.test
[ Filter.Filter_Account_Section_Text
(Filter.Filter_Text_Exact "A")
, Filter.Filter_Account_Section_Many
]
(("A":|"B":[]::Account))
, "A:B A:B" ~?
- Filter.filter
+ Filter.test
[ Filter.Filter_Account_Section_Text
(Filter.Filter_Text_Exact "A")
, Filter.Filter_Account_Section_Text
]
(("A":|"B":[]::Account))
, "A::B A:B" ~?
- Filter.filter
+ Filter.test
[ Filter.Filter_Account_Section_Text
(Filter.Filter_Text_Exact "A")
, Filter.Filter_Account_Section_Many
]
(("A":|"B":[]::Account))
, ":B: A:B:C" ~?
- Filter.filter
+ Filter.test
[ Filter.Filter_Account_Section_Many
, Filter.Filter_Account_Section_Text
(Filter.Filter_Text_Exact "B")
]
(("A":|"B":"C":[]::Account))
, ":C A:B:C" ~?
- Filter.filter
+ Filter.test
[ Filter.Filter_Account_Section_Many
, Filter.Filter_Account_Section_Text
(Filter.Filter_Text_Exact "C")
]
, "Filter_Bool" ~: TestList
[ "Any A" ~?
- Filter.filter
+ Filter.test
(Filter.Any::Filter.Filter_Bool Filter.Filter_Account)
(("A":|[]::Account))
]
, "Filter_Ord" ~: TestList
[ "0 < (1, 2)" ~?
- Filter.filter
+ Filter.test
(Filter.Filter_Ord_Gt (0::Integer))
(fromJust $ (Lib.Interval.<=..<=) 1 2)
, "(-2, -1) < 0" ~?
- Filter.filter
+ Filter.test
(Filter.Filter_Ord_Lt (0::Integer))
(fromJust $ (Lib.Interval.<=..<=) (-2) (-1))
, "not (1 < (0, 2))" ~?
- (not $ Filter.filter
+ (not $ Filter.test
(Filter.Filter_Ord_Gt (1::Integer))
(fromJust $ (Lib.Interval.<=..<=) 0 2))
]
(Format.Ledger.posting ("A":|[]))
{ Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ 1 ]
}
- Balance.nil)
+ Balance.empty)
~?=
Balance.Balance
{ Balance.balance_by_account =
Lib.TreeMap.from_List const $
- Data.List.map (id *** Data.Map.map Amount.sum) $
+ Data.List.map (id *** Balance.Account_Sum . Data.Map.map Amount.sum) $
[ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) ]
, Balance.balance_by_unit =
+ Balance.Balance_by_Unit $
Data.Map.fromList $
Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s))
[ Balance.Unit_Sum
, "[A+$1, A-$1] = {A+$0, $+0}" ~:
(Data.List.foldl
(flip Balance.balance)
- Balance.nil
+ Balance.empty
[ (Format.Ledger.posting ("A":|[]))
{ Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ 1 ]
}
{ Balance.balance_by_account =
Lib.TreeMap.from_List const $
[ ( "A":|[]
- , Data.Map.fromListWith const $
+ , Balance.Account_Sum $
+ Data.Map.fromListWith const $
Data.List.map (\s -> (Amount.unit $ Amount.sum_balance s, s))
[ Amount.Sum_Both
(Amount.usd $ -1)
]
) ]
, Balance.balance_by_unit =
+ Balance.Balance_by_Unit $
Data.Map.fromList $
Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s))
[ Balance.Unit_Sum
, "[A+$1, A-€1] = {A+$1-€1, $+1 €-1}" ~:
(Data.List.foldl
(flip Balance.balance)
- Balance.nil
+ Balance.empty
[ (Format.Ledger.posting ("A":|[]))
{ 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 Amount.sum) $
+ Data.List.map (id *** Balance.Account_Sum . Data.Map.map Amount.sum) $
[ ("A":|[], Amount.from_List [ Amount.usd $ 1, Amount.eur $ -1 ]) ]
, Balance.balance_by_unit =
+ Balance.Balance_by_Unit $
Data.Map.fromList $
Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s))
[ Balance.Unit_Sum
, "[A+$1, B-$1] = {A+$1 B-$1, $+0}" ~:
(Data.List.foldl
(flip Balance.balance)
- Balance.nil
+ Balance.empty
[ (Format.Ledger.posting ("A":|[]))
{ 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 Amount.sum) $
+ Data.List.map (id *** Balance.Account_Sum . Data.Map.map Amount.sum) $
[ ("A":|[], Amount.from_List [ Amount.usd $ 1 ])
, ("B":|[], Amount.from_List [ Amount.usd $ -1 ])
]
, Balance.balance_by_unit =
+ Balance.Balance_by_Unit $
Data.Map.fromList $
Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s))
[ Balance.Unit_Sum
, "[A+$1, B+$1]" ~:
(Data.List.foldl
(flip Balance.balance)
- Balance.nil
+ Balance.empty
[ (Format.Ledger.posting ("A":|[]))
{ 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 Amount.sum) $
+ Data.List.map (id *** Balance.Account_Sum . Data.Map.map Amount.sum) $
[ ("A":|[], Amount.from_List [ Amount.usd $ 1 ])
, ("B":|[], Amount.from_List [ Amount.usd $ 1 ])
]
, Balance.balance_by_unit =
+ Balance.Balance_by_Unit $
Data.Map.fromList $
Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s))
[ Balance.Unit_Sum
, "[A+$1+€2, A-$1-€2] = {A+$0+€0, $+0 €+0}" ~:
(Data.List.foldl
(flip Balance.balance)
- Balance.nil
+ Balance.empty
[ (Format.Ledger.posting ("A":|[]))
{ Format.Ledger.posting_amounts=Amount.from_List [ Amount.usd $ 1, Amount.eur $ 2 ]
}
{ Balance.balance_by_account =
Lib.TreeMap.from_List const $
[ ("A":|[]
- , Data.Map.fromListWith const $
+ , Balance.Account_Sum $
+ Data.Map.fromListWith const $
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 =
+ Balance.Balance_by_Unit $
Data.Map.fromList $
Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s))
[ Balance.Unit_Sum
, "[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
+ Balance.empty
[ (Format.Ledger.posting ("A":|[]))
{ 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 Amount.sum) $
+ Data.List.map (id *** Balance.Account_Sum . 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 =
+ Balance.Balance_by_Unit $
Data.Map.fromList $
Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s))
[ Balance.Unit_Sum
}
]
, "union" ~: TestList
- [ "nil nil = nil" ~:
- Balance.union Balance.nil Balance.nil
+ [ "empty empty = empty" ~:
+ Balance.union Balance.empty Balance.empty
~?=
- (Balance.nil::Balance.Balance Amount)
+ (Balance.empty::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 $
- Data.List.map (id *** Data.Map.map Amount.sum) $
+ Data.List.map (id *** Balance.Account_Sum . Data.Map.map Amount.sum) $
[ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) ]
, Balance.balance_by_unit =
+ Balance.Balance_by_Unit $
Data.Map.fromList $
Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s))
[ Balance.Unit_Sum
(Balance.Balance
{ Balance.balance_by_account =
Lib.TreeMap.from_List const $
- Data.List.map (id *** Data.Map.map Amount.sum) $
+ Data.List.map (id *** Balance.Account_Sum . Data.Map.map Amount.sum) $
[ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) ]
, Balance.balance_by_unit =
+ Balance.Balance_by_Unit $
Data.Map.fromList $
Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s))
[ Balance.Unit_Sum
Balance.Balance
{ Balance.balance_by_account =
Lib.TreeMap.from_List const $
- Data.List.map (id *** Data.Map.map Amount.sum) $
+ Data.List.map (id *** Balance.Account_Sum . Data.Map.map Amount.sum) $
[ ("A":|[], Amount.from_List [ Amount.usd $ 2 ]) ]
, Balance.balance_by_unit =
+ Balance.Balance_by_Unit $
Data.Map.fromList $
Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s))
[ Balance.Unit_Sum
(Balance.Balance
{ Balance.balance_by_account =
Lib.TreeMap.from_List const $
- Data.List.map (id *** Data.Map.map Amount.sum) $
+ Data.List.map (id *** Balance.Account_Sum . Data.Map.map Amount.sum) $
[ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) ]
, Balance.balance_by_unit =
+ Balance.Balance_by_Unit $
Data.Map.fromList $
Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s))
[ Balance.Unit_Sum
(Balance.Balance
{ Balance.balance_by_account =
Lib.TreeMap.from_List const $
- Data.List.map (id *** Data.Map.map Amount.sum) $
+ Data.List.map (id *** Balance.Account_Sum . Data.Map.map Amount.sum) $
[ ("B":|[], Amount.from_List [ Amount.usd $ 1 ]) ]
, Balance.balance_by_unit =
+ Balance.Balance_by_Unit $
Data.Map.fromList $
Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s))
[ Balance.Unit_Sum
Balance.Balance
{ Balance.balance_by_account =
Lib.TreeMap.from_List const $
- Data.List.map (id *** Data.Map.map Amount.sum) $
+ Data.List.map (id *** Balance.Account_Sum . Data.Map.map Amount.sum) $
[ ("A":|[], Amount.from_List [ Amount.usd $ 1 ])
, ("B":|[], Amount.from_List [ Amount.usd $ 1 ]) ]
, Balance.balance_by_unit =
+ Balance.Balance_by_Unit $
Data.Map.fromList $
Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s))
[ Balance.Unit_Sum
(Balance.Balance
{ Balance.balance_by_account =
Lib.TreeMap.from_List const $
- Data.List.map (id *** Data.Map.map Amount.sum) $
+ Data.List.map (id *** Balance.Account_Sum . Data.Map.map Amount.sum) $
[ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) ]
, Balance.balance_by_unit =
+ Balance.Balance_by_Unit $
Data.Map.fromList $
Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s))
[ Balance.Unit_Sum
(Balance.Balance
{ Balance.balance_by_account =
Lib.TreeMap.from_List const $
- Data.List.map (id *** Data.Map.map Amount.sum) $
+ Data.List.map (id *** Balance.Account_Sum . Data.Map.map Amount.sum) $
[ ("B":|[], Amount.from_List [ Amount.eur $ 1 ]) ]
, Balance.balance_by_unit =
+ Balance.Balance_by_Unit $
Data.Map.fromList $
Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s))
[ Balance.Unit_Sum
Balance.Balance
{ Balance.balance_by_account =
Lib.TreeMap.from_List const $
- Data.List.map (id *** Data.Map.map Amount.sum) $
+ Data.List.map (id *** Balance.Account_Sum . Data.Map.map Amount.sum) $
[ ("A":|[], Amount.from_List [ Amount.usd $ 1 ])
, ("B":|[], Amount.from_List [ Amount.eur $ 1 ]) ]
, Balance.balance_by_unit =
+ Balance.Balance_by_Unit $
Data.Map.fromList $
Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s))
[ Balance.Unit_Sum
}
]
, "expanded" ~: TestList
- [ "nil_By_Account" ~:
+ [ "mempty" ~:
Balance.expanded
Lib.TreeMap.empty
~?=
, "A+$1 = A+$1" ~:
Balance.expanded
(Lib.TreeMap.from_List const $
- Data.List.map (id *** Data.Map.map Amount.sum) $
+ Data.List.map (id *** Balance.Account_Sum . Data.Map.map Amount.sum) $
[ ("A":|[], Amount.from_List [ Amount.usd $ 1 ]) ])
~?=
(Lib.TreeMap.from_List const $
[ ("A":|[], Balance.Account_Sum_Expanded
{ Balance.inclusive =
+ Balance.Account_Sum $
Data.Map.map Amount.sum $
Amount.from_List [ Amount.usd $ 1 ]
, Balance.exclusive =
+ Balance.Account_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 Amount.sum) $
+ Data.List.map (id *** Balance.Account_Sum . 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 =
+ Balance.Account_Sum $
Data.Map.map Amount.sum $
Amount.from_List [ Amount.usd $ 1 ]
, Balance.exclusive =
+ Balance.Account_Sum $
Data.Map.map Amount.sum $
Amount.from_List []
})
, ("A":|["A"], Balance.Account_Sum_Expanded
{ Balance.inclusive =
+ Balance.Account_Sum $
Data.Map.map Amount.sum $
Amount.from_List [ Amount.usd $ 1 ]
, Balance.exclusive =
+ Balance.Account_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 Amount.sum) $
+ Data.List.map (id *** Balance.Account_Sum . 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 =
+ Balance.Account_Sum $
Data.Map.map Amount.sum $
Amount.from_List [ Amount.usd $ 1 ]
, Balance.exclusive =
+ Balance.Account_Sum $
Data.Map.map Amount.sum $
Amount.from_List []
})
, ("A":|["B"], Balance.Account_Sum_Expanded
{ Balance.inclusive =
+ Balance.Account_Sum $
Data.Map.map Amount.sum $
Amount.from_List [ Amount.usd $ 1 ]
, Balance.exclusive =
+ Balance.Account_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 Amount.sum) $
+ Data.List.map (id *** Balance.Account_Sum . 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 =
+ Balance.Account_Sum $
Data.Map.map Amount.sum $
Amount.from_List [ Amount.usd $ 1 ]
, Balance.exclusive =
+ Balance.Account_Sum $
Data.Map.map Amount.sum $
Amount.from_List []
})
, ("A":|["B"], Balance.Account_Sum_Expanded
{ Balance.inclusive =
+ Balance.Account_Sum $
Data.Map.map Amount.sum $
Amount.from_List [ Amount.usd $ 1 ]
, Balance.exclusive =
+ Balance.Account_Sum $
Data.Map.map Amount.sum $
Amount.from_List []
})
, ("A":|["B", "C"], Balance.Account_Sum_Expanded
{ Balance.inclusive =
+ Balance.Account_Sum $
Data.Map.map Amount.sum $
Amount.from_List [ Amount.usd $ 1 ]
, Balance.exclusive =
+ Balance.Account_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 Amount.sum) $
+ Data.List.map (id *** Balance.Account_Sum . Data.Map.map 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 =
+ Balance.Account_Sum $
Data.Map.map Amount.sum $
Amount.from_List [ Amount.usd $ 2 ]
, Balance.exclusive =
+ Balance.Account_Sum $
Data.Map.map Amount.sum $
Amount.from_List [ Amount.usd $ 1 ]
})
, ("A":|["B"], Balance.Account_Sum_Expanded
{ Balance.inclusive =
+ Balance.Account_Sum $
Data.Map.map Amount.sum $
Amount.from_List [ Amount.usd $ 1 ]
, Balance.exclusive =
+ Balance.Account_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 Amount.sum) $
+ Data.List.map (id *** Balance.Account_Sum . 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 ])
(Lib.TreeMap.from_List const
[ ("A":|[], Balance.Account_Sum_Expanded
{ Balance.inclusive =
+ Balance.Account_Sum $
Data.Map.map Amount.sum $
Amount.from_List [ Amount.usd $ 3 ]
, Balance.exclusive =
+ Balance.Account_Sum $
Data.Map.map Amount.sum $
Amount.from_List [ Amount.usd $ 1 ]
})
, ("A":|["B"], Balance.Account_Sum_Expanded
{ Balance.inclusive =
+ Balance.Account_Sum $
Data.Map.map Amount.sum $
Amount.from_List [ Amount.usd $ 2 ]
, Balance.exclusive =
+ Balance.Account_Sum $
Data.Map.map Amount.sum $
Amount.from_List [ Amount.usd $ 1 ]
})
, ("A":|["B", "C"], Balance.Account_Sum_Expanded
{ Balance.inclusive =
+ Balance.Account_Sum $
Data.Map.map Amount.sum $
Amount.from_List [ Amount.usd $ 1 ]
, Balance.exclusive =
+ Balance.Account_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 Amount.sum) $
+ Data.List.map (id *** Balance.Account_Sum . 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 ])
(Lib.TreeMap.from_List const
[ ("A":|[], Balance.Account_Sum_Expanded
{ Balance.inclusive =
+ Balance.Account_Sum $
Data.Map.map Amount.sum $
Amount.from_List [ Amount.usd $ 4 ]
, Balance.exclusive =
+ Balance.Account_Sum $
Data.Map.map Amount.sum $
Amount.from_List [ Amount.usd $ 1 ]
})
, ("A":|["B"], Balance.Account_Sum_Expanded
{ Balance.inclusive =
+ Balance.Account_Sum $
Data.Map.map Amount.sum $
Amount.from_List [ Amount.usd $ 3 ]
, Balance.exclusive =
+ Balance.Account_Sum $
Data.Map.map Amount.sum $
Amount.from_List [ Amount.usd $ 1 ]
})
, ("A":|["B", "C"], Balance.Account_Sum_Expanded
{ Balance.inclusive =
+ Balance.Account_Sum $
Data.Map.map Amount.sum $
Amount.from_List [ Amount.usd $ 2 ]
, Balance.exclusive =
+ Balance.Account_Sum $
Data.Map.map Amount.sum $
Amount.from_List [ Amount.usd $ 1 ]
})
, ("A":|["B", "C", "D"], Balance.Account_Sum_Expanded
{ Balance.inclusive =
+ Balance.Account_Sum $
Data.Map.map Amount.sum $
Amount.from_List [ Amount.usd $ 1 ]
, Balance.exclusive =
+ Balance.Account_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 Amount.sum) $
+ Data.List.map (id *** Balance.Account_Sum . 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 ])
(Lib.TreeMap.from_List const
[ ("A":|[], Balance.Account_Sum_Expanded
{ Balance.inclusive =
+ Balance.Account_Sum $
Data.Map.map Amount.sum $
Amount.from_List [ Amount.usd $ 3 ]
, Balance.exclusive =
+ Balance.Account_Sum $
Data.Map.map Amount.sum $
Amount.from_List [ Amount.usd $ 1 ]
})
, ("A":|["B"], Balance.Account_Sum_Expanded
{ Balance.inclusive =
+ Balance.Account_Sum $
Data.Map.map Amount.sum $
Amount.from_List [ Amount.usd $ 1 ]
, Balance.exclusive =
+ Balance.Account_Sum $
Data.Map.map Amount.sum $
Amount.from_List [ Amount.usd $ 1 ]
})
, ("A":|["BB"], Balance.Account_Sum_Expanded
{ Balance.inclusive =
+ Balance.Account_Sum $
Data.Map.map Amount.sum $
Amount.from_List [ Amount.usd $ 1 ]
, Balance.exclusive =
+ Balance.Account_Sum $
Data.Map.map Amount.sum $
Amount.from_List [ Amount.usd $ 1 ]
})
, ("AA":|[], Balance.Account_Sum_Expanded
{ Balance.inclusive =
+ Balance.Account_Sum $
Data.Map.map Amount.sum $
Amount.from_List [ Amount.usd $ 1 ]
, Balance.exclusive =
+ Balance.Account_Sum $
Data.Map.map Amount.sum $
Amount.from_List []
})
, ("AA":|["B"], Balance.Account_Sum_Expanded
{ Balance.inclusive =
+ Balance.Account_Sum $
Data.Map.map Amount.sum $
Amount.from_List [ Amount.usd $ 1 ]
, Balance.exclusive =
+ Balance.Account_Sum $
Data.Map.map Amount.sum $
Amount.from_List [ Amount.usd $ 1 ]
})
Balance.Balance
{ Balance.balance_by_account =
Lib.TreeMap.from_List const $
- Data.List.map (id *** Data.Map.map Amount.sum) $
+ Data.List.map (id *** Balance.Account_Sum . Data.Map.map Amount.sum) $
[ ("A":|[], Amount.from_List [ Amount.usd $ 1 ])
, ("B":|[], Amount.from_List [])
]
, Balance.balance_by_unit =
+ Balance.Balance_by_Unit $
Data.Map.fromList $
Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s))
[ Balance.Unit_Sum
})
~?=
(Balance.Deviation $
+ Balance.Balance_by_Unit $
Data.Map.fromList $
Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s))
[ Balance.Unit_Sum
Balance.Balance
{ Balance.balance_by_account =
Lib.TreeMap.from_List const $
- Data.List.map (id *** Data.Map.map Amount.sum) $
+ Data.List.map (id *** Balance.Account_Sum . Data.Map.map Amount.sum) $
[ ("A":|[], Amount.from_List [ Amount.usd $ 1 ])
, ("B":|[], Amount.from_List [ Amount.usd $ 1 ])
]
, Balance.balance_by_unit =
+ Balance.Balance_by_Unit $
Data.Map.fromList $
Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s))
[ Balance.Unit_Sum
})
~?=
(Balance.Deviation $
+ Balance.Balance_by_Unit $
Data.Map.fromList $
Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s))
[ Balance.Unit_Sum
(@=?) True $
Balance.is_equilibrium_inferrable $
Balance.deviation $
- (Balance.nil::Balance.Balance Amount.Amount)
+ (Balance.empty::Balance.Balance Amount.Amount)
, "{A+$0, $+0}" ~: TestCase $
(@=?) True $
Balance.is_equilibrium_inferrable $
Balance.Balance
{ Balance.balance_by_account =
Lib.TreeMap.from_List const $
- Data.List.map (id *** Data.Map.map Amount.sum) $
+ Data.List.map (id *** Balance.Account_Sum . Data.Map.map Amount.sum) $
[ ("A":|[], Amount.from_List [ Amount.usd $ 0 ])
]
, Balance.balance_by_unit =
+ Balance.Balance_by_Unit $
Data.Map.fromList $
Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s))
[ Balance.Unit_Sum
Balance.Balance
{ Balance.balance_by_account =
Lib.TreeMap.from_List const $
- Data.List.map (id *** Data.Map.map Amount.sum) $
+ Data.List.map (id *** Balance.Account_Sum . Data.Map.map Amount.sum) $
[ ("A":|[], Amount.from_List [ Amount.usd $ 1 ])
]
, Balance.balance_by_unit =
+ Balance.Balance_by_Unit $
Data.Map.fromList $
Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s))
[ Balance.Unit_Sum
Balance.Balance
{ Balance.balance_by_account =
Lib.TreeMap.from_List const $
- Data.List.map (id *** Data.Map.map Amount.sum) $
+ Data.List.map (id *** Balance.Account_Sum . Data.Map.map Amount.sum) $
[ ("A":|[], Amount.from_List [ Amount.usd $ 0, Amount.eur $ 0 ])
]
, Balance.balance_by_unit =
+ Balance.Balance_by_Unit $
Data.Map.fromList $
Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s))
[ Balance.Unit_Sum
Balance.Balance
{ Balance.balance_by_account =
Lib.TreeMap.from_List const $
- Data.List.map (id *** Data.Map.map Amount.sum) $
+ Data.List.map (id *** Balance.Account_Sum . Data.Map.map Amount.sum) $
[ ("A":|[], Amount.from_List [ Amount.usd $ 1 ])
, ("B":|[], Amount.from_List [ Amount.usd $ -1 ])
]
, Balance.balance_by_unit =
+ Balance.Balance_by_Unit $
Data.Map.fromList $
Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s))
[ Balance.Unit_Sum
Balance.Balance
{ Balance.balance_by_account =
Lib.TreeMap.from_List const $
- Data.List.map (id *** Data.Map.map Amount.sum) $
+ Data.List.map (id *** Balance.Account_Sum . Data.Map.map Amount.sum) $
[ ("A":|[], Amount.from_List [ Amount.usd $ 1 ])
, ("B":|[], Amount.from_List [])
]
, Balance.balance_by_unit =
+ Balance.Balance_by_Unit $
Data.Map.fromList $
Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s))
[ Balance.Unit_Sum
Balance.Balance
{ Balance.balance_by_account =
Lib.TreeMap.from_List const $
- Data.List.map (id *** Data.Map.map Amount.sum) $
+ Data.List.map (id *** Balance.Account_Sum . Data.Map.map Amount.sum) $
[ ("A":|[], Amount.from_List [ Amount.usd $ 1 ])
, ("B":|[], Amount.from_List [ Amount.eur $ 1 ])
]
, Balance.balance_by_unit =
+ Balance.Balance_by_Unit $
Data.Map.fromList $
Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s))
[ Balance.Unit_Sum
Balance.Balance
{ Balance.balance_by_account =
Lib.TreeMap.from_List const $
- Data.List.map (id *** Data.Map.map Amount.sum) $
+ Data.List.map (id *** Balance.Account_Sum . 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 =
+ Balance.Balance_by_Unit $
Data.Map.fromList $
Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s))
[ Balance.Unit_Sum
Balance.Balance
{ Balance.balance_by_account =
Lib.TreeMap.from_List const $
- Data.List.map (id *** Data.Map.map Amount.sum) $
+ Data.List.map (id *** Balance.Account_Sum . 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 =
+ Balance.Balance_by_Unit $
Data.Map.fromList $
Data.List.map (\s -> (Amount.unit $ Amount.sum_balance $ Balance.unit_sum_amount s, s))
[ Balance.Unit_Sum
(Data.Either.rights $
[P.runParser_with_Error
(Format.Ledger.Read.posting <* P.eof)
- Format.Ledger.Read.nil_Context "" (" A:B:C"::Text)])
+ (Format.Ledger.Read.context Format.Ledger.journal::Format.Ledger.Read.Context [] Format.Ledger.Transaction)
+ "" (" A:B:C"::Text)])
~?=
[ ( (Format.Ledger.posting ("A":|["B", "C"]))
{ Format.Ledger.posting_sourcepos = P.newPos "" 1 1
Data.Either.rights $
[P.runParser_with_Error
(Format.Ledger.Read.posting <* P.eof)
- Format.Ledger.Read.nil_Context "" (" !A:B:C"::Text)])
+ (Format.Ledger.Read.context Format.Ledger.journal::Format.Ledger.Read.Context [] Format.Ledger.Transaction)
+ "" (" !A:B:C"::Text)])
~?=
[ (Format.Ledger.posting ("A":|["B", "C"]))
{ Format.Ledger.posting_sourcepos = P.newPos "" 1 1
Data.Either.rights $
[P.runParser_with_Error
(Format.Ledger.Read.posting <* P.eof)
- Format.Ledger.Read.nil_Context "" (" *A:B:C"::Text)])
+ (Format.Ledger.Read.context Format.Ledger.journal::Format.Ledger.Read.Context [] Format.Ledger.Transaction)
+ "" (" *A:B:C"::Text)])
~?=
[ (Format.Ledger.posting ("A":|["B", "C"]))
{ Format.Ledger.posting_amounts = Data.Map.fromList []
Data.Either.rights $
[P.runParser_with_Error
(Format.Ledger.Read.posting <* P.eof)
- Format.Ledger.Read.nil_Context "" (" A:B:C $1"::Text)])
+ (Format.Ledger.Read.context Format.Ledger.journal::Format.Ledger.Read.Context [] Format.Ledger.Transaction)
+ "" (" A:B:C $1"::Text)])
~?=
[ (Format.Ledger.posting ("A":|["B","C $1"]))
{ Format.Ledger.posting_sourcepos = P.newPos "" 1 1
Data.Either.rights $
[P.runParser_with_Error
(Format.Ledger.Read.posting <* P.eof)
- Format.Ledger.Read.nil_Context "" (" A:B:C $1"::Text)])
+ (Format.Ledger.Read.context Format.Ledger.journal::Format.Ledger.Read.Context [] Format.Ledger.Transaction)
+ "" (" A:B:C $1"::Text)])
~?=
[ (Format.Ledger.posting ("A":|["B", "C"]))
{ Format.Ledger.posting_amounts = Data.Map.fromList
Data.Either.rights $
[P.runParser_with_Error
(Format.Ledger.Read.posting <* P.eof)
- Format.Ledger.Read.nil_Context "" (" A:B:C $1 + 1€"::Text)])
+ (Format.Ledger.Read.context Format.Ledger.journal::Format.Ledger.Read.Context [] Format.Ledger.Transaction)
+ "" (" A:B:C $1 + 1€"::Text)])
~?=
[ (Format.Ledger.posting ("A":|["B", "C"]))
{ Format.Ledger.posting_amounts = Data.Map.fromList
Data.Either.rights $
[P.runParser_with_Error
(Format.Ledger.Read.posting <* P.eof)
- Format.Ledger.Read.nil_Context "" (" A:B:C $1 + 1$"::Text)])
+ (Format.Ledger.Read.context Format.Ledger.journal::Format.Ledger.Read.Context [] Format.Ledger.Transaction)
+ "" (" A:B:C $1 + 1$"::Text)])
~?=
[ (Format.Ledger.posting ("A":|["B", "C"]))
{ Format.Ledger.posting_amounts = Data.Map.fromList
Data.Either.rights $
[P.runParser_with_Error
(Format.Ledger.Read.posting <* P.eof)
- Format.Ledger.Read.nil_Context "" (" A:B:C $1 + 1$ + 1$"::Text)])
+ (Format.Ledger.Read.context Format.Ledger.journal::Format.Ledger.Read.Context [] Format.Ledger.Transaction)
+ "" (" A:B:C $1 + 1$ + 1$"::Text)])
~?=
[ (Format.Ledger.posting ("A":|["B", "C"]))
{ Format.Ledger.posting_amounts = Data.Map.fromList
Data.Either.rights $
[P.runParser_with_Error
(Format.Ledger.Read.posting <* P.eof)
- Format.Ledger.Read.nil_Context "" (" A:B:C ; some comment"::Text)])
+ (Format.Ledger.Read.context Format.Ledger.journal::Format.Ledger.Read.Context [] Format.Ledger.Transaction)
+ "" (" A:B:C ; some comment"::Text)])
~?=
[ (Format.Ledger.posting ("A":|["B", "C"]))
{ Format.Ledger.posting_amounts = Data.Map.fromList []
Data.Either.rights $
[P.runParser_with_Error
(Format.Ledger.Read.posting <* P.eof)
- Format.Ledger.Read.nil_Context "" (" A:B:C ; some comment\n ; some other comment"::Text)])
+ (Format.Ledger.Read.context Format.Ledger.journal::Format.Ledger.Read.Context [] Format.Ledger.Transaction)
+ "" (" A:B:C ; some comment\n ; some other comment"::Text)])
~?=
[ (Format.Ledger.posting ("A":|["B", "C"]))
{ Format.Ledger.posting_amounts = Data.Map.fromList []
Data.Either.rights $
[P.runParser_with_Error
(Format.Ledger.Read.posting)
- Format.Ledger.Read.nil_Context "" (" A:B:C $1 ; some comment"::Text)])
+ (Format.Ledger.Read.context Format.Ledger.journal::Format.Ledger.Read.Context [] Format.Ledger.Transaction)
+ "" (" A:B:C $1 ; some comment"::Text)])
~?=
[ (Format.Ledger.posting ("A":|["B", "C"]))
{ Format.Ledger.posting_amounts = Data.Map.fromList
Data.Either.rights $
[P.runParser_with_Error
(Format.Ledger.Read.posting <* P.eof)
- Format.Ledger.Read.nil_Context "" (" A:B:C ; N:V"::Text)])
+ (Format.Ledger.Read.context Format.Ledger.journal::Format.Ledger.Read.Context [] Format.Ledger.Transaction)
+ "" (" A:B:C ; N:V"::Text)])
~?=
[ (Format.Ledger.posting ("A":|["B", "C"]))
{ Format.Ledger.posting_comments = [" N:V"]
Data.Either.rights $
[P.runParser_with_Error
(Format.Ledger.Read.posting <* P.eof)
- Format.Ledger.Read.nil_Context "" (" A:B:C ; some comment N:V"::Text)])
+ (Format.Ledger.Read.context Format.Ledger.journal::Format.Ledger.Read.Context [] Format.Ledger.Transaction)
+ "" (" A:B:C ; some comment N:V"::Text)])
~?=
[ (Format.Ledger.posting ("A":|["B", "C"]))
{ Format.Ledger.posting_comments = [" some comment N:V"]
Data.Either.rights $
[P.runParser_with_Error
(Format.Ledger.Read.posting )
- Format.Ledger.Read.nil_Context "" (" A:B:C ; some comment N:V v, N2:V2 v2"::Text)])
+ (Format.Ledger.Read.context Format.Ledger.journal::Format.Ledger.Read.Context [] Format.Ledger.Transaction)
+ "" (" A:B:C ; some comment N:V v, N2:V2 v2"::Text)])
~?=
[ (Format.Ledger.posting ("A":|["B", "C"]))
{ Format.Ledger.posting_comments = [" some comment N:V v, N2:V2 v2"]
Data.Either.rights $
[P.runParser_with_Error
(Format.Ledger.Read.posting <* P.eof)
- Format.Ledger.Read.nil_Context "" (" A:B:C ; N:V\n ; N:V2"::Text)])
+ (Format.Ledger.Read.context Format.Ledger.journal::Format.Ledger.Read.Context [] Format.Ledger.Transaction)
+ "" (" A:B:C ; N:V\n ; N:V2"::Text)])
~?=
[ (Format.Ledger.posting ("A":|["B", "C"]))
{ Format.Ledger.posting_comments = [" N:V", " N:V2"]
Data.Either.rights $
[P.runParser_with_Error
(Format.Ledger.Read.posting <* P.eof)
- Format.Ledger.Read.nil_Context "" (" A:B:C ; N:V\n ; N2:V"::Text)])
+ (Format.Ledger.Read.context Format.Ledger.journal::Format.Ledger.Read.Context [] Format.Ledger.Transaction)
+ "" (" A:B:C ; N:V\n ; N2:V"::Text)])
~?=
[ (Format.Ledger.posting ("A":|["B", "C"]))
{ Format.Ledger.posting_comments = [" N:V", " N2:V"]
Data.Either.rights $
[P.runParser_with_Error
(Format.Ledger.Read.posting <* P.eof)
- Format.Ledger.Read.nil_Context "" (" A:B:C ; date:2001/01/01"::Text)])
+ (Format.Ledger.Read.context Format.Ledger.journal::Format.Ledger.Read.Context [] Format.Ledger.Transaction)
+ "" (" A:B:C ; date:2001/01/01"::Text)])
~?=
[ (Format.Ledger.posting ("A":|["B", "C"]))
{ Format.Ledger.posting_comments = [" date:2001/01/01"]
(Data.Either.rights $
[P.runParser_with_Error
(Format.Ledger.Read.posting <* P.eof)
- Format.Ledger.Read.nil_Context "" (" (A:B:C)"::Text)])
+ (Format.Ledger.Read.context Format.Ledger.journal::Format.Ledger.Read.Context [] Format.Ledger.Transaction)
+ "" (" (A:B:C)"::Text)])
~?=
[ ( (Format.Ledger.posting ("A":|["B", "C"]))
{ Format.Ledger.posting_sourcepos = P.newPos "" 1 1
(Data.Either.rights $
[P.runParser_with_Error
(Format.Ledger.Read.posting <* P.eof)
- Format.Ledger.Read.nil_Context "" (" [A:B:C]"::Text)])
+ (Format.Ledger.Read.context Format.Ledger.journal::Format.Ledger.Read.Context [] Format.Ledger.Transaction)
+ "" (" [A:B:C]"::Text)])
~?=
[ ( (Format.Ledger.posting ("A":|["B", "C"]))
{ Format.Ledger.posting_sourcepos = P.newPos "" 1 1
(Data.Either.rights $
[P.runParser_with_Error
(Format.Ledger.Read.transaction <* P.eof)
- Format.Ledger.Read.nil_Context "" ("2000/01/01 some description\n A:B:C $1\n a:b:c"::Text)])
+ (Format.Ledger.Read.context Format.Ledger.journal::Format.Ledger.Read.Context [] Format.Ledger.Transaction)
+ "" ("2000/01/01 some description\n A:B:C $1\n a:b:c"::Text)])
~?=
[ Format.Ledger.transaction
{ Format.Ledger.transaction_dates=
(Data.Either.rights $
[P.runParser_with_Error
(Format.Ledger.Read.transaction <* P.newline <* P.eof)
- Format.Ledger.Read.nil_Context "" ("2000/01/01 some description\n A:B:C $1\n a:b:c\n"::Text)])
+ (Format.Ledger.Read.context Format.Ledger.journal::Format.Ledger.Read.Context [] Format.Ledger.Transaction)
+ "" ("2000/01/01 some description\n A:B:C $1\n a:b:c\n"::Text)])
~?=
[ Format.Ledger.transaction
{ Format.Ledger.transaction_dates=
(Data.Either.rights $
[P.runParser_with_Error
(Format.Ledger.Read.transaction <* P.eof)
- Format.Ledger.Read.nil_Context "" ("2000/01/01 some description ; some comment\n ; some other;comment\n ; some Tag:\n ; some last comment\n A:B:C $1\n a:b:c"::Text)])
+ (Format.Ledger.Read.context Format.Ledger.journal::Format.Ledger.Read.Context [] Format.Ledger.Transaction)
+ "" ("2000/01/01 some description ; some comment\n ; some other;comment\n ; some Tag:\n ; some last comment\n A:B:C $1\n a:b:c"::Text)])
~?=
[ Format.Ledger.transaction
{ Format.Ledger.transaction_comments_after =
jnl <- liftIO $
P.runParserT_with_Error
(Format.Ledger.Read.journal "" {-<* P.eof-})
- Format.Ledger.Read.nil_Context "" ("2000/01/01 1° description\n A:B:C $1\n a:b:c\n2000/01/02 2° description\n A:B:C $1\n x:y:z"::Text)
+ (Format.Ledger.Read.context Format.Ledger.journal
+ ::Format.Ledger.Read.Context [] Format.Ledger.Transaction)
+ "" ("2000/01/01 1° description\n A:B:C $1\n a:b:c\n2000/01/02 2° description\n A:B:C $1\n x:y:z"::Text)
(Data.List.map
- (\j -> j{Format.Ledger.journal_last_read_time=
- Format.Ledger.journal_last_read_time Format.Ledger.journal}) $
+ (\j -> j{Format.Ledger.journal_last_read_time=Date.nil}) $
Data.Either.rights [jnl])
@?=
[ Format.Ledger.journal
{ Format.Ledger.journal_transactions =
- Format.Ledger.transaction_by_Date
[ Format.Ledger.transaction
{ Format.Ledger.transaction_dates=
( Time.zonedTimeToUTC $
Time.ZonedTime
(Time.LocalTime
- (Time.fromGregorian 2000 01 01)
+ (Time.fromGregorian 2000 01 02)
(Time.TimeOfDay 0 0 0))
(Time.utc)
, [] )
- , Format.Ledger.transaction_description="1° description"
+ , Format.Ledger.transaction_description="2° description"
, Format.Ledger.transaction_postings = Format.Ledger.posting_by_Account
[ (Format.Ledger.posting ("A":|["B", "C"]))
{ Format.Ledger.posting_amounts = Data.Map.fromList
, Amount.unit = "$"
})
]
- , Format.Ledger.posting_sourcepos = P.newPos "" 2 1
+ , Format.Ledger.posting_sourcepos = P.newPos "" 5 1
}
- , (Format.Ledger.posting ("a":|["b", "c"]))
+ , (Format.Ledger.posting ("x":|["y", "z"]))
{ Format.Ledger.posting_amounts = Data.Map.fromList
[ ("$", Amount.nil
{ Amount.quantity = -1
, Amount.unit = "$"
})
]
- , Format.Ledger.posting_sourcepos = P.newPos "" 3 1
+ , Format.Ledger.posting_sourcepos = P.newPos "" 6 1
}
]
- , Format.Ledger.transaction_sourcepos = P.newPos "" 1 1
+ , Format.Ledger.transaction_sourcepos = P.newPos "" 4 1
}
, Format.Ledger.transaction
{ Format.Ledger.transaction_dates=
( Time.zonedTimeToUTC $
Time.ZonedTime
(Time.LocalTime
- (Time.fromGregorian 2000 01 02)
+ (Time.fromGregorian 2000 01 01)
(Time.TimeOfDay 0 0 0))
(Time.utc)
, [] )
- , Format.Ledger.transaction_description="2° description"
+ , Format.Ledger.transaction_description="1° description"
, Format.Ledger.transaction_postings = Format.Ledger.posting_by_Account
[ (Format.Ledger.posting ("A":|["B", "C"]))
{ Format.Ledger.posting_amounts = Data.Map.fromList
, Amount.unit = "$"
})
]
- , Format.Ledger.posting_sourcepos = P.newPos "" 5 1
+ , Format.Ledger.posting_sourcepos = P.newPos "" 2 1
}
- , (Format.Ledger.posting ("x":|["y", "z"]))
+ , (Format.Ledger.posting ("a":|["b", "c"]))
{ Format.Ledger.posting_amounts = Data.Map.fromList
[ ("$", Amount.nil
{ Amount.quantity = -1
, Amount.unit = "$"
})
]
- , Format.Ledger.posting_sourcepos = P.newPos "" 6 1
+ , Format.Ledger.posting_sourcepos = P.newPos "" 3 1
}
]
- , Format.Ledger.transaction_sourcepos = P.newPos "" 4 1
+ , Format.Ledger.transaction_sourcepos = P.newPos "" 1 1
}
]
}
ghc-options: -O2
if flag(prof)
cpp-options: -DPROFILING
- ghc-options: -fprof-auto
+ ghc-options: -O2 -fprof-auto
if flag(double)
cpp-options: -DDOUBLE
if flag(dump)
- ghc-options: -ddump-simple -ddump-stg -ddump-to-file
+ ghc-options: -ddump-simpl -ddump-stg -ddump-to-file
-- default-language: Haskell2010
exposed-modules:
Hcompta.Account
Hcompta.Format.Ledger.Read
Hcompta.Format.Ledger.Write
Hcompta.GL
+ Hcompta.Journal
+ Hcompta.Lib.Consable
Hcompta.Lib.Foldable
Hcompta.Lib.Interval
Hcompta.Lib.Interval.Sieve
Hcompta.Lib.Parsec
Hcompta.Lib.Path
Hcompta.Lib.Regex
+ Hcompta.Lib.Strict
Hcompta.Lib.TreeMap
build-depends:
base >= 4.7 && < 5
-- , collections-api
-- , collections-base-instances
, Decimal
+ , deepseq
, directory
, filepath
, fingertree
- , HUnit
+ -- , HUnit
, integer-gmp
-- , lens
-- , mmorph
, regex-tdfa-text
-- , safe >= 0.2
, semigroups
+ , strict
, test-framework
, test-framework-hunit
, text
, parsec >= 3.1.2 && < 4
-- , safe
, semigroups
+ , strict
, test-framework
, test-framework-hunit
, text