]> Git — Sourcephile - comptalang.git/blob - ledger/Hcompta/Ledger/Journal.hs
Remove cli/
[comptalang.git] / ledger / Hcompta / Ledger / Journal.hs
1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE NamedFieldPuns #-}
3 module Hcompta.Ledger.Journal where
4
5 import Control.DeepSeq (NFData(..))
6 import Control.Monad (Monad(..), foldM)
7 import Data.Data (Data(..))
8 import Data.Eq (Eq(..))
9 import Data.Foldable (Foldable(..))
10 import Data.Function (($), (.), flip)
11 import Data.Functor (Functor(..), (<$>))
12 import Data.List (reverse)
13 import Data.Maybe (Maybe(..))
14 import Data.Monoid (Monoid(..))
15 import qualified Data.Monoid (getFirst, First(..))
16 import Data.Typeable (Typeable)
17 import Text.Show (Show(..))
18 import Prelude (seq, min)
19 import System.IO (FilePath)
20
21 import qualified Hcompta as H
22 import Hcompta.Ledger.Amount
23 import Hcompta.Ledger.Chart
24
25 -- * Type 'Journal'
26
27 data Journal j
28 = Journal
29 { journal_amount_styles :: !Amount_Styles
30 , journal_chart :: Chart
31 , journal_content :: !j
32 , journal_files :: [FilePath]
33 , journal_includes :: [Journal j]
34 , journal_last_read_time :: H.Date
35 } deriving (Data, Eq, Show, Typeable)
36
37 instance Functor Journal where
38 fmap f j@Journal{journal_includes, journal_content} =
39 j{ journal_content = f journal_content
40 , journal_includes = fmap (fmap f) journal_includes
41 }
42
43 journal :: Monoid j => Journal j
44 journal =
45 Journal
46 { journal_amount_styles = mempty
47 , journal_chart = mempty
48 , journal_content = mempty
49 , journal_files = mempty
50 , journal_includes = mempty
51 , journal_last_read_time = H.date_epoch
52 }
53
54 instance Monoid j => Monoid (Journal j) where
55 mempty = journal
56 mappend x y =
57 Journal
58 { journal_amount_styles = journal_amount_styles x `mappend` journal_amount_styles y
59 , journal_chart = journal_chart x `mappend` journal_chart y
60 , journal_content = journal_content x `mappend` journal_content y
61 , journal_files = journal_files x `mappend` journal_files y
62 , journal_includes = journal_includes x `mappend` journal_includes y
63 , journal_last_read_time = journal_last_read_time x `min` journal_last_read_time y
64 }
65 instance NFData j => NFData (Journal j) where
66 rnf
67 Journal
68 { journal_amount_styles
69 , journal_chart
70 , journal_content
71 , journal_files
72 , journal_includes
73 , journal_last_read_time
74 } =
75 rnf journal_amount_styles `seq`
76 rnf journal_chart `seq`
77 rnf journal_content `seq`
78 rnf journal_files `seq`
79 rnf journal_includes `seq`
80 rnf journal_last_read_time
81
82 -- * Extractors
83
84 -- | Return the given accumulator folded over
85 -- the given 'Journal' and its 'journal_includes' 'Journal's.
86 journal_fold :: (Journal j -> a -> a) -> Journal j -> a -> a
87 journal_fold f j@Journal{journal_includes} a =
88 foldl'
89 (flip (journal_fold f)) (f j a)
90 journal_includes
91
92 -- | Return the given accumulator folded over
93 -- the given 'Journal' and its 'journal_includes' 'Journal's.
94 journal_foldM :: Monad m => (Journal j -> a -> m a) -> Journal j -> a -> m a
95 journal_foldM f j@Journal{journal_includes} a = do
96 ma <- f j a
97 foldM
98 (flip (journal_foldM f)) ma
99 journal_includes
100
101 -- | Return the given accumulator folded with the given function
102 -- over the given 'Journal' and its 'journal_includes' 'Journal's.
103 journal_fold_map :: Monoid a => (Journal j -> a -> a) -> Journal j -> a -> a
104 journal_fold_map f j@(Journal{journal_includes}) =
105 (f j) `mappend` foldMap (journal_fold_map f) journal_includes
106
107 -- | Return the first non-'Nothing' value returned by the given function
108 -- when applied to the given 'Journal' or its 'journal_includes' 'Journal's,
109 -- with the parent 'Journal's.
110 journal_find :: (Journal j -> Maybe a) -> Journal j -> Maybe (a, [Journal j])
111 journal_find f =
112 (\x -> case x of
113 Nothing -> Nothing
114 Just (a, path) -> Just (a, reverse path))
115 . find_ []
116 where
117 find_ path j@Journal{journal_includes} =
118 case f j of
119 Just a -> Just (a, path)
120 Nothing ->
121 Data.Monoid.getFirst $
122 foldMap (Data.Monoid.First . (find_ (j:path))) $
123 journal_includes
124
125 -- | Return the given 'Journal' and its 'journal_includes' 'Journal's
126 -- mapped by the given function.
127 journal_traverse :: (Journal j -> Journal j) -> Journal j -> Journal j
128 journal_traverse f =
129 (\x -> case x of
130 j@Journal{journal_includes} ->
131 j{journal_includes = fmap (journal_traverse f) journal_includes})
132 . f
133
134 -- * Constructors
135
136 journal_unions :: (Foldable f, Monoid j) => f (Journal j) -> Journal j
137 journal_unions = foldl' (flip mappend) journal
138
139 -- | Return the 'Journal' recursively 'mappend'-ed
140 -- with its 'journal_includes', now empty.
141 journal_flatten :: Monoid j => Journal j -> Journal j
142 journal_flatten jnl =
143 (mconcat $ (:) jnl $ journal_flatten <$>
144 journal_includes jnl) { journal_includes = [] }