]> Git — Sourcephile - comptalang.git/blob - lcc/Hcompta/LCC/Journal.hs
Remove cli/
[comptalang.git] / lcc / Hcompta / LCC / Journal.hs
1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
3 {-# LANGUAGE NamedFieldPuns #-}
4 {-# LANGUAGE RecordWildCards #-}
5 {-# LANGUAGE TypeFamilies #-}
6 {-# OPTIONS_GHC -fno-warn-orphans #-}
7 module Hcompta.LCC.Journal where
8
9 -- import Data.NonNull (NonNull)
10 -- import Data.Text (Text)
11 -- import qualified Data.NonNull as NonNull
12 -- import qualified Data.Text as Text
13 import Control.DeepSeq (NFData(..))
14 import Data.Data (Data(..))
15 import Data.Eq (Eq(..))
16 import Data.Foldable (Foldable(..))
17 import Data.Function (($), (.))
18 import Data.Functor (Functor(..), (<$>))
19 import Data.Functor.Compose (Compose(..))
20 import Data.Map.Strict (Map)
21 -- import Data.Monoid (Monoid(..))
22 import Data.Ord (Ord(..))
23 -- import Data.String (IsString(..))
24 import Data.Traversable (Traversable(..))
25 import Data.TreeMap.Strict (TreeMap)
26 import Data.Typeable (Typeable)
27 import Prelude (seq)
28 import Text.Show (Show(..))
29 import qualified Data.MonoTraversable as MT
30 -- import qualified System.FilePath.Posix as FP
31
32 {-
33 import Data.Tree
34 import Control.Monad (Monad(..), foldM)
35 import Data.List (reverse)
36 import Data.Maybe (Maybe(..))
37 import qualified Data.Monoid as Monoid
38 import Data.Semigroup (Semigroup(..))
39 -}
40
41 import qualified Hcompta as H
42 -- import Hcompta.LCC.Account
43 -- import Hcompta.LCC.Amount
44 -- import Hcompta.LCC.Chart
45 import Hcompta.LCC.IO
46 import Hcompta.LCC.Posting
47 -- import Hcompta.LCC.Transaction
48
49 -- * Type 'Journal'
50 data Journal j
51 = Journal
52 { journal_file :: !PathFile
53 , journal_last_read_time :: !Date
54 , journal_content :: !j
55 , journal_includes :: ![CanonFile]
56 } deriving (Data, Eq, Show, Typeable)
57
58 type instance MT.Element (Journal j) = j
59 instance Functor Journal where
60 fmap f j@Journal{journal_content{- DELME: , journal_includes-}} =
61 j{ journal_content = f journal_content
62 {- DELME: , journal_includes = fmap f <$> journal_includes-}
63 }
64 instance MT.MonoFunctor (Journal j)
65 instance Foldable Journal where
66 foldMap f Journal{journal_content{- DELME: , journal_includes-}} =
67 f journal_content {- DELME: `mappend`
68 (foldMap f `foldMap` journal_includes)-}
69 instance MT.MonoFoldable (Journal j)
70 instance Traversable Journal where
71 traverse f j = (\c -> j{journal_content=c}) <$> f (journal_content j)
72 instance NFData j => NFData (Journal j) where
73 rnf Journal{..} =
74 rnf journal_file `seq`
75 rnf journal_last_read_time `seq`
76 rnf journal_content `seq`
77 rnf journal_includes
78
79 journal :: j -> Journal j
80 journal j =
81 Journal
82 { journal_file = ""
83 , journal_last_read_time = H.epoch
84 , journal_content = j
85 , journal_includes = []
86 }
87
88 {-
89 instance Semigroup j => Semigroup (Journal j) where
90 (<>) = journal_union
91 instance (Monoid j, Semigroup j) => Monoid (Journal j) where
92 mempty = journal
93 mappend = journal_union
94
95 journal_union :: Semigroup j => Journal j -> Journal j -> Journal j
96 journal_union x y =
97 Journal
98 { journal_last_read_time = journal_last_read_time x `min` journal_last_read_time y
99 , journal_content = journal_content x <> journal_content y
100 , journal_includes = journal_includes x <> journal_includes y
101 }
102
103 journal_unions :: (Foldable f, Monoid j, Semigroup j) => f (Journal j) -> Journal j
104 journal_unions = foldl' (flip (<>)) journal
105 -}
106
107 {-
108 -- | Return the given accumulator folded over
109 -- the given 'Journal' and its 'journal_includes' 'Journal's.
110 journal_fold :: (Journal j -> a -> a) -> Journal j -> a -> a
111 journal_fold f j@Journal{journal_includes} a =
112 foldl'
113 (flip $ journal_fold f) (f j a)
114 journal_includes
115
116 -- | Return the given accumulator folded over
117 -- the given 'Journal' and its 'journal_includes' 'Journal's.
118 journal_foldM :: Monad m => (Journal j -> a -> m a) -> Journal j -> a -> m a
119 journal_foldM f j@Journal{journal_includes} a = do
120 ma <- f j a
121 foldM
122 (flip $ journal_foldM f) ma
123 journal_includes
124
125 -- | Return the given accumulator folded with the given function
126 -- over the given 'Journal' and its 'journal_includes' 'Journal's.
127 journal_foldMap :: Monoid a => (Journal j -> a -> a) -> Journal j -> a -> a
128 journal_foldMap f j@(Journal{journal_includes}) =
129 f j `mappend` foldMap (journal_foldMap f) journal_includes
130
131 -- | Return the first non-'Nothing' value returned by the given function
132 -- when applied to the given 'Journal' or its 'journal_includes' 'Journal's,
133 -- with the parent 'Journal's.
134 journal_find :: (Journal j -> Maybe a) -> Journal j -> Maybe (a, [Journal j])
135 journal_find f =
136 (\x -> case x of
137 Nothing -> Nothing
138 Just (a, path) -> Just (a, reverse path))
139 . find_ []
140 where
141 find_ path j =
142 case f j of
143 Just a -> Just (a, path)
144 Nothing ->
145 Monoid.getFirst $
146 foldMap (Monoid.First . (find_ (j:path))) $
147 journal_includes j
148
149 -- | Return the given 'Journal' and its 'journal_includes' 'Journal's
150 -- mapped by the given function.
151 journal_traverse :: (Journal j -> Journal j) -> Journal j -> Journal j
152 journal_traverse f =
153 (\x -> case x of
154 j@Journal{journal_includes} ->
155 j{journal_includes = journal_traverse f <$> journal_includes})
156 . f
157
158 -- | Return the 'Journal' recursively 'mappend'-ed
159 -- with its 'journal_includes', now empty.
160 journal_flatten :: (Monoid j, Semigroup j) => Journal j -> Journal j
161 journal_flatten jnl =
162 (mconcat $ (:) jnl $ journal_flatten <$>
163 journal_includes jnl) { journal_includes = [] }
164 -}
165
166 -- * Type 'Journals'
167 newtype Journals j = Journals (Map CanonFile (Journal j))
168 deriving (Data, Eq, Show, Typeable)
169 type instance MT.Element (Journals j) = Journal j
170
171 instance MT.MonoFunctor (Journals j) where
172 omap f (Journals m) = Journals $ f `MT.omap` m
173 instance MT.MonoFoldable (Journals j) where
174 ofoldMap f (Journals m) = MT.ofoldMap f m
175 ofoldr f a (Journals m) = MT.ofoldr f a m
176 ofoldl' f a (Journals m) = MT.ofoldl' f a m
177 ofoldr1Ex f (Journals m) = MT.ofoldr1Ex f m
178 ofoldl1Ex' f (Journals m) = MT.ofoldl1Ex' f m
179 instance MT.MonoTraversable (Journals j) where
180 otraverse f (Journals m) = Journals <$> MT.otraverse f m
181
182 instance Functor Journals where
183 fmap f (Journals m) = Journals $ fmap f <$> m
184 instance Foldable Journals where
185 foldMap f (Journals m) = f `foldMap` Compose m
186 instance Traversable Journals where
187 traverse f (Journals m) =
188 Journals . getCompose <$> (f `traverse` Compose m)
189
190
191
192
193 {-
194 -- ** Type 'JournalFile'
195 newtype JournalFile = JournalFile PathFile
196 deriving (Data, Eq, NFData, Ord, Show, Typeable)
197 unJournalFile :: JournalFile -> PathFile
198 unJournalFile (JournalFile fp) = fp
199
200 -- ** Type 'JournalFileCanon'
201 newtype JournalFileCanon = JournalFileCanon JournalFile
202 deriving (Data, Eq, NFData, Ord, Show, Typeable)
203 unJournalFileCanon :: JournalFileCanon -> JournalFile
204 unJournalFileCanon (JournalFileCanon jf) = jf
205
206 journalFileCanon :: JournalFile -> IO JournalFileCanon
207 journalFileCanon (JournalFile (PathFile fp)) =
208 JournalFileCanon . JournalFile . fromString
209 <$> IO.canonicalizePath fp
210
211 newtype Journals j = Journals (Forest (Journal j))
212 deriving (Data, Eq, Show, Typeable)
213 type instance MT.Element (Journals j) = Journal j
214 instance MT.MonoFunctor (Journals j) where
215 omap f (Journals m) = Journals $ f `MT.omap` m
216 instance MT.MonoFoldable (Journals j) where
217 ofoldMap f (Journals m) = MT.ofoldMap f m
218 ofoldr f a (Journals m) = MT.ofoldr f a m
219 ofoldl' f a (Journals m) = MT.ofoldl' f a m
220 ofoldr1Ex f (Journals m) = MT.ofoldr1Ex f m
221 ofoldl1Ex' f (Journals m) = MT.ofoldl1Ex' f m
222 instance MT.MonoTraversable (Journals j) where
223 otraverse f (Journals m) = Journals <$> MT.otraverse f m
224
225
226 instance Functor Journals where
227 fmap f (Journals m) = Journals $
228 getCompose $ getCompose . fmap f $ Compose (Compose m)
229 instance Foldable Journals where
230 foldMap f (Journals m) = foldMap f $ Compose (Compose m)
231 instance Traversable Journals where
232 traverse f (Journals m) =
233 Journals . getCompose . getCompose
234 <$> traverse f (Compose (Compose m))
235
236 instance Functor Journals where
237 fmap f (Journals m) = Journals $ fmap f <$> m
238 instance Foldable Journals where
239 foldMap f (Journals m) = f `foldMap` Compose m
240 instance Traversable Journals where
241 traverse f (Journals m) =
242 Journals . getCompose <$> (f `traverse` Compose m)
243
244 journals_flatten :: Journals j -> Journal j
245 journals_flatten js@(Journals m)
246 Map.fold
247 MT.ofoldr1Ex (\j) js
248 -- | Return the 'Journal' recursively 'mappend'-ed
249 -- with its 'journal_includes', now empty.
250 journal_flatten :: (Monoid j, Semigroup j) => Journal j -> Journal j
251 journal_flatten jnl =
252 (mconcat $ (:) jnl $ journal_flatten <$>
253 journal_includes jnl) { journal_includes = [] }
254 -}
255
256 type instance MT.Element (TreeMap k a) = a
257 instance Ord k => MT.MonoFunctor (TreeMap k a)
258 instance Ord k => MT.MonoFoldable (TreeMap k a)
259 instance Ord k => MT.MonoTraversable (TreeMap k a)