lib/Hcompta/Format/Ledger/Journal.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE NamedFieldPuns #-}
   3 module Hcompta.Format.Ledger.Journal where
   4
   5 -- import           Control.Applicative ((<$>))
   6 import qualified Control.Monad
   7 import           Data.Foldable hiding (fold)
   8 import qualified Data.List
   9 import qualified Data.Monoid (getFirst, First(..))
  10 -- import           Data.Monoid (Monoid, mappend)
  11 import qualified Data.Map.Strict as Data.Map
  12 import           Prelude hiding (traverse)
  13 import           Data.Typeable ()
  14
  15 import qualified Hcompta.Amount.Style as Amount.Style
  16 import           Hcompta.Format.Ledger (Journal(..))
  17 import qualified Hcompta.Format.Ledger as Ledger
  18 import           Hcompta.Lib.Consable (Consable(..))
  19
  20 -- * Extractors
  21
  22 -- | Return the given accumulator folded over
  23 --   the given 'Journal' and its 'journal_includes' 'Journal's.
  24 fold :: Consable ts t => (Journal ts t -> a -> a) -> Journal ts t -> a -> a
  25 fold f j@Journal{journal_includes} a =
  26         Data.List.foldl'
  27          (flip (fold f)) (f j a)
  28          journal_includes
  29
  30 -- | Return the given accumulator folded over
  31 --   the given 'Journal' and its 'journal_includes' 'Journal's.
  32 foldM :: (Monad m, Consable ts t) => (Journal ts t -> a -> m a) -> Journal ts t -> a -> m a
  33 foldM f j@Journal{journal_includes} a = do
  34         ma <- f j a
  35         Control.Monad.foldM
  36          (flip (foldM f)) ma
  37          journal_includes
  38
  39 -- | Return the given accumulator folded with the given function
  40 --   over the given 'Journal' and its 'journal_includes' 'Journal's.
  41 fold_map :: (Monoid a, Consable ts t) => (Journal ts t -> a -> a) -> Journal ts t -> a -> a
  42 fold_map f j@(Journal{journal_includes}) =
  43         (f j) `mappend` foldMap (fold_map f) journal_includes
  44
  45 -- | Return the first non-'Nothing' value returned by the given function
  46 --   when applied to the given 'Journal' or its 'journal_includes' 'Journal's,
  47 --   with the parent 'Journal's.
  48 find :: Consable ts t => (Journal ts t -> Maybe a) -> Journal ts t -> Maybe (a, [Journal ts t])
  49 find f =
  50         (\x -> case x of
  51          Nothing -> Nothing
  52          Just (a, path) -> Just (a, reverse path))
  53         . find_ []
  54         where
  55                 find_ path j@Journal{journal_includes} =
  56                         case f j of
  57                          Just a -> Just (a, path)
  58                          Nothing ->
  59                                 Data.Monoid.getFirst $
  60                                 foldMap (Data.Monoid.First . (find_ (j:path))) $
  61                                 journal_includes
  62
  63 -- | Return the given 'Journal' and its 'journal_includes' 'Journal's
  64 --   mapped by the given function.
  65 traverse :: Consable ts t => (Journal ts t -> Journal ts t) -> Journal ts t -> Journal ts t
  66 traverse f =
  67         (\x -> case x of
  68          j@Journal{journal_includes} ->
  69                 j{journal_includes = Data.List.map (traverse f) journal_includes})
  70         . f
  71
  72 -- * Constructors
  73
  74 union :: Consable ts t => Journal ts t -> Journal ts t -> Journal ts t
  75 union j0 j1 =
  76         j1{ journal_transactions = mappend (journal_transactions j0) (journal_transactions j1)
  77          ,  journal_unit_styles  = Data.Map.unionWith Amount.Style.union (journal_unit_styles j0) (journal_unit_styles j1)
  78          ,  journal_last_read_time = min (journal_last_read_time j0) (journal_last_read_time j1)
  79          }
  80
  81 unions :: (Foldable f, Consable ts t) => f (Journal ts t) -> Journal ts t
  82 unions = Data.Foldable.foldl' (flip union) Ledger.journal
  83
  84 -- | Return the 'Journal' with its 'journal_transactions'
  85 --   recursively completed by the 'journal_transactions'
  86 --   of its 'journal_includes', now empty.
  87 flatten :: Consable ts t => Journal ts t -> Journal ts t
  88 flatten jnl =
  89         jnl
  90          { journal_includes = []
  91          , journal_transactions = flat journal_transactions jnl
  92          }
  93         where
  94                 flat :: Consable ts t => (Journal ts t -> ts t) -> Journal ts t -> ts t
  95                 flat g j = mconcat $ g j : Data.List.map (flat g) (journal_includes j)