Polissage : CLI.Command.Balance : is_worth.
[comptalang.git] / lib / Hcompta / Format / Ledger / Journal.hs
index 3d3b24110a6ab6b63e270301cbe083fcad4165ad..26a4c1dfffc220ae1c84129ea0fc6bb1958885d4 100644 (file)
@@ -1,4 +1,3 @@
-{-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE NamedFieldPuns #-}
 module Hcompta.Format.Ledger.Journal where
 
@@ -6,20 +5,22 @@ module Hcompta.Format.Ledger.Journal where
 import qualified Control.Monad
 import           Data.Foldable hiding (fold)
 import qualified Data.List
-import qualified Data.Map.Strict as Data.Map
 import qualified Data.Monoid (getFirst, First(..))
 -- import           Data.Monoid (Monoid, mappend)
+import qualified Data.Map.Strict as Data.Map
 import           Prelude hiding (traverse)
 import           Data.Typeable ()
 
-import qualified Hcompta.Format.Ledger as Ledger
+import qualified Hcompta.Amount.Style as Amount.Style
 import           Hcompta.Format.Ledger (Journal(..))
+import qualified Hcompta.Format.Ledger as Ledger
+-- import           Hcompta.Lib.Consable (Consable(..))
 
 -- * Extractors
 
 -- | Return the given accumulator folded over
 --   the given 'Journal' and its 'journal_includes' 'Journal's.
-fold :: (Journal -> a -> a) -> Journal -> a -> a
+fold :: Monoid (ts t) => (Journal (ts t) -> a -> a) -> Journal (ts t) -> a -> a
 fold f j@Journal{journal_includes} a =
        Data.List.foldl'
         (flip (fold f)) (f j a)
@@ -27,7 +28,7 @@ fold f j@Journal{journal_includes} a =
 
 -- | Return the given accumulator folded over
 --   the given 'Journal' and its 'journal_includes' 'Journal's.
-foldM :: Monad m => (Journal -> a -> m a) -> Journal -> a -> m a
+foldM :: (Monad m, Monoid (ts t)) => (Journal (ts t) -> a -> m a) -> Journal (ts t) -> a -> m a
 foldM f j@Journal{journal_includes} a = do
        ma <- f j a
        Control.Monad.foldM
@@ -36,14 +37,14 @@ foldM f j@Journal{journal_includes} a = do
 
 -- | Return the given accumulator folded with the given function
 --   over the given 'Journal' and its 'journal_includes' 'Journal's.
-fold_map :: Monoid a => (Journal -> a -> a) -> Journal -> a -> a
+fold_map :: (Monoid a, Monoid (ts t)) => (Journal (ts t) -> a -> a) -> Journal (ts t) -> a -> a
 fold_map f j@(Journal{journal_includes}) =
        (f j) `mappend` foldMap (fold_map f) journal_includes
 
 -- | Return the first non-'Nothing' value returned by the given function
 --   when applied to the given 'Journal' or its 'journal_includes' 'Journal's,
 --   with the parent 'Journal's.
-find :: (Journal -> Maybe a) -> Journal -> Maybe (a, [Journal])
+find :: Monoid (ts t) => (Journal (ts t) -> Maybe a) -> Journal (ts t) -> Maybe (a, [Journal (ts t)])
 find f =
        (\x -> case x of
         Nothing -> Nothing
@@ -60,7 +61,7 @@ find f =
 
 -- | Return the given 'Journal' and its 'journal_includes' 'Journal's
 --   mapped by the given function.
-traverse :: (Journal -> Journal) -> Journal -> Journal
+traverse :: Monoid (ts t) => (Journal (ts t) -> Journal (ts t)) -> Journal (ts t) -> Journal (ts t)
 traverse f =
        (\x -> case x of
         j@Journal{journal_includes} ->
@@ -69,26 +70,25 @@ traverse f =
 
 -- * Constructors
 
-union :: Journal -> Journal -> Journal
-union
- Journal{ journal_transactions=t0 }
- j@Journal{ journal_transactions=t1 } =
-       j{ journal_transactions = Data.Map.unionWith (++) t0 t1 }
+union :: Monoid (ts t) => Journal (ts t) -> Journal (ts t) -> Journal (ts t)
+union j0 j1 =
+       j1{ journal_transactions = mappend (journal_transactions j0) (journal_transactions j1)
+        ,  journal_unit_styles  = Data.Map.unionWith Amount.Style.union (journal_unit_styles j0) (journal_unit_styles j1)
+        ,  journal_last_read_time = min (journal_last_read_time j0) (journal_last_read_time j1)
+        }
 
-unions :: Foldable t => t Journal -> Journal
-unions = Data.Foldable.foldl' union Ledger.journal
+unions :: (Foldable f, Monoid (ts t)) => f (Journal (ts t)) -> Journal (ts t)
+unions = Data.Foldable.foldl' (flip union) Ledger.journal
 
 -- | Return the 'Journal' with its 'journal_transactions'
 --   recursively completed by the 'journal_transactions'
 --   of its 'journal_includes', now empty.
-flatten :: Journal -> Journal
+flatten :: Monoid (ts t) => Journal (ts t) -> Journal (ts t)
 flatten jnl =
-       Ledger.journal
-        { journal_transactions =
-               Data.Map.unionsWith (++) $
-               flat journal_transactions jnl
-        , journal_includes = []
+       jnl
+        { journal_includes = []
+        , journal_transactions = flat journal_transactions jnl
         }
        where
-               flat :: (Journal -> a) -> Journal -> [a]
-               flat g j = g j:Data.List.concatMap (flat g) (journal_includes j)
+               flat :: Monoid (ts t) => (Journal (ts t) -> ts t) -> Journal (ts t) -> (ts t)
+               flat g j = mconcat $ g j : Data.List.map (flat g) (journal_includes j)