lib/Hcompta/Format/Ledger/Journal.hs

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