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