{-# 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 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.Format.Ledger as Ledger
+import Hcompta.Format.Ledger (Journal(..))
-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)
-
-nil :: Journal
-nil =
- Journal
- { file = ""
- , includes = []
- , last_read_time = Time.posixSecondsToUTCTime 0
- , transactions = Data.Map.empty
- , unit_styles = Data.Map.empty
- }
+-- * Extractors
-- | Return the given accumulator folded over
--- the given 'Journal' and its 'includes' 'Journal's.
+-- the given 'Journal' and its 'journal_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
+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 'journal_includes' 'Journal's.
+foldM :: Monad m => (Journal -> a -> m a) -> Journal -> 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 => (Journal -> a -> a) -> Journal -> 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 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 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 :: Journal -> Journal -> Journal
+union
+ Journal{ journal_transactions=t0 }
+ j@Journal{ journal_transactions=t1 } =
+ j{ journal_transactions = Data.Map.unionWith (++) t0 t1 }
+
+unions :: Foldable t => t Journal -> Journal
+unions = Data.Foldable.foldl' 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 =
+-- | Return the 'Journal' with its 'journal_transactions'
+-- recursively completed by the 'journal_transactions'
+-- of its 'journal_includes', now empty.
+flatten :: Journal -> Journal
+flatten jnl =
+ Ledger.journal
+ { journal_transactions =
Data.Map.unionsWith (++) $
- flatten transactions $ jour
+ flat journal_transactions jnl
+ , journal_includes = []
}
where
- flatten :: (Journal -> a) -> Journal -> [a]
- flatten g j = g j:Data.List.concatMap (flatten g) (includes j)
+ flat :: (Journal -> a) -> Journal -> [a]
+ flat g j = g j:Data.List.concatMap (flat g) (journal_includes j)
sourcephile / git / comptalang.git / blobdiff