jcc/Hcompta/Format/JCC/Journal.hs

   1 {-# LANGUAGE NamedFieldPuns #-}
   2 module Hcompta.Format.JCC.Journal where
   3
   4 import qualified Control.Monad
   5 import           Control.Monad (Monad(..))
   6 import           Data.Foldable hiding (fold)
   7 import           Data.Functor (Functor(..))
   8 import           Data.List (reverse, foldl')
   9 import           Data.Maybe (Maybe(..))
  10 import           Data.Monoid (Monoid(..))
  11 import qualified Data.Monoid (getFirst, First(..))
  12 import           Data.Typeable ()
  13 import           Prelude (($), (.), flip)
  14
  15 import           Hcompta.Format.JCC (Journal(..))
  16 import qualified Hcompta.Format.JCC as JCC
  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 :: (Journal j -> a -> a) -> Journal j -> 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 => (Journal j -> a -> m a) -> Journal j -> 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 => (Journal j -> a -> a) -> Journal j -> 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 :: (Journal j -> Maybe a) -> Journal j -> Maybe (a, [Journal j])
  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 :: (Journal j -> Journal j) -> Journal j -> Journal j
  65 traverse f =
  66         (\x -> case x of
  67          j@Journal{journal_includes} ->
  68                 j{journal_includes = fmap (traverse f) journal_includes})
  69         . f
  70
  71 -- * Constructors
  72
  73 unions :: (Foldable f, Monoid j) => f (Journal j) -> Journal j
  74 unions = foldl' (flip mappend) JCC.journal
  75
  76 -- | Return the 'Journal' recursively 'mappend'-ed
  77 --   with its 'journal_includes', now empty.
  78 flatten :: Monoid j => Journal j -> Journal j
  79 flatten jnl =
  80         (mconcat $ (:) jnl $ fmap flatten $ journal_includes jnl)
  81          { journal_includes = []
  82          }