ledger/Hcompta/Format/Ledger/Journal.hs

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