]> Git — Sourcephile - comptalang.git/blob - lib/Hcompta/Format/Ledger/Journal.hs
Modification : filtre dès la lecture pour moins de consommation mémoire.
[comptalang.git] / lib / Hcompta / Format / Ledger / Journal.hs
1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE NamedFieldPuns #-}
3 module Hcompta.Format.Ledger.Journal where
4
5 -- import Control.Applicative ((<$>))
6 import qualified Control.Monad
7 import Data.Foldable hiding (fold)
8 import qualified Data.List
9 import qualified Data.Monoid (getFirst, First(..))
10 -- import Data.Monoid (Monoid, mappend)
11 import qualified Data.Map.Strict as Data.Map
12 import Prelude hiding (traverse)
13 import Data.Typeable ()
14
15 import qualified Hcompta.Amount.Style as Amount.Style
16 import Hcompta.Format.Ledger (Journal(..))
17 import qualified Hcompta.Format.Ledger as Ledger
18 import Hcompta.Lib.Consable (Consable(..))
19
20 -- * Extractors
21
22 -- | Return the given accumulator folded over
23 -- the given 'Journal' and its 'journal_includes' 'Journal's.
24 fold :: Consable ts t => (Journal ts t -> a -> a) -> Journal ts t -> a -> a
25 fold f j@Journal{journal_includes} a =
26 Data.List.foldl'
27 (flip (fold f)) (f j a)
28 journal_includes
29
30 -- | Return the given accumulator folded over
31 -- the given 'Journal' and its 'journal_includes' 'Journal's.
32 foldM :: (Monad m, Consable ts t) => (Journal ts t -> a -> m a) -> Journal ts t -> a -> m a
33 foldM f j@Journal{journal_includes} a = do
34 ma <- f j a
35 Control.Monad.foldM
36 (flip (foldM f)) ma
37 journal_includes
38
39 -- | Return the given accumulator folded with the given function
40 -- over the given 'Journal' and its 'journal_includes' 'Journal's.
41 fold_map :: (Monoid a, Consable ts t) => (Journal ts t -> a -> a) -> Journal ts t -> a -> a
42 fold_map f j@(Journal{journal_includes}) =
43 (f j) `mappend` foldMap (fold_map f) journal_includes
44
45 -- | Return the first non-'Nothing' value returned by the given function
46 -- when applied to the given 'Journal' or its 'journal_includes' 'Journal's,
47 -- with the parent 'Journal's.
48 find :: Consable ts t => (Journal ts t -> Maybe a) -> Journal ts t -> Maybe (a, [Journal ts t])
49 find f =
50 (\x -> case x of
51 Nothing -> Nothing
52 Just (a, path) -> Just (a, reverse path))
53 . find_ []
54 where
55 find_ path j@Journal{journal_includes} =
56 case f j of
57 Just a -> Just (a, path)
58 Nothing ->
59 Data.Monoid.getFirst $
60 foldMap (Data.Monoid.First . (find_ (j:path))) $
61 journal_includes
62
63 -- | Return the given 'Journal' and its 'journal_includes' 'Journal's
64 -- mapped by the given function.
65 traverse :: Consable ts t => (Journal ts t -> Journal ts t) -> Journal ts t -> Journal ts t
66 traverse f =
67 (\x -> case x of
68 j@Journal{journal_includes} ->
69 j{journal_includes = Data.List.map (traverse f) journal_includes})
70 . f
71
72 -- * Constructors
73
74 union :: Consable ts t => Journal ts t -> Journal ts t -> Journal ts t
75 union j0 j1 =
76 j1{ journal_transactions = mappend (journal_transactions j0) (journal_transactions j1)
77 , journal_unit_styles = Data.Map.unionWith Amount.Style.union (journal_unit_styles j0) (journal_unit_styles j1)
78 , journal_last_read_time = min (journal_last_read_time j0) (journal_last_read_time j1)
79 }
80
81 unions :: (Foldable f, Consable ts t) => f (Journal ts t) -> Journal ts t
82 unions = Data.Foldable.foldl' (flip union) Ledger.journal
83
84 -- | Return the 'Journal' with its 'journal_transactions'
85 -- recursively completed by the 'journal_transactions'
86 -- of its 'journal_includes', now empty.
87 flatten :: Consable ts t => Journal ts t -> Journal ts t
88 flatten jnl =
89 jnl
90 { journal_includes = []
91 , journal_transactions = flat journal_transactions jnl
92 }
93 where
94 flat :: Consable ts t => (Journal ts t -> ts t) -> Journal ts t -> ts t
95 flat g j = mconcat $ g j : Data.List.map (flat g) (journal_includes j)