Polissage : CLI.Command.Balance : is_worth.
[comptalang.git] / lib / Hcompta / GL.hs
index b1af1a4ab5a1b6a58b4ca1ae57a3d61aad1725c1..d0d15373a337d389bb5ff0b8b15e25039aadf75d 100644 (file)
@@ -1,20 +1,24 @@
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# OPTIONS_GHC -fno-warn-deprecations #-} -- FIXME: to be removed when dropping GHC-7.6 support
+-- | General Ledger
 module Hcompta.GL where -- General Ledger
 
+-- import           Control.Applicative (Const(..))
 import           Control.Exception (assert)
 import           Data.Data
 import qualified Data.Foldable
-import           Data.Foldable (Foldable)
+-- import           Data.Foldable (Foldable)
 import           Data.Functor.Compose (Compose(..))
-import           Data.Maybe (fromMaybe)
 import qualified Data.Sequence
 import           Data.Sequence (Seq, (><), (|>), ViewR(..))
+import qualified Data.Strict.Maybe as Strict
 import qualified Data.Traversable
 import qualified Data.Map.Strict as Data.Map
 import           Data.Map.Strict (Map)
@@ -23,6 +27,7 @@ import           Data.Typeable ()
 import qualified Hcompta.Account as Account
 import           Hcompta.Account (Account)
 import           Hcompta.Date (Date)
+-- import           Hcompta.Lib.Consable
 import qualified Hcompta.Lib.TreeMap as TreeMap
 import           Hcompta.Lib.TreeMap (TreeMap)
 
@@ -71,7 +76,9 @@ class
        type Transaction_Postings t :: * -> *
        transaction_date     :: t -> Date
        transaction_postings :: t -> Transaction_Postings t (Transaction_Posting t)
+       transaction_postings_filter :: (Transaction_Posting t -> Bool) -> t -> t
 
+{- NOTE: not needed so far.
 instance
  ( Posting posting
  , Data    posting
@@ -83,6 +90,25 @@ instance
        type Transaction_Postings (Date, Map Account ([] posting)) = Compose (Map Account) []
        transaction_date = fst
        transaction_postings = Compose . snd
+       transaction_postings_filter f =
+               fmap $
+               Data.Map.mapMaybe
+                (\p -> case filter f p of
+                        [] -> Nothing
+                        ps -> Just ps)
+-}
+instance
+ ( Posting posting
+ , Data    posting
+ , Eq      posting
+ , Show    posting
+ ) => Transaction (Date, [posting])
+ where
+       type Transaction_Posting  (Date, [posting]) = posting
+       type Transaction_Postings (Date, [posting]) = []
+       transaction_date     = fst
+       transaction_postings = snd
+       transaction_postings_filter = fmap . filter
 
 -- * Type 'GL'
 
@@ -102,10 +128,14 @@ deriving instance ( Transaction transaction
                   ) => Show (GL transaction)
 deriving instance Typeable1 GL
  -- FIXME: use 'Typeable' when dropping GHC-7.6 support
+instance Transaction transaction
+ => Monoid (GL transaction) where
+       mempty  = empty
+       mappend = union
 
 data
  Transaction transaction
- => GL_Line transaction
+ => GL_Line  transaction
  =  GL_Line
  {  gl_line_transaction :: transaction
  ,  gl_line_posting     :: Transaction_Posting transaction
@@ -127,22 +157,25 @@ deriving instance Typeable1 GL_Line
 
 -- ** Constructors
 
-nil
+empty
  :: Transaction transaction
  => GL transaction
-nil = GL TreeMap.empty
+empty = GL mempty
 
 -- | Return the given 'GL'
---   updated by the given 'Posting'.
-general_ledger
+--   updated by the given 'Transaction'.
+--
+-- NOTE: to reduce memory consumption when 'cons'ing iteratively,
+--       the given 'GL' is matched strictly.
+cons
  :: Transaction transaction
  => transaction
  -> GL transaction
  -> GL transaction
-general_ledger t (GL gl) =
+cons t (GL !gl) =
        GL $
-       Data.Foldable.foldr
-        ((\p ->
+       Data.Foldable.foldl'
+        (flip $ \p ->
                let first_line =
                        GL_Line
                         { gl_line_transaction = t
@@ -174,26 +207,38 @@ general_ledger t (GL gl) =
                        in
                        Data.Map.union nlt $
                        Data.Map.insert (transaction_date t) neq $
-                       Data.Map.map (fmap (\l -> l{gl_line_sum =
-                               amount_add (gl_line_sum leq) $
-                               gl_line_sum l})) ngt
+                       Data.Map.map
+                        (fmap (\l -> l{gl_line_sum =
+                               amount_add (gl_line_sum leq) $ gl_line_sum l}))
+                        ngt
                 )
                 (posting_account p)
                 single
-        ))
+        )
         gl
         (transaction_postings t)
 
+union
+ :: Transaction transaction
+ => GL transaction
+ -> GL transaction
+ -> GL transaction
+union (GL gl0) (GL gl1) =
+       GL $
+       TreeMap.union
+        (Data.Map.unionWith mappend)
+        gl0 gl1
+
 -- * Type 'Expanded'
 
 -- | Descending propagation of 'Amount's accross 'Account's.
 type Expanded transaction
  = TreeMap Account.Name (GL_Line_Expanded transaction)
-data Transaction           transaction
+data Transaction     transaction
  => GL_Line_Expanded transaction
  =  GL_Line_Expanded
- { exclusive :: Map Date (Seq (GL_Line transaction))
- , inclusive :: Map Date (Seq (GL_Line transaction)) -- ^ 'amount_add' folded over 'exclusive' and 'inclusive' of 'Lib.TreeMap.node_descendants'
+ { exclusive :: !(Map Date (Seq (GL_Line transaction)))
+ , inclusive :: !(Map Date (Seq (GL_Line transaction))) -- ^ 'amount_add' folded over 'exclusive' and 'inclusive' of 'Lib.TreeMap.node_descendants'
  }
 deriving instance ( Transaction transaction
                   , Data        transaction
@@ -219,11 +264,11 @@ expanded
  => GL          transaction
  -> Expanded    transaction
 expanded (GL gl) =
-       let from_value = fromMaybe (assert False undefined) . TreeMap.node_value in
+       let from_value = Strict.fromMaybe (assert False undefined) . TreeMap.node_value in
        TreeMap.map_by_depth_first
         (\descendants value ->
                let nodes = TreeMap.nodes descendants in
-               let exclusive = fromMaybe Data.Map.empty value in
+               let exclusive = Strict.fromMaybe Data.Map.empty value in
                GL_Line_Expanded
                 { exclusive
                 , inclusive =
@@ -241,7 +286,7 @@ expanded (GL gl) =
                         ) Nothing $
                        Compose $
                        Data.Map.foldr
-                        (Data.Map.unionWith (><) . inclusive . from_value)
+                        (Data.Map.unionWith (flip (><)) . inclusive . from_value)
                         exclusive nodes
                 })
         gl