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