ledger/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           Data.Maybe (Maybe(..))
   9 import           Data.Monoid (Monoid(..))
  10 import qualified Data.Monoid (getFirst, First(..))
  11 import           Data.Ord (Ord(..))
  12 import           Data.Typeable ()
  13 import           Prelude (($), (.), flip)
  14
  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_sections       = journal_sections j0 `mappend` journal_sections j1
  76          ,  journal_amount_styles  = mappend (journal_amount_styles j0) (journal_amount_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_sections'
  84 --   recursively completed by the 'journal_sections'
  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_sections = flat journal_sections 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)