-{-# 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)