{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE NamedFieldPuns #-} module Hcompta.Format.Ledger.Journal where -- import Control.Applicative ((<$>)) import qualified Control.Monad import Data.Foldable hiding (fold) import qualified Data.List 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.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 :: 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) journal_includes -- | Return the given accumulator folded over -- the given 'Journal' and its 'journal_includes' 'Journal's. 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 (flip (foldM f)) ma journal_includes -- | Return the given accumulator folded with the given function -- over the given 'Journal' and its 'journal_includes' 'Journal's. 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 :: Monoid (ts t) => (Journal (ts t) -> Maybe a) -> Journal (ts t) -> Maybe (a, [Journal (ts t)]) find f = (\x -> case x of Nothing -> Nothing Just (a, path) -> Just (a, reverse path)) . find_ [] where find_ path j@Journal{journal_includes} = case f j of Just a -> Just (a, path) Nothing -> Data.Monoid.getFirst $ foldMap (Data.Monoid.First . (find_ (j:path))) $ journal_includes -- | Return the given 'Journal' and its 'journal_includes' 'Journal's -- mapped by the given function. 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} -> j{journal_includes = Data.List.map (traverse f) journal_includes}) . f -- * Constructors 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 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 :: Monoid (ts t) => Journal (ts t) -> Journal (ts t) flatten jnl = jnl { journal_includes = [] , journal_transactions = flat journal_transactions jnl } where 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)