-{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE NamedFieldPuns #-}
module Hcompta.Format.Ledger.Journal where
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 :: Monoid (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, Monoid (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, Monoid (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 :: Monoid (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 :: Monoid (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 :: Monoid (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, Monoid (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 :: Monoid (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 :: Monoid (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)