+{-# 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
+-- | 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.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: not needed so far.
instance
( Posting posting
, Data posting
type Transaction_Postings (Date, Map Account ([] posting)) = Compose (Map Account) []
transaction_date = fst
transaction_postings = Compose . snd
+ transaction_postings_filter f =
+ fmap $
+ Data.Map.mapMaybe
+ (\p -> case filter f p of
+ [] -> Nothing
+ ps -> Just ps)
+-}
+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
data
Transaction transaction
- => GL_Line transaction
+ => GL_Line transaction
= GL_Line
{ gl_line_transaction :: transaction
, gl_line_posting :: Transaction_Posting transaction
-- ** Constructors
-nil
+empty
:: Transaction transaction
=> GL transaction
-nil = GL TreeMap.empty
+empty = GL mempty
-- | Return the given 'GL'
--- updated by the given 'Posting'.
-general_ledger
+-- updated by the given 'Transaction'.
+--
+-- NOTE: to reduce memory consumption when 'cons'ing iteratively,
+-- the given 'GL' is matched strictly.
+cons
:: Transaction transaction
=> transaction
-> GL transaction
-> GL transaction
-general_ledger t (GL gl) =
+cons t (GL !gl) =
GL $
- Data.Foldable.foldr
- ((\p ->
+ Data.Foldable.foldl'
+ (flip $ \p ->
let first_line =
GL_Line
{ gl_line_transaction = t
in
Data.Map.union nlt $
Data.Map.insert (transaction_date t) neq $
- Data.Map.map (fmap (\l -> l{gl_line_sum =
- amount_add (gl_line_sum leq) $
- gl_line_sum l})) ngt
+ Data.Map.map
+ (fmap (\l -> l{gl_line_sum =
+ amount_add (gl_line_sum leq) $ gl_line_sum l}))
+ ngt
)
(posting_account p)
single
- ))
+ )
gl
(transaction_postings t)
+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.
type Expanded transaction
= TreeMap Account.Name (GL_Line_Expanded transaction)
-data Transaction transaction
+data Transaction transaction
=> GL_Line_Expanded transaction
= GL_Line_Expanded
- { exclusive :: Map Date (Seq (GL_Line transaction))
- , inclusive :: Map Date (Seq (GL_Line transaction)) -- ^ 'amount_add' folded over 'exclusive' and 'inclusive' of 'Lib.TreeMap.node_descendants'
+ { exclusive :: !(Map Date (Seq (GL_Line transaction)))
+ , inclusive :: !(Map Date (Seq (GL_Line transaction))) -- ^ 'amount_add' folded over 'exclusive' and 'inclusive' of 'Lib.TreeMap.node_descendants'
}
deriving instance ( Transaction transaction
, Data transaction
=> 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 =
) Nothing $
Compose $
Data.Map.foldr
- (Data.Map.unionWith (><) . inclusive . from_value)
+ (Data.Map.unionWith (flip (><)) . inclusive . from_value)
exclusive nodes
})
gl