lib/Hcompta/GL.hs

   1 {-# LANGUAGE BangPatterns #-}
   2 {-# LANGUAGE DeriveDataTypeable #-}
   3 {-# LANGUAGE FlexibleContexts #-}
   4 {-# LANGUAGE FlexibleInstances #-}
   5 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   6 {-# LANGUAGE MultiParamTypeClasses #-}
   7 {-# LANGUAGE NamedFieldPuns #-}
   8 {-# LANGUAGE RecordWildCards #-}
   9 {-# LANGUAGE ScopedTypeVariables #-}
  10 {-# LANGUAGE TypeFamilies #-}
  11 {-# LANGUAGE TypeOperators #-}
  12
  13 -- | General Ledger
  14 module Hcompta.GL where
  15
  16 import           Control.DeepSeq (NFData(..))
  17 import           Control.Exception (assert)
  18 import           Data.Bool
  19 import           Data.Data
  20 import           Data.Eq (Eq(..))
  21 import           Data.Function (($), (.), flip)
  22 import           Data.Functor (Functor(..))
  23 import           Data.Functor.Compose (Compose(..))
  24 import           Data.Map.Strict (Map)
  25 import qualified Data.Map.Strict as Map
  26 import           Data.Maybe (Maybe(..))
  27 import           Data.Monoid (Monoid(..))
  28 import qualified Data.MonoTraversable as MT
  29 import           Data.Ord (Ord(..))
  30 import           Data.Sequence (Seq, (><), (|>), ViewR(..))
  31 import qualified Data.Sequence as Seq
  32 import qualified Data.Strict.Maybe as Strict
  33 import qualified Data.Traversable as Traversable
  34 import           Data.TreeMap.Strict (TreeMap(..))
  35 import qualified Data.TreeMap.Strict as TreeMap
  36 import           Data.Tuple (snd)
  37 import           Data.Typeable ()
  38 import           Prelude (seq, undefined)
  39 import           Text.Show (Show(..))
  40
  41 import           Hcompta.Account
  42 import           Hcompta.Amount
  43 import           Hcompta.Date
  44 import qualified Hcompta.Lib.Strict as Strict
  45 import           Hcompta.Posting
  46 import           Hcompta.Quantity
  47 import           Hcompta.Has
  48
  49
  50 -- * Type 'GL'
  51 newtype GL_ tran date acct_sect post amt
  52  =      GL (TreeMap acct_sect
  53                     (Map date (Seq (GL_Line tran post amt))))
  54  deriving (Data, Eq, NFData, Show, Typeable)
  55 type GL tran
  56  = GL_ tran
  57  (Date :@ tran)
  58  (MT.Element (Account :@ (MT.Element (Postings :@ tran))))
  59  (MT.Element (Postings :@ tran))
  60  (Amount :@ (MT.Element (Postings :@ tran)))
  61
  62 gl_empty :: GL tran
  63 gl_empty = GL TreeMap.empty
  64
  65 -- * Type 'GL_Account'
  66 -- | 'GL' operations works on this type of 'Account'.
  67 type GL_Account = TreeMap.Path
  68
  69 -- | Return the given 'GL'
  70 --   updated by the given 'GL_Transaction'.
  71 --
  72 -- NOTE: to reduce memory consumption when applying 'gl_cons' iteratively,
  73 --       the given 'GL' is matched strictly.
  74 gl_cons ::
  75  ( post ~ MT.Element (Postings :@ tran)
  76  , acct_sect ~ MT.Element (Account :@ post)
  77  , GetI Postings tran
  78  , GetI Date tran
  79  , GetI Amount post
  80  , Get (GL_Account acct_sect) post
  81  , MT.MonoFoldable (Postings :@ tran)
  82  , Addable (Amount :@ post)
  83  , Ord acct_sect
  84  , Ord (Date :@ tran)
  85  ) => tran -> GL tran -> GL tran
  86 gl_cons tran (GL !gl) =
  87         GL $
  88         MT.ofoldl'
  89          (flip $ \post ->
  90                 let first_line =
  91                         GL_Line
  92                          { gl_line_transaction = tran
  93                          , gl_line_posting     = post
  94                          , gl_line_sum         = getI _Amount post
  95                          } in
  96                 let single =
  97                         Map.singleton (getI _Date tran) $
  98                         Seq.singleton first_line in
  99                 TreeMap.insert
 100                  (\_new old ->
 101                         let (nlt, leq, neq, ngt) =
 102                                 case Map.splitLookup (getI _Date tran) old of
 103                                  (olt, Nothing, ogt) | Map.null olt ->
 104                                         (olt, first_line, Seq.singleton first_line, ogt)
 105                                  (olt, Nothing, ogt) ->
 106                                         let line =
 107                                                 case Seq.viewr $ snd $ Map.findMax olt of
 108                                                  (_:>GL_Line{gl_line_sum = s}) ->
 109                                                         first_line{gl_line_sum = quantity_add s $ getI _Amount post}
 110                                                  _ -> first_line
 111                                         in (olt, line, Seq.singleton line, ogt)
 112                                  (olt, Just oeq, ogt) ->
 113                                         case Seq.viewr oeq of
 114                                          (_:>GL_Line{gl_line_sum = s}) ->
 115                                                 let line = first_line{gl_line_sum = quantity_add s $ getI _Amount post} in
 116                                                 (olt, line, oeq |> line, ogt)
 117                                          _ -> (olt, first_line, Seq.singleton first_line, ogt)
 118                         in
 119                         Map.union nlt $
 120                         Map.insert (getI _Date tran) neq $
 121                         Map.map
 122                          (fmap (\l -> l{gl_line_sum =
 123                                 quantity_add (gl_line_sum leq) $ gl_line_sum l}))
 124                          ngt
 125                  )
 126                  (get post)
 127                  single
 128          )
 129          gl
 130          (getI _Postings tran)
 131
 132 gl_union ::
 133  ( post ~ MT.Element (Postings :@ tran)
 134  , Ord (MT.Element (Account :@ post))
 135  , Ord (Date :@ tran)
 136  ) => GL tran -> GL tran -> GL tran
 137 gl_union (GL x) (GL y) =
 138         GL $ TreeMap.union (Map.unionWith (flip mappend)) x y
 139
 140 -- ** Type 'GL_Line'
 141 data GL_Line tran post amt
 142  =   GL_Line
 143  {   gl_line_transaction :: tran
 144  ,   gl_line_posting     :: post
 145  ,   gl_line_sum         :: amt
 146  }
 147  deriving (Data, Eq, Show, Typeable)
 148 instance -- NFData
 149  ( NFData tran
 150  , NFData post
 151  , NFData amt
 152  ) => NFData (GL_Line tran post amt) where
 153         rnf GL_Line{..} =
 154                 rnf gl_line_transaction `seq`
 155                 rnf gl_line_posting `seq`
 156                 rnf gl_line_sum
 157
 158
 159 -- * Type 'ExpandedGL'
 160
 161 -- | Descending propagation of 'Amount's accross 'Account's.
 162 newtype ExpandedGL_ tran date acct_sect post amt
 163  =      ExpandedGL (TreeMap acct_sect (ExpandedGL_Line tran date post amt))
 164  deriving (Data, Eq, NFData, Show, Typeable)
 165 type ExpandedGL  tran
 166  =   ExpandedGL_ tran
 167  (Date :@ tran)
 168  (MT.Element (Account :@ (MT.Element (Postings :@ tran))))
 169  (MT.Element (Postings :@ tran))
 170  (Amount :@ (MT.Element (Postings :@ tran)))
 171
 172 -- ** Type 'ExpandedGL_Line'
 173 -- |
 174 -- * 'Strict.exclusive': contains the original 'GL_Line's.
 175 -- * 'Strict.inclusive': contains 'quantity_add' folded
 176 --   over 'Strict.exclusive' and  'Strict.inclusive'
 177 --   of 'TreeMap.node_descendants'
 178 type ExpandedGL_Line tran date post amt
 179  = Strict.Clusive (Map date (Seq (GL_Line tran post amt)))
 180
 181 -- | Return the given 'GL' with:
 182 --
 183 -- * all missing 'Account.parent' 'Account's inserted;
 184 -- * and every mapped 'GL_Line'
 185 --   added with any 'GL_Line'
 186 --   of the 'Account's for which it is 'Account.parent'.
 187 expanded_gl ::
 188  ( post ~ MT.Element (Postings :@ tran)
 189  , GetI Amount post
 190  , Addable (Amount :@ post)
 191  , MT.MonoFoldable (Postings :@ tran)
 192  , Ord (MT.Element (Account :@ post))
 193  , Ord (Date :@ tran)
 194  ) => GL tran -> ExpandedGL tran
 195 expanded_gl (GL gl) =
 196         let from_value =
 197                 Strict.fromMaybe (assert False undefined) .
 198                 TreeMap.node_value in
 199         ExpandedGL $
 200         TreeMap.map_by_depth_first
 201          (\(TreeMap nodes) value ->
 202                 let exclusive = Strict.fromMaybe Map.empty value in
 203                 Strict.Clusive
 204                  { Strict.exclusive
 205                  , Strict.inclusive =
 206                         getCompose $
 207                         snd $
 208                         Traversable.mapAccumL -- NOTE: recalc 'gl_line_sum's
 209                          (\may_sum line ->
 210                                 let amt = getI _Amount $ gl_line_posting line in
 211                                 case may_sum of
 212                                  Nothing -> (Just amt, line)
 213                                  Just last_sum ->
 214                                         let new_sum = quantity_add last_sum amt in
 215                                         ( Just new_sum
 216                                         , line{gl_line_sum=new_sum} )
 217                          ) Nothing $
 218                         Compose $
 219                         Map.foldr
 220                          (Map.unionWith (flip (><)) . Strict.inclusive . from_value)
 221                          exclusive nodes
 222                  })
 223          gl