lib/Hcompta/Format/Ledger/Journal.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE LambdaCase #-}
   3 {-# LANGUAGE NamedFieldPuns #-}
   4 module Hcompta.Format.Ledger.Journal where
   5
   6 -- import           Control.Applicative ((<$>))
   7 import           Data.Data
   8 import qualified Data.Foldable (foldMap)
   9 import qualified Data.List
  10 import qualified Data.Map.Strict as Data.Map
  11 import           Data.Map.Strict (Map)
  12 import qualified Data.Monoid (getFirst, First(..))
  13 import           Data.Monoid (Monoid, mappend)
  14 import qualified Data.Time.Clock       as Time
  15 import qualified Data.Time.Clock.POSIX as Time
  16 import           Data.Typeable ()
  17
  18 import qualified Hcompta.Model as Model
  19 import qualified Hcompta.Model.Amount as Amount
  20 import qualified Hcompta.Model.Journal as Model.Journal
  21 import qualified Hcompta.Model.Transaction as Transaction
  22
  23 data Journal
  24  =   Journal
  25  { file :: FilePath
  26  , includes :: [Journal]
  27  -- , historical_prices :: [Amount.Price.Historical]
  28  , last_read_time :: Time.UTCTime
  29  , transactions :: Transaction.By_Date
  30  -- , transaction_periodics :: [Transaction.Periodic]
  31  -- , transaction_modifiers :: [Transaction.Modifier]
  32  , unit_styles :: Map Amount.Unit Amount.Style
  33  } deriving (Data, Eq, Read, Show, Typeable)
  34
  35 nil :: Journal
  36 nil =
  37         Journal
  38          { file = ""
  39          , includes = []
  40          , last_read_time = Time.posixSecondsToUTCTime 0
  41          , transactions = Data.Map.empty
  42          , unit_styles = Data.Map.empty
  43          }
  44
  45 -- | Return the given accumulator folded over
  46 --   the given 'Journal' and its 'includes' 'Journal's.
  47 fold :: (Journal -> a -> a) -> Journal -> a -> a
  48 fold f j@Journal{includes} a =
  49         Data.List.foldl (flip (Hcompta.Format.Ledger.Journal.fold f))
  50          (f j a)
  51          includes
  52
  53 -- | Return the first non-'Nothing' value returned by the given function
  54 --   when applied to the given 'Journal' or its 'includes' 'Journal's,
  55 --   with the parent 'Journal's.
  56 find :: (Journal -> Maybe a) -> Journal -> Maybe (a, [Journal])
  57 find f =
  58         (\case
  59          Nothing -> Nothing
  60          Just (a, path) -> Just (a, Data.List.reverse path))
  61         . find_ []
  62         where
  63                 find_ path j@Journal{includes} =
  64                         case f j of
  65                          Just a -> Just (a, path)
  66                          Nothing ->
  67                                 Data.Monoid.getFirst $
  68                                 Data.Foldable.foldMap (Data.Monoid.First . (find_ (j:path))) $
  69                                 includes
  70
  71 -- | Return the given 'Journal' and its 'includes' 'Journal's
  72 --   mapped by the given function.
  73 traverse :: (Journal -> Journal) -> Journal -> Journal
  74 traverse f =
  75         (\case j@Journal{includes} ->
  76                 j{includes=Data.List.map (traverse f) includes})
  77         . f
  78
  79 -- | Return the given accumulator folded with the given function
  80 --   over the given 'Journal' and its 'includes' 'Journal's.
  81 fold_map :: Monoid a => (Journal -> a -> a) -> Journal -> a -> a
  82 fold_map f j@(Journal{includes}) =
  83         (f j) `mappend` Data.Foldable.foldMap (fold_map f) includes
  84
  85 -- | Return the Model.'Model.Journal' derived from the given 'Journal'.
  86 to_Model :: Journal -> Model.Journal
  87 to_Model jour =
  88         Model.Journal.Journal
  89          { Model.Journal.transactions =
  90                 Data.Map.unionsWith (++) $
  91                 flatten transactions $ jour
  92          }
  93         where
  94                 flatten :: (Journal -> a) -> Journal -> [a]
  95                 flatten g j = g j:Data.List.concatMap (flatten g) (includes j)