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