Polissage : CLI.Command.Balance : is_worth.
[comptalang.git] / lib / Hcompta / Format / Ledger / Journal.hs
index 6165c93bb7627e0a86c49fec186f9a803a549d9d..26a4c1dfffc220ae1c84129ea0fc6bb1958885d4 100644 (file)
@@ -1,95 +1,94 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 module Hcompta.Format.Ledger.Journal where
 
 -- import           Control.Applicative ((<$>))
-import           Data.Data
-import qualified Data.Foldable (foldMap)
+import qualified Control.Monad
+import           Data.Foldable hiding (fold)
 import qualified Data.List
-import qualified Data.Map.Strict as Data.Map
-import           Data.Map.Strict (Map)
 import qualified Data.Monoid (getFirst, First(..))
-import           Data.Monoid (Monoid, mappend)
-import qualified Data.Time.Clock       as Time
-import qualified Data.Time.Clock.POSIX as Time
+-- import           Data.Monoid (Monoid, mappend)
+import qualified Data.Map.Strict as Data.Map
+import           Prelude hiding (traverse)
 import           Data.Typeable ()
 
-import qualified Hcompta.Model as Model
-import qualified Hcompta.Model.Amount as Amount
-import qualified Hcompta.Model.Journal as Model.Journal
-import qualified Hcompta.Model.Transaction as Transaction
+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(..))
 
-data Journal
- =   Journal
- { file :: FilePath
- , includes :: [Journal]
- -- , historical_prices :: [Amount.Price.Historical]
- , last_read_time :: Time.UTCTime
- , transactions :: Transaction.By_Date
- -- , transaction_periodics :: [Transaction.Periodic]
- -- , transaction_modifiers :: [Transaction.Modifier]
- , unit_styles :: Map Amount.Unit Amount.Style
- } deriving (Data, Eq, Read, Show, Typeable)
+-- * Extractors
 
-nil :: Journal
-nil =
-       Journal
-        { file = ""
-        , includes = []
-        , last_read_time = Time.posixSecondsToUTCTime 0
-        , transactions = Data.Map.empty
-        , unit_styles = Data.Map.empty
-        }
+-- | Return the given accumulator folded over
+--   the given 'Journal' and its 'journal_includes' 'Journal's.
+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)
+        journal_includes
 
 -- | Return the given accumulator folded over
---   the given 'Journal' and its 'includes' 'Journal's.
-fold :: (Journal -> a -> a) -> Journal -> a -> a
-fold f j@Journal{includes} a =
-       Data.List.foldl (flip (Hcompta.Format.Ledger.Journal.fold f))
-        (f j a)
-        includes
+--   the given 'Journal' and its 'journal_includes' 'Journal's.
+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
+        (flip (foldM f)) ma
+        journal_includes
+
+-- | Return the given accumulator folded with the given function
+--   over the given 'Journal' and its 'journal_includes' 'Journal's.
+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 'includes' 'Journal's,
+--   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 =
-       (\case
+       (\x -> case x of
         Nothing -> Nothing
-        Just (a, path) -> Just (a, Data.List.reverse path))
+        Just (a, path) -> Just (a, reverse path))
        . find_ []
        where
-               find_ path j@Journal{includes} =
+               find_ path j@Journal{journal_includes} =
                        case f j of
                         Just a -> Just (a, path)
                         Nothing ->
                                Data.Monoid.getFirst $
-                               Data.Foldable.foldMap (Data.Monoid.First . (find_ (j:path))) $
-                               includes
+                               foldMap (Data.Monoid.First . (find_ (j:path))) $
+                               journal_includes
 
--- | Return the given 'Journal' and its 'includes' 'Journal's
+-- | 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 =
-       (\case j@Journal{includes} ->
-               j{includes=Data.List.map (traverse f) includes})
+       (\x -> case x of
+        j@Journal{journal_includes} ->
+               j{journal_includes = Data.List.map (traverse f) journal_includes})
        . f
 
--- | Return the given accumulator folded with the given function
---   over the given 'Journal' and its 'includes' 'Journal's.
-fold_map :: Monoid a => (Journal -> a -> a) -> Journal -> a -> a
-fold_map f j@(Journal{includes}) =
-       (f j) `mappend` Data.Foldable.foldMap (fold_map f) includes
+-- * Constructors
+
+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 f, Monoid (ts t)) => f (Journal (ts t)) -> Journal (ts t)
+unions = Data.Foldable.foldl' (flip union) Ledger.journal
 
--- | Return the Model.'Model.Journal' derived from the given 'Journal'.
-to_Model :: Journal -> Model.Journal
-to_Model jour =
-       Model.Journal.Journal
-        { Model.Journal.transactions =
-               Data.Map.unionsWith (++) $
-               flatten transactions $ jour
+-- | Return the 'Journal' with its 'journal_transactions'
+--   recursively completed by the 'journal_transactions'
+--   of its 'journal_includes', now empty.
+flatten :: Monoid (ts t) => Journal (ts t) -> Journal (ts t)
+flatten jnl =
+       jnl
+        { journal_includes = []
+        , journal_transactions = flat journal_transactions jnl
         }
        where
-               flatten :: (Journal -> a) -> Journal -> [a]
-               flatten g j = g j:Data.List.concatMap (flatten g) (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)