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