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