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: conflicting with the instance below.
  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 -}
  94
  95 instance
  96  ( Posting posting
  97  , Data    posting
  98  , Eq      posting
  99  , Show    posting
 100  ) => Transaction (Date, [posting])
 101  where
 102         type Transaction_Posting  (Date, [posting]) = posting
 103         type Transaction_Postings (Date, [posting]) = []
 104         transaction_date     = fst
 105         transaction_postings = snd
 106         transaction_postings_filter = fmap . filter
 107
 108 -- * Type 'GL'
 109
 110 newtype Transaction transaction
 111  => GL transaction
 112  =  GL (TreeMap Account.Name (Map Date (Seq (GL_Line transaction))))
 113 deriving instance ( Transaction transaction
 114                   , Data        transaction
 115                   , Typeable    transaction
 116                   , Typeable GL_Line
 117                   ) => Data (GL transaction)
 118 deriving instance ( Transaction transaction
 119                   , Eq          transaction
 120                   ) => Eq (GL   transaction)
 121 deriving instance ( Transaction transaction
 122                   , Show        transaction
 123                   ) => Show (GL transaction)
 124 deriving instance Typeable1 GL
 125  -- FIXME: use 'Typeable' when dropping GHC-7.6 support
 126 instance Transaction transaction
 127  => Monoid (GL transaction) where
 128         mempty  = empty
 129         mappend = union
 130
 131 instance Transaction transaction
 132  => Consable (Const (GL transaction)) transaction where
 133         mcons t (Const !gl) = Const $ cons t gl
 134 instance
 135  ( Foldable foldable
 136  , Transaction transaction
 137  )
 138  => Consable (Const (GL transaction))
 139  (foldable transaction) where
 140         mcons ts (Const !gl) =
 141                 Const $ Data.Foldable.foldr cons gl ts
 142
 143 data
 144  Transaction transaction
 145  => GL_Line  transaction
 146  =  GL_Line
 147  {  gl_line_transaction :: transaction
 148  ,  gl_line_posting     :: Transaction_Posting transaction
 149  ,  gl_line_sum         :: Posting_Amount (Transaction_Posting transaction)
 150  }
 151 deriving instance ( Transaction transaction
 152                   , Data        transaction
 153                   , Typeable    transaction
 154                   , Typeable GL_Line
 155                   ) => Data (GL_Line transaction)
 156 deriving instance ( Transaction transaction
 157                   , Eq          transaction
 158                   ) => Eq (GL_Line transaction)
 159 deriving instance ( Transaction transaction
 160                   , Show        transaction
 161                   ) => Show (GL_Line transaction)
 162 deriving instance Typeable1 GL_Line
 163  -- FIXME: use 'Typeable' when dropping GHC-7.6 support
 164
 165 -- ** Constructors
 166
 167 empty
 168  :: Transaction transaction
 169  => GL transaction
 170 empty = GL TreeMap.empty
 171
 172 -- | Return the given 'GL'
 173 --   updated by the given 'Transaction'.
 174 cons
 175  :: Transaction transaction
 176  => transaction
 177  -> GL transaction
 178  -> GL transaction
 179 cons t (GL gl) =
 180         GL $
 181         Data.Foldable.foldr
 182          ((\p ->
 183                 let first_line =
 184                         GL_Line
 185                          { gl_line_transaction = t
 186                          , gl_line_posting     = p
 187                          , gl_line_sum         = posting_amount p
 188                          } in
 189                 let single =
 190                         Data.Map.singleton (transaction_date t) $
 191                         Data.Sequence.singleton first_line in
 192                 TreeMap.insert
 193                  (\_new old ->
 194                         let (nlt, leq, neq, ngt) =
 195                                 case Data.Map.splitLookup (transaction_date t) old of
 196                                  (olt, Nothing, ogt) | Data.Map.null olt ->
 197                                         (olt, first_line, Data.Sequence.singleton first_line, ogt)
 198                                  (olt, Nothing, ogt) ->
 199                                         let line =
 200                                                 case Data.Sequence.viewr $ snd $ Data.Map.findMax olt of
 201                                                  (_:>GL_Line{gl_line_sum = s}) ->
 202                                                         first_line{gl_line_sum = amount_add s $ posting_amount p}
 203                                                  _ -> first_line
 204                                         in (olt, line, Data.Sequence.singleton line, ogt)
 205                                  (olt, Just oeq, ogt) ->
 206                                         case Data.Sequence.viewr oeq of
 207                                          (_:>GL_Line{gl_line_sum = s}) ->
 208                                                 let line = first_line{gl_line_sum = amount_add s $ posting_amount p} in
 209                                                 (olt, line, oeq |> line, ogt)
 210                                          _ -> (olt, first_line, Data.Sequence.singleton first_line, ogt)
 211                         in
 212                         Data.Map.union nlt $
 213                         Data.Map.insert (transaction_date t) neq $
 214                         Data.Map.map (fmap (\l -> l{gl_line_sum =
 215                                 amount_add (gl_line_sum leq) $
 216                                 gl_line_sum l})) ngt
 217                  )
 218                  (posting_account p)
 219                  single
 220          ))
 221          gl
 222          (transaction_postings t)
 223
 224 union
 225  :: Transaction transaction
 226  => GL transaction
 227  -> GL transaction
 228  -> GL transaction
 229 union (GL gl0) (GL gl1) =
 230         GL $
 231         TreeMap.union
 232          (Data.Map.unionWith mappend)
 233          gl0 gl1
 234
 235 -- * Type 'Expanded'
 236
 237 -- | Descending propagation of 'Amount's accross 'Account's.
 238 type Expanded transaction
 239  = TreeMap Account.Name (GL_Line_Expanded transaction)
 240 data Transaction     transaction
 241  => GL_Line_Expanded transaction
 242  =  GL_Line_Expanded
 243  { exclusive :: Map Date (Seq (GL_Line transaction))
 244  , inclusive :: Map Date (Seq (GL_Line transaction)) -- ^ 'amount_add' folded over 'exclusive' and 'inclusive' of 'Lib.TreeMap.node_descendants'
 245  }
 246 deriving instance ( Transaction transaction
 247                   , Data        transaction
 248                   ) => Data (GL_Line_Expanded transaction)
 249 deriving instance ( Transaction transaction
 250                   , Eq          transaction
 251                   ) => Eq (GL_Line_Expanded transaction)
 252 deriving instance ( Transaction transaction
 253                   , Show        transaction
 254                   ) => Show (GL_Line_Expanded transaction)
 255 deriving instance Typeable1 GL_Line_Expanded
 256  -- FIXME: use 'Typeable' when dropping GHC-7.6 support
 257
 258 -- | Return the given 'GL' with:
 259 --
 260 -- * all missing 'Account.ascending' 'Account's inserted,
 261 --
 262 -- * and every mapped 'GL_Line'
 263 -- added with any 'GL_Line'
 264 -- of the 'Account's for which it is 'Account.ascending'.
 265 expanded
 266  :: Transaction transaction
 267  => GL          transaction
 268  -> Expanded    transaction
 269 expanded (GL gl) =
 270         let from_value = Strict.fromMaybe (assert False undefined) . TreeMap.node_value in
 271         TreeMap.map_by_depth_first
 272          (\descendants value ->
 273                 let nodes = TreeMap.nodes descendants in
 274                 let exclusive = Strict.fromMaybe Data.Map.empty value in
 275                 GL_Line_Expanded
 276                  { exclusive
 277                  , inclusive =
 278                         getCompose $
 279                         snd $
 280                         Data.Traversable.mapAccumL
 281                          (\ms line ->
 282                                 let pamt = posting_amount $ gl_line_posting line in
 283                                 case ms of
 284                                  Nothing -> (Just pamt, line)
 285                                  Just s ->
 286                                         let ls = amount_add s pamt in
 287                                         ( Just ls
 288                                         , line{gl_line_sum=ls} )
 289                          ) Nothing $
 290                         Compose $
 291                         Data.Map.foldr
 292                          (Data.Map.unionWith (><) . inclusive . from_value)
 293                          exclusive nodes
 294                  })
 295          gl