]> Git — Sourcephile - comptalang.git/blob - lib/Hcompta/Format/Ledger/Journal.hs
Ajout : CLI.Lib.Shakespeare.Leijen : et demain L’Internationale...
[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 Data.Foldable (foldMap)
7 import Data.Foldable (Foldable(..))
8 import qualified Data.List
9 import qualified Data.Map.Strict as Data.Map
10 import qualified Data.Monoid (getFirst, First(..))
11 import Data.Monoid (Monoid, mappend)
12 import Data.Typeable ()
13
14 import qualified Hcompta.Format.Ledger as Ledger
15 import Hcompta.Format.Ledger (Journal(..))
16
17 -- * Extractors
18
19 -- | Return the given accumulator folded over
20 -- the given 'Journal' and its 'journal_includes' 'Journal's.
21 fold :: (Journal -> a -> a) -> Journal -> a -> a
22 fold f j@Journal{journal_includes} a =
23 Data.List.foldl' (flip (Hcompta.Format.Ledger.Journal.fold f))
24 (f j a)
25 journal_includes
26
27 -- | Return the given accumulator folded with the given function
28 -- over the given 'Journal' and its 'journal_includes' 'Journal's.
29 fold_map :: Monoid a => (Journal -> a -> a) -> Journal -> a -> a
30 fold_map f j@(Journal{journal_includes}) =
31 (f j) `mappend` Data.Foldable.foldMap (fold_map f) journal_includes
32
33 -- | Return the first non-'Nothing' value returned by the given function
34 -- when applied to the given 'Journal' or its 'journal_includes' 'Journal's,
35 -- with the parent 'Journal's.
36 find :: (Journal -> Maybe a) -> Journal -> Maybe (a, [Journal])
37 find f =
38 (\x -> case x of
39 Nothing -> Nothing
40 Just (a, path) -> Just (a, Data.List.reverse path))
41 . find_ []
42 where
43 find_ path j@Journal{journal_includes} =
44 case f j of
45 Just a -> Just (a, path)
46 Nothing ->
47 Data.Monoid.getFirst $
48 Data.Foldable.foldMap (Data.Monoid.First . (find_ (j:path))) $
49 journal_includes
50
51 -- | Return the given 'Journal' and its 'journal_includes' 'Journal's
52 -- mapped by the given function.
53 traverse :: (Journal -> Journal) -> Journal -> Journal
54 traverse f =
55 (\x -> case x of
56 j@Journal{journal_includes} ->
57 j{journal_includes = Data.List.map (traverse f) journal_includes})
58 . f
59
60 -- * Constructors
61
62 union :: Journal -> Journal -> Journal
63 union
64 Journal{ journal_transactions=t0 }
65 j@Journal{ journal_transactions=t1 } =
66 j{ journal_transactions = Data.Map.unionWith (++) t0 t1 }
67
68 unions :: Foldable t => t Journal -> Journal
69 unions = Data.Foldable.foldl' union Ledger.journal
70
71 -- | Return the 'Journal' with its 'journal_transactions'
72 -- recursively completed by the 'journal_transactions'
73 -- of its 'journal_includes', now empty.
74 flatten :: Journal -> Journal
75 flatten jnl =
76 Ledger.journal
77 { journal_transactions =
78 Data.Map.unionsWith (++) $
79 flat journal_transactions jnl
80 , journal_includes = []
81 }
82 where
83 flat :: (Journal -> a) -> Journal -> [a]
84 flat g j = g j:Data.List.concatMap (flat g) (journal_includes j)