lib/Hcompta/Format/Ledger/Journal.hs

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