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