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.foldl'
 178          (flip $ \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
 211                          (fmap (\l -> l{gl_line_sum =
 212                                 amount_add (gl_line_sum leq) $ gl_line_sum l}))
 213                          ngt
 214                  )
 215                  (posting_account p)
 216                  single
 217          )
 218          gl
 219          (transaction_postings t)
 220
 221 union
 222  :: Transaction transaction
 223  => GL transaction
 224  -> GL transaction
 225  -> GL transaction
 226 union (GL gl0) (GL gl1) =
 227         GL $
 228         TreeMap.union
 229          (Data.Map.unionWith mappend)
 230          gl0 gl1
 231
 232 -- * Type 'Expanded'
 233
 234 -- | Descending propagation of 'Amount's accross 'Account's.
 235 type Expanded transaction
 236  = TreeMap Account.Name (GL_Line_Expanded transaction)
 237 data Transaction     transaction
 238  => GL_Line_Expanded transaction
 239  =  GL_Line_Expanded
 240  { exclusive :: !(Map Date (Seq (GL_Line transaction)))
 241  , inclusive :: !(Map Date (Seq (GL_Line transaction))) -- ^ 'amount_add' folded over 'exclusive' and 'inclusive' of 'Lib.TreeMap.node_descendants'
 242  }
 243 deriving instance ( Transaction transaction
 244                   , Data        transaction
 245                   ) => Data (GL_Line_Expanded transaction)
 246 deriving instance ( Transaction transaction
 247                   , Eq          transaction
 248                   ) => Eq (GL_Line_Expanded transaction)
 249 deriving instance ( Transaction transaction
 250                   , Show        transaction
 251                   ) => Show (GL_Line_Expanded transaction)
 252 deriving instance Typeable1 GL_Line_Expanded
 253  -- FIXME: use 'Typeable' when dropping GHC-7.6 support
 254
 255 -- | Return the given 'GL' with:
 256 --
 257 -- * all missing 'Account.ascending' 'Account's inserted,
 258 --
 259 -- * and every mapped 'GL_Line'
 260 -- added with any 'GL_Line'
 261 -- of the 'Account's for which it is 'Account.ascending'.
 262 expanded
 263  :: Transaction transaction
 264  => GL          transaction
 265  -> Expanded    transaction
 266 expanded (GL gl) =
 267         let from_value = Strict.fromMaybe (assert False undefined) . TreeMap.node_value in
 268         TreeMap.map_by_depth_first
 269          (\descendants value ->
 270                 let nodes = TreeMap.nodes descendants in
 271                 let exclusive = Strict.fromMaybe Data.Map.empty value in
 272                 GL_Line_Expanded
 273                  { exclusive
 274                  , inclusive =
 275                         getCompose $
 276                         snd $
 277                         Data.Traversable.mapAccumL
 278                          (\ms line ->
 279                                 let pamt = posting_amount $ gl_line_posting line in
 280                                 case ms of
 281                                  Nothing -> (Just pamt, line)
 282                                  Just s ->
 283                                         let ls = amount_add s pamt in
 284                                         ( Just ls
 285                                         , line{gl_line_sum=ls} )
 286                          ) Nothing $
 287                         Compose $
 288                         Data.Map.foldr
 289                          (Data.Map.unionWith (flip (><)) . inclusive . from_value)
 290                          exclusive nodes
 291                  })
 292          gl