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