lib/Hcompta/Journal.hs

   1 {-# LANGUAGE BangPatterns #-}
   2 {-# LANGUAGE DeriveDataTypeable #-}
   3 {-# LANGUAGE FlexibleInstances #-}
   4 {-# LANGUAGE MultiParamTypeClasses #-}
   5 {-# OPTIONS_GHC -fno-warn-orphans #-}
   6 module Hcompta.Journal where
   7
   8 import           Control.DeepSeq (NFData(..))
   9 import           Data.Foldable (Foldable(..))
  10 import           Data.Functor (Functor(..))
  11 import           Data.Data
  12 import           Data.Typeable ()
  13 import           Data.Map.Strict (Map)
  14 import qualified Data.Map.Strict as Map
  15 import           Data.Monoid (Monoid(..))
  16 import           Prelude (($), Eq(..), Show(..), flip)
  17
  18 import           Hcompta.Date (Date)
  19 import           Hcompta.Lib.Consable (Consable(..))
  20 import           Hcompta.Transaction
  21
  22 -- * Class 'Journal_Transaction'
  23
  24 class Transaction t => Journal_Transaction t
  25
  26 -- * Type 'Journal'
  27
  28 newtype Journal t
  29  =      Journal (Map Date [t])
  30  deriving (Data, Eq, Show, Typeable)
  31
  32 instance Functor Journal where
  33         fmap f (Journal t) = Journal (fmap (fmap f) t)
  34 instance Foldable Journal where
  35         foldMap f (Journal t) = foldMap (foldMap f) t
  36 instance Monoid (Journal t) where
  37         mempty = Journal mempty
  38         mappend (Journal x) (Journal y) =
  39                 Journal $ Map.unionWith (flip mappend) x y
  40 instance NFData t => NFData (Journal t) where
  41         rnf (Journal t) = rnf t
  42 instance Journal_Transaction t
  43  => Consable t (Journal t) where
  44         mcons = journal_cons
  45
  46 -- | Return the given 'Journal'
  47 --   updated by the given 'Journal_Transaction'.
  48 --
  49 -- NOTE: to reduce memory consumption when 'cons'ing iteratively,
  50 --       the given 'Journal' is matched strictly.
  51 journal_cons :: Journal_Transaction t => t -> Journal t -> Journal t
  52 journal_cons t (Journal !ts) =
  53         Journal $
  54         Map.insertWith (flip mappend)
  55          (transaction_date t) [t] ts
  56
  57 journal_transactions :: Journal_Transaction t => Journal t -> Map Date [t]
  58 journal_transactions (Journal ts) = ts