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