lib/Hcompta/GL.hs

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