lib/Hcompta/GL.hs

   1 {-# LANGUAGE BangPatterns #-}
   2 {-# LANGUAGE DeriveDataTypeable #-}
   3 {-# LANGUAGE FlexibleContexts #-}
   4 {-# LANGUAGE FlexibleInstances #-}
   5 {-# LANGUAGE MultiParamTypeClasses #-}
   6 {-# LANGUAGE NamedFieldPuns #-}
   7 {-# LANGUAGE RecordWildCards #-}
   8 {-# LANGUAGE StandaloneDeriving #-}
   9 {-# LANGUAGE TypeFamilies #-}
  10 {-# OPTIONS_GHC -fno-warn-deprecations #-}
  11  -- FIXME: to be removed when dropping GHC-7.6 support
  12
  13 -- | General Ledger
  14 module Hcompta.GL where
  15
  16 -- import           Control.Applicative (Const(..))
  17 import           Control.DeepSeq (NFData(..))
  18 import           Control.Exception (assert)
  19 import           Data.Bool
  20 import           Data.Data
  21 -- import           Data.Eq (Eq(..))
  22 -- import           Data.Foldable (Foldable(..))
  23 -- import qualified Data.Foldable as Foldable
  24 import           Data.Function (($), (.), flip, id)
  25 import           Data.Functor (Functor(..))
  26 import           Data.Functor.Compose (Compose(..))
  27 -- import qualified Data.List as List
  28 import           Data.Map.Strict (Map)
  29 import qualified Data.Map.Strict as Map
  30 import           Data.Maybe (Maybe(..))
  31 import           Data.Monoid (Monoid(..))
  32 import qualified Data.MonoTraversable as MT
  33 import           Data.Sequence (Seq, (><), (|>), ViewR(..))
  34 import qualified Data.Sequence as Seq
  35 import qualified Data.Strict.Maybe as Strict
  36 import qualified Data.Traversable as Traversable
  37 import           Data.TreeMap.Strict (TreeMap(..))
  38 import qualified Data.TreeMap.Strict as TreeMap
  39 import           Data.Tuple (snd)
  40 import           Data.Typeable ()
  41 import           Prelude (seq, undefined)
  42 import           Text.Show (Show(..))
  43
  44 import           Hcompta.Account
  45 import           Hcompta.Date
  46 import qualified Hcompta.Lib.Strict as Strict
  47 import           Hcompta.Posting
  48 import           Hcompta.Quantity
  49 import           Hcompta.Transaction
  50
  51 -- * Class 'GL_Posting'
  52
  53 class
  54  ( Posting p
  55  , Addable (GL_Posting_Quantity p)
  56  , Data    (GL_Posting_Quantity p)
  57  , NFData  (GL_Posting_Quantity p)
  58  , Show    (GL_Posting_Quantity p)
  59  ) => GL_Posting p where
  60         type GL_Posting_Quantity p
  61         gl_posting_quantity :: p -> GL_Posting_Quantity p
  62
  63 {-
  64 instance
  65  ( Account account
  66  , Amount quantity
  67  , Posting (account, quantity)
  68  , Addable quantity
  69  , NFData  quantity
  70  ) => GL_Posting (account, quantity)
  71  where
  72         -- type Posting_Account   (account, quantity) = account
  73         type Posting_Quantity  (account, quantity) = quantity
  74         -- posting_account  (x, _) = x
  75         posting_quantity (_, x) = x
  76 -}
  77
  78 -- ** Class 'GL_Transaction'
  79
  80 class
  81  ( Transaction t
  82  , GL_Posting      (Transaction_Posting  t)
  83  , Data            (Transaction_Posting  t)
  84  , NFData          (Transaction_Posting  t)
  85  , Show            (Transaction_Posting  t)
  86  , MT.Element      (Transaction_Postings t) ~ Transaction_Posting t
  87  , MT.MonoFoldable (Transaction_Postings t)
  88  , Data   (GL_Transaction_Line t)
  89  , Show   (GL_Transaction_Line t)
  90  , NFData (GL_Transaction_Line t)
  91  ) => GL_Transaction t where
  92         type GL_Transaction_Line t
  93         gl_transaction_line :: t -> GL_Transaction_Line t
  94         -- gl_transaction_postings_filter :: (Transaction_Posting t -> Bool) -> t -> t
  95
  96 {- NOTE: not needed so far.
  97 instance
  98  ( GL_Posting posting
  99  , Data    posting
 100  , Eq      posting
 101  , Show    posting
 102  , account ~ Posting_Account posting
 103  ) => GL_Transaction (Date, Map account ([] posting))
 104  where
 105         type Transaction_Posting  (Date, Map account ([] posting)) = posting
 106         type Transaction_Postings (Date, Map account ([] posting)) = Compose (Map account) []
 107         transaction_date = fst
 108         transaction_postings = Compose . snd
 109         gl_transaction_postings_filter f =
 110                 fmap $
 111                 Map.mapMaybe
 112                  (\p -> case filter f p of
 113                          [] -> Nothing
 114                          ps -> Just ps)
 115 -}
 116
 117 instance
 118  ( GL_Posting posting
 119  , Data       posting
 120  , NFData     posting
 121  , Show       posting
 122  ) => GL_Transaction (Date, [posting])
 123  where
 124         type GL_Transaction_Line (Date, [posting]) = (Date, [posting])
 125         gl_transaction_line            = id
 126         -- gl_transaction_postings_filter = fmap . List.filter
 127
 128 -- * Type 'GL'
 129
 130 newtype GL_Transaction t
 131  =>     GL             t
 132  =      GL (TreeMap (Account_Section (Posting_Account (Transaction_Posting t)))
 133                     (Map Date (Seq (GL_Line t))))
 134 deriving instance -- Data
 135  ( GL_Transaction t
 136  , Data t
 137  ) => Data (GL t)
 138 instance -- Monoid
 139  GL_Transaction t
 140  => Monoid (GL t) where
 141         mempty  = gl_empty
 142         mappend = gl_union
 143 instance -- NFData
 144  ( GL_Transaction t
 145  , NFData t
 146  ) => NFData (GL t) where
 147         rnf (GL t) = rnf t
 148 deriving instance -- Show
 149  ( GL_Transaction t
 150  , Show t
 151  ) => Show (GL t)
 152 deriving instance -- Typeable
 153  Typeable1 GL
 154  -- FIXME: use 'Typeable' when dropping GHC-7.6 support
 155
 156 -- ** Type 'GL_Line'
 157
 158 data GL_Line transaction
 159  =   GL_Line
 160  {   gl_line_transaction :: GL_Transaction_Line transaction
 161  ,   gl_line_posting     :: Transaction_Posting transaction
 162  ,   gl_line_sum         :: GL_Posting_Quantity (Transaction_Posting transaction)
 163  }
 164 deriving instance -- Data
 165  ( GL_Transaction t
 166  , Data t
 167  , Typeable t
 168  , Typeable1 GL_Line
 169  ) => Data (GL_Line t)
 170 instance -- NFData
 171  ( GL_Transaction t
 172  , NFData t
 173  ) => NFData (GL_Line t) where
 174         rnf GL_Line{..} =
 175                 rnf gl_line_transaction `seq`
 176                 rnf gl_line_posting `seq`
 177                 rnf gl_line_sum
 178 deriving instance -- Show
 179  ( GL_Transaction t
 180  ) => Show (GL_Line t)
 181 deriving instance -- Typeable
 182  Typeable1 GL_Line
 183  -- FIXME: use 'Typeable' when dropping GHC-7.6 support
 184
 185 -- ** Constructors
 186
 187 gl_empty
 188  :: GL_Transaction transaction
 189  => GL transaction
 190 gl_empty = GL mempty
 191
 192 -- | Return the given 'GL'
 193 --   updated by the given 'GL_Transaction'.
 194 --
 195 -- NOTE: to reduce memory consumption when applying 'gl_cons' iteratively,
 196 --       the given 'GL' is matched strictly.
 197 gl_cons
 198  :: GL_Transaction transaction
 199  => transaction
 200  -> GL transaction
 201  -> GL transaction
 202 gl_cons t (GL !gl) =
 203         GL $
 204         MT.ofoldl'
 205          (flip $ \p ->
 206                 let first_line =
 207                         GL_Line
 208                          { gl_line_transaction = gl_transaction_line t
 209                          , gl_line_posting     = p
 210                          , gl_line_sum         = gl_posting_quantity p
 211                          } in
 212                 let single =
 213                         Map.singleton (transaction_date t) $
 214                         Seq.singleton first_line in
 215                 TreeMap.insert
 216                  (\_new old ->
 217                         let (nlt, leq, neq, ngt) =
 218                                 case Map.splitLookup (transaction_date t) old of
 219                                  (olt, Nothing, ogt) | Map.null olt ->
 220                                         (olt, first_line, Seq.singleton first_line, ogt)
 221                                  (olt, Nothing, ogt) ->
 222                                         let line =
 223                                                 case Seq.viewr $ snd $ Map.findMax olt of
 224                                                  (_:>GL_Line{gl_line_sum = s}) ->
 225                                                         first_line{gl_line_sum = quantity_add s $ gl_posting_quantity p}
 226                                                  _ -> first_line
 227                                         in (olt, line, Seq.singleton line, ogt)
 228                                  (olt, Just oeq, ogt) ->
 229                                         case Seq.viewr oeq of
 230                                          (_:>GL_Line{gl_line_sum = s}) ->
 231                                                 let line = first_line{gl_line_sum = quantity_add s $ gl_posting_quantity p} in
 232                                                 (olt, line, oeq |> line, ogt)
 233                                          _ -> (olt, first_line, Seq.singleton first_line, ogt)
 234                         in
 235                         Map.union nlt $
 236                         Map.insert (transaction_date t) neq $
 237                         Map.map
 238                          (fmap (\l -> l{gl_line_sum =
 239                                 quantity_add (gl_line_sum leq) $ gl_line_sum l}))
 240                          ngt
 241                  )
 242                  (account_path $ posting_account p)
 243                  single
 244          )
 245          gl
 246          (transaction_postings t)
 247
 248 gl_union
 249  :: GL_Transaction transaction
 250  => GL transaction
 251  -> GL transaction
 252  -> GL transaction
 253 gl_union (GL x) (GL y) =
 254         GL $ TreeMap.union (Map.unionWith mappend) x y
 255
 256 -- * Type 'GL_Expanded'
 257
 258 -- | Descending propagation of 'Amount's accross 'Account's.
 259 newtype GL_Transaction transaction
 260  =>     GL_Expanded    transaction
 261  =      GL_Expanded (TreeMap (Account_Section (Posting_Account (Transaction_Posting transaction)))
 262                              (GL_Expanded_Line transaction))
 263
 264 -- ** Type 'GL_Expanded_Line'
 265
 266 -- |
 267 -- * 'Strict.exclusive': contains the original 'GL_Line's.
 268 -- * 'Strict.inclusive': contains 'quantity_add' folded
 269 --   over 'Strict.exclusive' and  'Strict.inclusive'
 270 --   of 'TreeMap.node_descendants'
 271 type GL_Expanded_Line transaction
 272  = Strict.Clusive (Map Date (Seq (GL_Line transaction)))
 273
 274 -- | Return the given 'GL' with:
 275 --
 276 -- * all missing 'Account.parent' 'Account's inserted;
 277 -- * and every mapped 'GL_Line'
 278 --   added with any 'GL_Line'
 279 --   of the 'Account's for which it is 'Account.parent'.
 280 gl_expanded
 281  :: GL_Transaction transaction
 282  => GL             transaction
 283  -> GL_Expanded    transaction
 284 gl_expanded (GL gl) =
 285         let from_value =
 286                 Strict.fromMaybe (assert False undefined) .
 287                 TreeMap.node_value in
 288         GL_Expanded $
 289         TreeMap.map_by_depth_first
 290          (\(TreeMap nodes) value ->
 291                 let exclusive = Strict.fromMaybe Map.empty value in
 292                 Strict.Clusive
 293                  { Strict.exclusive
 294                  , Strict.inclusive =
 295                         getCompose $
 296                         snd $
 297                         Traversable.mapAccumL -- NOTE: recalc 'gl_line_sum's
 298                          (\may_sum line ->
 299                                 let amts = gl_posting_quantity $ gl_line_posting line in
 300                                 case may_sum of
 301                                  Nothing -> (Just amts, line)
 302                                  Just last_sum ->
 303                                         let new_sum = quantity_add last_sum amts in
 304                                         ( Just new_sum
 305                                         , line{gl_line_sum=new_sum} )
 306                          ) Nothing $
 307                         Compose $
 308                         Map.foldr
 309                          (Map.unionWith (flip (><)) . Strict.inclusive . from_value)
 310                          exclusive nodes
 311                  })
 312          gl