ledger/Hcompta/Ledger/Journal.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE NamedFieldPuns #-}
   3 module Hcompta.Ledger.Journal where
   4
   5 import           Control.DeepSeq (NFData(..))
   6 import           Control.Monad (Monad(..), foldM)
   7 import           Data.Data (Data(..))
   8 import           Data.Eq (Eq(..))
   9 import           Data.Foldable (Foldable(..))
  10 import           Data.Function (($), (.), flip)
  11 import           Data.Functor (Functor(..), (<$>))
  12 import           Data.List (reverse)
  13 import           Data.Maybe (Maybe(..))
  14 import           Data.Monoid (Monoid(..))
  15 import qualified Data.Monoid (getFirst, First(..))
  16 import           Data.Typeable (Typeable)
  17 import           Text.Show (Show(..))
  18 import           Prelude (seq, min)
  19 import           System.IO (FilePath)
  20
  21 import qualified Hcompta as H
  22 import           Hcompta.Ledger.Amount
  23 import           Hcompta.Ledger.Chart
  24
  25 -- * Type 'Journal'
  26
  27 data Journal j
  28  =   Journal
  29  {   journal_amount_styles  :: !Amount_Styles
  30  ,   journal_chart          :: Chart
  31  ,   journal_content        :: !j
  32  ,   journal_files          :: [FilePath]
  33  ,   journal_includes       :: [Journal j]
  34  ,   journal_last_read_time :: H.Date
  35  } deriving (Data, Eq, Show, Typeable)
  36
  37 instance Functor Journal where
  38         fmap f j@Journal{journal_includes, journal_content} =
  39                 j{ journal_content  = f journal_content
  40                  , journal_includes = fmap (fmap f) journal_includes
  41                  }
  42
  43 journal :: Monoid j => Journal j
  44 journal =
  45         Journal
  46          { journal_amount_styles  = mempty
  47          , journal_chart          = mempty
  48          , journal_content        = mempty
  49          , journal_files          = mempty
  50          , journal_includes       = mempty
  51          , journal_last_read_time = H.date_epoch
  52          }
  53
  54 instance Monoid j => Monoid (Journal j) where
  55         mempty = journal
  56         mappend x y =
  57                 Journal
  58                  { journal_amount_styles  = journal_amount_styles  x `mappend` journal_amount_styles  y
  59                  , journal_chart          = journal_chart          x `mappend` journal_chart          y
  60                  , journal_content        = journal_content        x `mappend` journal_content        y
  61                  , journal_files          = journal_files          x `mappend` journal_files          y
  62                  , journal_includes       = journal_includes       x `mappend` journal_includes       y
  63                  , journal_last_read_time = journal_last_read_time x `min`     journal_last_read_time y
  64                  }
  65 instance NFData j => NFData (Journal j) where
  66         rnf
  67          Journal
  68          { journal_amount_styles
  69          , journal_chart
  70          , journal_content
  71          , journal_files
  72          , journal_includes
  73          , journal_last_read_time
  74          } =
  75                 rnf journal_amount_styles `seq`
  76                 rnf journal_chart `seq`
  77                 rnf journal_content `seq`
  78                 rnf journal_files `seq`
  79                 rnf journal_includes `seq`
  80                 rnf journal_last_read_time
  81
  82 -- * Extractors
  83
  84 -- | Return the given accumulator folded over
  85 --   the given 'Journal' and its 'journal_includes' 'Journal's.
  86 journal_fold :: (Journal j -> a -> a) -> Journal j -> a -> a
  87 journal_fold f j@Journal{journal_includes} a =
  88         foldl'
  89          (flip (journal_fold f)) (f j a)
  90          journal_includes
  91
  92 -- | Return the given accumulator folded over
  93 --   the given 'Journal' and its 'journal_includes' 'Journal's.
  94 journal_foldM :: Monad m => (Journal j -> a -> m a) -> Journal j -> a -> m a
  95 journal_foldM f j@Journal{journal_includes} a = do
  96         ma <- f j a
  97         foldM
  98          (flip (journal_foldM f)) ma
  99          journal_includes
 100
 101 -- | Return the given accumulator folded with the given function
 102 --   over the given 'Journal' and its 'journal_includes' 'Journal's.
 103 journal_fold_map :: Monoid a => (Journal j -> a -> a) -> Journal j -> a -> a
 104 journal_fold_map f j@(Journal{journal_includes}) =
 105         (f j) `mappend` foldMap (journal_fold_map f) journal_includes
 106
 107 -- | Return the first non-'Nothing' value returned by the given function
 108 --   when applied to the given 'Journal' or its 'journal_includes' 'Journal's,
 109 --   with the parent 'Journal's.
 110 journal_find :: (Journal j -> Maybe a) -> Journal j -> Maybe (a, [Journal j])
 111 journal_find f =
 112         (\x -> case x of
 113          Nothing -> Nothing
 114          Just (a, path) -> Just (a, reverse path))
 115         . find_ []
 116         where
 117                 find_ path j@Journal{journal_includes} =
 118                         case f j of
 119                          Just a -> Just (a, path)
 120                          Nothing ->
 121                                 Data.Monoid.getFirst $
 122                                 foldMap (Data.Monoid.First . (find_ (j:path))) $
 123                                 journal_includes
 124
 125 -- | Return the given 'Journal' and its 'journal_includes' 'Journal's
 126 --   mapped by the given function.
 127 journal_traverse :: (Journal j -> Journal j) -> Journal j -> Journal j
 128 journal_traverse f =
 129         (\x -> case x of
 130          j@Journal{journal_includes} ->
 131                 j{journal_includes = fmap (journal_traverse f) journal_includes})
 132         . f
 133
 134 -- * Constructors
 135
 136 journal_unions :: (Foldable f, Monoid j) => f (Journal j) -> Journal j
 137 journal_unions = foldl' (flip mappend) journal
 138
 139 -- | Return the 'Journal' recursively 'mappend'-ed
 140 --   with its 'journal_includes', now empty.
 141 journal_flatten :: Monoid j => Journal j -> Journal j
 142 journal_flatten jnl =
 143         (mconcat $ (:) jnl $ journal_flatten <$>
 144                 journal_includes jnl) { journal_includes = [] }