jcc/Hcompta/JCC/Journal.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE NamedFieldPuns #-}
   3 {-# LANGUAGE RecordWildCards #-}
   4 module Hcompta.JCC.Journal where
   5
   6 import           Control.DeepSeq (NFData(..))
   7 import           Control.Monad (Monad(..), foldM)
   8 import           Data.Data (Data(..))
   9 import           Data.Eq (Eq(..))
  10 import           Data.Foldable (Foldable(..))
  11 import           Data.Function (($), (.), flip)
  12 import           Data.Functor (Functor(..), (<$>))
  13 import           Data.List (reverse)
  14 import           Data.Maybe (Maybe(..))
  15 import           Data.Monoid (Monoid(..))
  16 import qualified Data.Monoid as Monoid
  17 import           Data.Typeable (Typeable)
  18 import           Prelude (seq, min)
  19 import           System.IO (FilePath)
  20 import           Text.Show (Show(..))
  21
  22 import qualified Hcompta.Date as H
  23 import           Hcompta.JCC.Amount
  24 import           Hcompta.JCC.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 :: H.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 = H.date_epoch
  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 Journal{..} =
  68                 rnf journal_amount_styles `seq`
  69                 rnf journal_chart `seq`
  70                 rnf journal_content `seq`
  71                 rnf journal_files `seq`
  72                 rnf journal_includes `seq`
  73                 rnf journal_last_read_time
  74
  75 -- * Extractors
  76
  77 -- | Return the given accumulator folded over
  78 --   the given 'Journal' and its 'journal_includes' 'Journal's.
  79 journal_fold :: (Journal j -> a -> a) -> Journal j -> a -> a
  80 journal_fold f j@Journal{journal_includes} a =
  81         foldl'
  82          (flip (journal_fold f)) (f j a)
  83          journal_includes
  84
  85 -- | Return the given accumulator folded over
  86 --   the given 'Journal' and its 'journal_includes' 'Journal's.
  87 journal_foldM :: Monad m => (Journal j -> a -> m a) -> Journal j -> a -> m a
  88 journal_foldM f j@Journal{journal_includes} a = do
  89         ma <- f j a
  90         foldM
  91          (flip (journal_foldM f)) ma
  92          journal_includes
  93
  94 -- | Return the given accumulator folded with the given function
  95 --   over the given 'Journal' and its 'journal_includes' 'Journal's.
  96 journal_fold_map :: Monoid a => (Journal j -> a -> a) -> Journal j -> a -> a
  97 journal_fold_map f j@(Journal{journal_includes}) =
  98         (f j) `mappend` foldMap (journal_fold_map f) journal_includes
  99
 100 -- | Return the first non-'Nothing' value returned by the given function
 101 --   when applied to the given 'Journal' or its 'journal_includes' 'Journal's,
 102 --   with the parent 'Journal's.
 103 journal_find :: (Journal j -> Maybe a) -> Journal j -> Maybe (a, [Journal j])
 104 journal_find f =
 105         (\x -> case x of
 106          Nothing -> Nothing
 107          Just (a, path) -> Just (a, reverse path))
 108         . find_ []
 109         where
 110                 find_ path j =
 111                         case f j of
 112                          Just a -> Just (a, path)
 113                          Nothing ->
 114                                 Monoid.getFirst $
 115                                 foldMap (Monoid.First . (find_ (j:path))) $
 116                                 journal_includes j
 117
 118 -- | Return the given 'Journal' and its 'journal_includes' 'Journal's
 119 --   mapped by the given function.
 120 journal_traverse :: (Journal j -> Journal j) -> Journal j -> Journal j
 121 journal_traverse f =
 122         (\x -> case x of
 123          j@Journal{journal_includes} ->
 124                 j{journal_includes = fmap (journal_traverse f) journal_includes})
 125         . f
 126
 127 -- * Constructors
 128
 129 journal_unions :: (Foldable f, Monoid j) => f (Journal j) -> Journal j
 130 journal_unions = foldl' (flip mappend) journal
 131
 132 -- | Return the 'Journal' recursively 'mappend'-ed
 133 --   with its 'journal_includes', now empty.
 134 journal_flatten :: Monoid j => Journal j -> Journal j
 135 journal_flatten jnl =
 136         (mconcat $ (:) jnl $ journal_flatten <$>
 137                 journal_includes jnl) { journal_includes = [] }