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