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