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
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)
30 import Text.Show (Show(..))
31 import qualified Data.MonoTraversable as MT
32 import qualified System.FilePath.Posix as FP
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(..))
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
51 newtype PathFile = PathFile FP.FilePath
52 deriving (Data, Eq, NFData, Ord, Show, Typeable)
53 instance IsString PathFile where
57 newtype CanonFile = CanonFile PathFile
58 deriving (Data, Eq, NFData, Ord, Show, Typeable)
63 { journal_file :: !PathFile
64 , journal_last_read_time :: !Date
65 , journal_content :: !j
66 , journal_includes :: ![CanonFile]
67 } deriving (Data, Eq, Show, Typeable)
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-}
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
85 rnf journal_file `seq`
86 rnf journal_last_read_time `seq`
87 rnf journal_content `seq`
90 journal :: Monoid j => Journal j
94 , journal_last_read_time = H.date_epoch
95 , journal_content = mempty
96 , journal_includes = []
100 instance Semigroup j => Semigroup (Journal j) where
102 instance (Monoid j, Semigroup j) => Monoid (Journal j) where
104 mappend = journal_union
106 journal_union :: Semigroup j => Journal j -> Journal j -> Journal j
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
114 journal_unions :: (Foldable f, Monoid j, Semigroup j) => f (Journal j) -> Journal j
115 journal_unions = foldl' (flip (<>)) journal
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 =
124 (flip $ journal_fold f) (f j a)
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
133 (flip $ journal_foldM f) ma
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
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])
149 Just (a, path) -> Just (a, reverse path))
154 Just a -> Just (a, path)
157 foldMap (Monoid.First . (find_ (j:path))) $
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
165 j@Journal{journal_includes} ->
166 j{journal_includes = journal_traverse f <$> journal_includes})
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 = [] }
178 newtype Journals j = Journals (Map CanonFile (Journal j))
179 deriving (Data, Eq, Show, Typeable)
180 type instance MT.Element (Journals j) = Journal j
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
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)
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
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
217 journalFileCanon :: JournalFile -> IO JournalFileCanon
218 journalFileCanon (JournalFile (PathFile fp)) =
219 JournalFileCanon . JournalFile . fromString
220 <$> IO.canonicalizePath fp
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
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))
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)
255 journals_flatten :: Journals j -> Journal j
256 journals_flatten js@(Journals m)
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 = [] }
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)