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