lib/Hcompta/GL.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE FlexibleInstances #-}
   4 {-# LANGUAGE NamedFieldPuns #-}
   5 {-# LANGUAGE StandaloneDeriving #-}
   6 {-# LANGUAGE TypeFamilies #-}
   7 {-# OPTIONS_GHC -fno-warn-deprecations #-} -- FIXME: to be removed when dropping GHC-7.6 support
   8 -- | General Ledger
   9 module Hcompta.GL where -- General Ledger
  10
  11 import           Control.Exception (assert)
  12 import           Data.Data
  13 import qualified Data.Foldable
  14 -- import           Data.Foldable (Foldable)
  15 import           Data.Functor.Compose (Compose(..))
  16 import           Data.Maybe (fromMaybe)
  17 import qualified Data.Sequence
  18 import           Data.Sequence (Seq, (><), (|>), ViewR(..))
  19 import qualified Data.Traversable
  20 import qualified Data.Map.Strict as Data.Map
  21 import           Data.Map.Strict (Map)
  22 import           Data.Typeable ()
  23
  24 import qualified Hcompta.Account as Account
  25 import           Hcompta.Account (Account)
  26 import           Hcompta.Date (Date)
  27 import qualified Hcompta.Lib.TreeMap as TreeMap
  28 import           Hcompta.Lib.TreeMap (TreeMap)
  29
  30 -- * Requirements' interface
  31
  32 -- ** Class 'Amount'
  33 class
  34  ( Data (Amount_Unit a)
  35  , Data a
  36  , Eq a
  37  , Ord  (Amount_Unit a)
  38  , Show (Amount_Unit a)
  39  , Show a
  40  , Typeable (Amount_Unit a)
  41  ) => Amount a where
  42         type Amount_Unit a
  43         amount_add :: a -> a -> a
  44
  45 -- ** Class 'Posting'
  46
  47 -- | A 'posting' used to produce a 'GL'
  48 --   must be an instance of this class.
  49 class Amount (Posting_Amount p)
  50  => Posting p where
  51         type Posting_Amount p
  52         posting_account :: p -> Account
  53         posting_amount  :: p -> Posting_Amount p
  54
  55 instance (Amount amount)
  56  => Posting (Account, amount)
  57  where
  58         type Posting_Amount (Account, amount) = amount
  59         posting_account (x, _) = x
  60         posting_amount  (_, x) = x
  61
  62 -- ** Class 'Transaction'
  63
  64 class
  65  ( Posting  (Transaction_Posting t)
  66  , Data     (Transaction_Posting t)
  67  , Eq       (Transaction_Posting t)
  68  , Show     (Transaction_Posting t)
  69  , Foldable (Transaction_Postings t)
  70  ) => Transaction t where
  71         type Transaction_Posting t
  72         type Transaction_Postings t :: * -> *
  73         transaction_date     :: t -> Date
  74         transaction_postings :: t -> Transaction_Postings t (Transaction_Posting t)
  75
  76 instance
  77  ( Posting posting
  78  , Data    posting
  79  , Eq      posting
  80  , Show    posting
  81  ) => Transaction (Date, Map Account ([] posting))
  82  where
  83         type Transaction_Posting  (Date, Map Account ([] posting)) = posting
  84         type Transaction_Postings (Date, Map Account ([] posting)) = Compose (Map Account) []
  85         transaction_date = fst
  86         transaction_postings = Compose . snd
  87
  88 -- * Type 'GL'
  89
  90 newtype Transaction transaction
  91  => GL transaction
  92  =  GL (TreeMap Account.Name (Map Date (Seq (GL_Line transaction))))
  93 deriving instance ( Transaction transaction
  94                   , Data        transaction
  95                   , Typeable    transaction
  96                   , Typeable GL_Line
  97                   ) => Data (GL transaction)
  98 deriving instance ( Transaction transaction
  99                   , Eq          transaction
 100                   ) => Eq (GL   transaction)
 101 deriving instance ( Transaction transaction
 102                   , Show        transaction
 103                   ) => Show (GL transaction)
 104 deriving instance Typeable1 GL
 105  -- FIXME: use 'Typeable' when dropping GHC-7.6 support
 106
 107 data
 108  Transaction transaction
 109  => GL_Line  transaction
 110  =  GL_Line
 111  {  gl_line_transaction :: transaction
 112  ,  gl_line_posting     :: Transaction_Posting transaction
 113  ,  gl_line_sum         :: Posting_Amount (Transaction_Posting transaction)
 114  }
 115 deriving instance ( Transaction transaction
 116                   , Data        transaction
 117                   , Typeable    transaction
 118                   , Typeable GL_Line
 119                   ) => Data (GL_Line transaction)
 120 deriving instance ( Transaction transaction
 121                   , Eq          transaction
 122                   ) => Eq (GL_Line transaction)
 123 deriving instance ( Transaction transaction
 124                   , Show        transaction
 125                   ) => Show (GL_Line transaction)
 126 deriving instance Typeable1 GL_Line
 127  -- FIXME: use 'Typeable' when dropping GHC-7.6 support
 128
 129 -- ** Constructors
 130
 131 nil
 132  :: Transaction transaction
 133  => GL transaction
 134 nil = GL TreeMap.empty
 135
 136 -- | Return the given 'GL'
 137 --   updated by the given 'Transaction'.
 138 general_ledger
 139  :: Transaction transaction
 140  => transaction
 141  -> GL transaction
 142  -> GL transaction
 143 general_ledger t (GL gl) =
 144         GL $
 145         Data.Foldable.foldr
 146          ((\p ->
 147                 let first_line =
 148                         GL_Line
 149                          { gl_line_transaction = t
 150                          , gl_line_posting     = p
 151                          , gl_line_sum         = posting_amount p
 152                          } in
 153                 let single =
 154                         Data.Map.singleton (transaction_date t) $
 155                         Data.Sequence.singleton first_line in
 156                 TreeMap.insert
 157                  (\_new old ->
 158                         let (nlt, leq, neq, ngt) =
 159                                 case Data.Map.splitLookup (transaction_date t) old of
 160                                  (olt, Nothing, ogt) | Data.Map.null olt ->
 161                                         (olt, first_line, Data.Sequence.singleton first_line, ogt)
 162                                  (olt, Nothing, ogt) ->
 163                                         let line =
 164                                                 case Data.Sequence.viewr $ snd $ Data.Map.findMax olt of
 165                                                  (_:>GL_Line{gl_line_sum = s}) ->
 166                                                         first_line{gl_line_sum = amount_add s $ posting_amount p}
 167                                                  _ -> first_line
 168                                         in (olt, line, Data.Sequence.singleton line, ogt)
 169                                  (olt, Just oeq, ogt) ->
 170                                         case Data.Sequence.viewr oeq of
 171                                          (_:>GL_Line{gl_line_sum = s}) ->
 172                                                 let line = first_line{gl_line_sum = amount_add s $ posting_amount p} in
 173                                                 (olt, line, oeq |> line, ogt)
 174                                          _ -> (olt, first_line, Data.Sequence.singleton first_line, ogt)
 175                         in
 176                         Data.Map.union nlt $
 177                         Data.Map.insert (transaction_date t) neq $
 178                         Data.Map.map (fmap (\l -> l{gl_line_sum =
 179                                 amount_add (gl_line_sum leq) $
 180                                 gl_line_sum l})) ngt
 181                  )
 182                  (posting_account p)
 183                  single
 184          ))
 185          gl
 186          (transaction_postings t)
 187
 188 -- * Type 'Expanded'
 189
 190 -- | Descending propagation of 'Amount's accross 'Account's.
 191 type Expanded transaction
 192  = TreeMap Account.Name (GL_Line_Expanded transaction)
 193 data Transaction     transaction
 194  => GL_Line_Expanded transaction
 195  =  GL_Line_Expanded
 196  { exclusive :: Map Date (Seq (GL_Line transaction))
 197  , inclusive :: Map Date (Seq (GL_Line transaction)) -- ^ 'amount_add' folded over 'exclusive' and 'inclusive' of 'Lib.TreeMap.node_descendants'
 198  }
 199 deriving instance ( Transaction transaction
 200                   , Data        transaction
 201                   ) => Data (GL_Line_Expanded transaction)
 202 deriving instance ( Transaction transaction
 203                   , Eq          transaction
 204                   ) => Eq (GL_Line_Expanded transaction)
 205 deriving instance ( Transaction transaction
 206                   , Show        transaction
 207                   ) => Show (GL_Line_Expanded transaction)
 208 deriving instance Typeable1 GL_Line_Expanded
 209  -- FIXME: use 'Typeable' when dropping GHC-7.6 support
 210
 211 -- | Return the given 'GL' with:
 212 --
 213 -- * all missing 'Account.ascending' 'Account's inserted,
 214 --
 215 -- * and every mapped 'GL_Line'
 216 -- added with any 'GL_Line'
 217 -- of the 'Account's for which it is 'Account.ascending'.
 218 expanded
 219  :: Transaction transaction
 220  => GL          transaction
 221  -> Expanded    transaction
 222 expanded (GL gl) =
 223         let from_value = fromMaybe (assert False undefined) . TreeMap.node_value in
 224         TreeMap.map_by_depth_first
 225          (\descendants value ->
 226                 let nodes = TreeMap.nodes descendants in
 227                 let exclusive = fromMaybe Data.Map.empty value in
 228                 GL_Line_Expanded
 229                  { exclusive
 230                  , inclusive =
 231                         getCompose $
 232                         snd $
 233                         Data.Traversable.mapAccumL
 234                          (\ms line ->
 235                                 let pamt = posting_amount $ gl_line_posting line in
 236                                 case ms of
 237                                  Nothing -> (Just pamt, line)
 238                                  Just s ->
 239                                         let ls = amount_add s pamt in
 240                                         ( Just ls
 241                                         , line{gl_line_sum=ls} )
 242                          ) Nothing $
 243                         Compose $
 244                         Data.Map.foldr
 245                          (Data.Map.unionWith (><) . inclusive . from_value)
 246                          exclusive nodes
 247                  })
 248          gl