lib/Hcompta/GL.hs

   1 -- | General Ledger
   2 module Hcompta.GL where
   3
   4 import Control.DeepSeq (NFData(..))
   5 import Control.Exception (assert)
   6 import Data.Bool
   7 import Data.Data
   8 import Data.Eq (Eq(..))
   9 import Data.Function (($), (.), flip)
  10 import Data.Functor (Functor(..))
  11 import Data.Functor.Compose (Compose(..))
  12 import Data.Map.Strict (Map)
  13 import Data.Maybe (Maybe(..))
  14 import Data.Ord (Ord(..))
  15 import Data.Sequence (Seq, (><), (|>), ViewR(..))
  16 import Data.TreeMap.Strict (TreeMap(..))
  17 import Data.Tuple (snd)
  18 import Data.Typeable ()
  19 import Prelude (seq, undefined)
  20 import Text.Show (Show(..))
  21 import qualified Data.Map.Strict as Map
  22 import qualified Data.MonoTraversable as MT
  23 import qualified Data.Sequence as Seq
  24 import qualified Data.Strict.Maybe as Strict
  25 import qualified Data.Traversable as Traversable
  26 import qualified Data.TreeMap.Strict as TM
  27
  28 import Hcompta.Data
  29 import Hcompta.Quantity
  30 import qualified Hcompta.Lib.Strict as Strict
  31
  32 -- * Type 'GL'
  33 newtype GL txn date post name amt
  34  =      GL (TreeMap name
  35                     (Map date (Seq (LineGL txn post amt))))
  36  deriving (Data, Eq, NFData, Show, Typeable)
  37
  38 instance Zeroable (GL txn date post name amt) where
  39         zero = GL zero
  40 instance (Ord name, Ord date) => Addable (GL txn date post name amt) where
  41         GL x + GL y = GL $ TM.union (Map.unionWith (flip (+))) x y
  42 -- | NOTE: to reduce memory consumption when applying '(+=)' iteratively,
  43 --   the given 'GL' is matched strictly.
  44 instance ( post ~ MT.Element posts
  45          , MT.MonoFoldable posts
  46          , Get posts txn
  47          , Get date txn
  48          , Get amt post
  49          , Get (TM.Path name) post
  50          , Addable amt
  51          , Ord name
  52          , Ord date
  53          ) =>
  54          Sumable (GL txn date post name amt) (txn, posts) where
  55         GL !gl += (txn, posts) = GL $
  56                 MT.ofoldl'
  57                  (flip $ \post ->
  58                         let first_line =
  59                                 LineGL
  60                                  { lineGL_transaction = txn
  61                                  , lineGL_posting     = post
  62                                  , lineGL_sum         = get @amt post
  63                                  } in
  64                         let single =
  65                                 Map.singleton (get @date txn) $
  66                                 Seq.singleton first_line in
  67                         TM.insert
  68                          (\_new old ->
  69                                 let (nlt, leq, neq, ngt) =
  70                                         case Map.splitLookup (get @date txn) old of
  71                                          (olt, Nothing, ogt) | Map.null olt ->
  72                                                 (olt, first_line, Seq.singleton first_line, ogt)
  73                                          (olt, Nothing, ogt) ->
  74                                                 let line =
  75                                                         case Seq.viewr $ snd $ Map.findMax olt of
  76                                                          (_:>LineGL{lineGL_sum = s}) ->
  77                                                                 first_line{lineGL_sum = s + get @amt post}
  78                                                          _ -> first_line
  79                                                 in (olt, line, Seq.singleton line, ogt)
  80                                          (olt, Just oeq, ogt) ->
  81                                                 case Seq.viewr oeq of
  82                                                  (_:>LineGL{lineGL_sum = s}) ->
  83                                                         let line = first_line{lineGL_sum = s + get @amt post} in
  84                                                         (olt, line, oeq |> line, ogt)
  85                                                  _ -> (olt, first_line, Seq.singleton first_line, ogt)
  86                                 in
  87                                 Map.union nlt $
  88                                 Map.insert (get @date txn) neq $
  89                                 Map.map
  90                                  (fmap (\l -> l{lineGL_sum =
  91                                         lineGL_sum leq + lineGL_sum l}))
  92                                  ngt
  93                          )
  94                          (get post)
  95                          single
  96                  )
  97                  gl
  98                  posts
  99
 100 -- ** Type 'LineGL'
 101 data LineGL txn post amt
 102  =   LineGL
 103  {   lineGL_transaction :: txn
 104  ,   lineGL_posting     :: post
 105  ,   lineGL_sum         :: amt
 106  } deriving (Data, Eq, Show, Typeable)
 107 instance (NFData txn, NFData post, NFData amt) => NFData (LineGL txn post amt) where
 108         rnf LineGL{..} =
 109                 rnf lineGL_transaction `seq`
 110                 rnf lineGL_posting `seq`
 111                 rnf lineGL_sum
 112
 113 -- * Type 'ExpandedGL'
 114 -- | Descending propagation of amounts accross accounts.
 115 newtype ExpandedGL txn date post name amt
 116  =      ExpandedGL (TreeMap name (LineExpandedGL txn date post amt))
 117  deriving (Data, Eq, NFData, Show, Typeable)
 118
 119 -- ** Type 'LineExpandedGL'
 120 -- |
 121 -- * 'Strict.exclusive': contains the original 'LineGL's.
 122 -- * 'Strict.inclusive': contains ('+') folded
 123 --   over 'Strict.exclusive' and 'Strict.inclusive'
 124 --   of 'TM.node_descendants'.
 125 type LineExpandedGL txn date post amt
 126  = Strict.Clusive (Map date (Seq (LineGL txn post amt)))
 127
 128 -- | Return the given 'GL' with:
 129 --
 130 -- * all missing parent accounts inserted;
 131 -- * and every mapped 'LineGL' added with any 'LineGL'
 132 --   of the accounts for which it is parent.
 133 expandedGL ::
 134  forall txn date post name amt.
 135  ( Get amt post
 136  , Addable amt
 137  , Ord name
 138  , Ord date
 139  ) =>
 140  GL txn date post name amt ->
 141  ExpandedGL txn date post name amt
 142 expandedGL (GL gl) =
 143         let from_value =
 144                 Strict.fromMaybe (assert False undefined) .
 145                 TM.node_value in
 146         ExpandedGL $
 147         TM.map_by_depth_first
 148          (\(TreeMap nodes) value ->
 149                 let exclusive = Strict.fromMaybe Map.empty value in
 150                 Strict.Clusive
 151                  { Strict.exclusive
 152                  , Strict.inclusive =
 153                         getCompose $
 154                         snd $
 155                         Traversable.mapAccumL -- NOTE: recalc 'lineGL_sum's
 156                          (\may_sum line ->
 157                                 let amt = get @amt $ lineGL_posting line in
 158                                 case may_sum of
 159                                  Nothing -> (Just amt, line)
 160                                  Just last_sum ->
 161                                         let new_sum = last_sum + amt in
 162                                         ( Just new_sum
 163                                         , line{lineGL_sum=new_sum} )
 164                          ) Nothing $
 165                         Compose $
 166                         Map.foldr
 167                          (Map.unionWith (flip (><)) . Strict.inclusive . from_value)
 168                          exclusive nodes
 169                  })
 170          gl