{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} -- FIXME: to be removed when dropping GHC-7.6 support -- | General Ledger module Hcompta.GL where -- General Ledger import Control.Applicative (Const(..)) import Control.Exception (assert) import Data.Data import qualified Data.Foldable -- import Data.Foldable (Foldable) import Data.Functor.Compose (Compose(..)) import qualified Data.Sequence import Data.Sequence (Seq, (><), (|>), ViewR(..)) import qualified Data.Strict.Maybe as Strict import qualified Data.Traversable import qualified Data.Map.Strict as Data.Map import Data.Map.Strict (Map) import Data.Typeable () import qualified Hcompta.Account as Account import Hcompta.Account (Account) import Hcompta.Date (Date) import Hcompta.Lib.Consable import qualified Hcompta.Lib.TreeMap as TreeMap import Hcompta.Lib.TreeMap (TreeMap) -- * Requirements' interface -- ** Class 'Amount' class ( Data (Amount_Unit a) , Data a , Eq a , Ord (Amount_Unit a) , Show (Amount_Unit a) , Show a , Typeable (Amount_Unit a) ) => Amount a where type Amount_Unit a amount_add :: a -> a -> a -- ** Class 'Posting' -- | A 'posting' used to produce a 'GL' -- must be an instance of this class. class Amount (Posting_Amount p) => Posting p where type Posting_Amount p posting_account :: p -> Account posting_amount :: p -> Posting_Amount p instance (Amount amount) => Posting (Account, amount) where type Posting_Amount (Account, amount) = amount posting_account (x, _) = x posting_amount (_, x) = x -- ** Class 'Transaction' class ( Posting (Transaction_Posting t) , Data (Transaction_Posting t) , Eq (Transaction_Posting t) , Show (Transaction_Posting t) , Foldable (Transaction_Postings t) ) => Transaction t where type Transaction_Posting t type Transaction_Postings t :: * -> * transaction_date :: t -> Date transaction_postings :: t -> Transaction_Postings t (Transaction_Posting t) transaction_postings_filter :: (Transaction_Posting t -> Bool) -> t -> t {- NOTE: conflicting with the instance below. instance ( Posting posting , Data posting , Eq posting , Show posting ) => Transaction (Date, Map Account ([] posting)) where type Transaction_Posting (Date, Map Account ([] posting)) = posting type Transaction_Postings (Date, Map Account ([] posting)) = Compose (Map Account) [] transaction_date = fst transaction_postings = Compose . snd -} instance ( Posting posting , Data posting , Eq posting , Show posting ) => Transaction (Date, [posting]) where type Transaction_Posting (Date, [posting]) = posting type Transaction_Postings (Date, [posting]) = [] transaction_date = fst transaction_postings = snd transaction_postings_filter = fmap . filter -- * Type 'GL' newtype Transaction transaction => GL transaction = GL (TreeMap Account.Name (Map Date (Seq (GL_Line transaction)))) deriving instance ( Transaction transaction , Data transaction , Typeable transaction , Typeable GL_Line ) => Data (GL transaction) deriving instance ( Transaction transaction , Eq transaction ) => Eq (GL transaction) deriving instance ( Transaction transaction , Show transaction ) => Show (GL transaction) deriving instance Typeable1 GL -- FIXME: use 'Typeable' when dropping GHC-7.6 support instance Transaction transaction => Monoid (GL transaction) where mempty = empty mappend = union instance Transaction transaction => Consable (Const (GL transaction)) transaction where mcons t (Const !gl) = Const $ cons t gl instance ( Foldable foldable , Transaction transaction ) => Consable (Const (GL transaction)) (foldable transaction) where mcons ts (Const !gl) = Const $ Data.Foldable.foldr cons gl ts data Transaction transaction => GL_Line transaction = GL_Line { gl_line_transaction :: transaction , gl_line_posting :: Transaction_Posting transaction , gl_line_sum :: Posting_Amount (Transaction_Posting transaction) } deriving instance ( Transaction transaction , Data transaction , Typeable transaction , Typeable GL_Line ) => Data (GL_Line transaction) deriving instance ( Transaction transaction , Eq transaction ) => Eq (GL_Line transaction) deriving instance ( Transaction transaction , Show transaction ) => Show (GL_Line transaction) deriving instance Typeable1 GL_Line -- FIXME: use 'Typeable' when dropping GHC-7.6 support -- ** Constructors empty :: Transaction transaction => GL transaction empty = GL TreeMap.empty -- | Return the given 'GL' -- updated by the given 'Transaction'. cons :: Transaction transaction => transaction -> GL transaction -> GL transaction cons t (GL gl) = GL $ Data.Foldable.foldr ((\p -> let first_line = GL_Line { gl_line_transaction = t , gl_line_posting = p , gl_line_sum = posting_amount p } in let single = Data.Map.singleton (transaction_date t) $ Data.Sequence.singleton first_line in TreeMap.insert (\_new old -> let (nlt, leq, neq, ngt) = case Data.Map.splitLookup (transaction_date t) old of (olt, Nothing, ogt) | Data.Map.null olt -> (olt, first_line, Data.Sequence.singleton first_line, ogt) (olt, Nothing, ogt) -> let line = case Data.Sequence.viewr $ snd $ Data.Map.findMax olt of (_:>GL_Line{gl_line_sum = s}) -> first_line{gl_line_sum = amount_add s $ posting_amount p} _ -> first_line in (olt, line, Data.Sequence.singleton line, ogt) (olt, Just oeq, ogt) -> case Data.Sequence.viewr oeq of (_:>GL_Line{gl_line_sum = s}) -> let line = first_line{gl_line_sum = amount_add s $ posting_amount p} in (olt, line, oeq |> line, ogt) _ -> (olt, first_line, Data.Sequence.singleton first_line, ogt) in Data.Map.union nlt $ Data.Map.insert (transaction_date t) neq $ Data.Map.map (fmap (\l -> l{gl_line_sum = amount_add (gl_line_sum leq) $ gl_line_sum l})) ngt ) (posting_account p) single )) gl (transaction_postings t) union :: Transaction transaction => GL transaction -> GL transaction -> GL transaction union (GL gl0) (GL gl1) = GL $ TreeMap.union (Data.Map.unionWith mappend) gl0 gl1 -- * Type 'Expanded' -- | Descending propagation of 'Amount's accross 'Account's. type Expanded transaction = TreeMap Account.Name (GL_Line_Expanded transaction) data Transaction transaction => GL_Line_Expanded transaction = GL_Line_Expanded { exclusive :: Map Date (Seq (GL_Line transaction)) , inclusive :: Map Date (Seq (GL_Line transaction)) -- ^ 'amount_add' folded over 'exclusive' and 'inclusive' of 'Lib.TreeMap.node_descendants' } deriving instance ( Transaction transaction , Data transaction ) => Data (GL_Line_Expanded transaction) deriving instance ( Transaction transaction , Eq transaction ) => Eq (GL_Line_Expanded transaction) deriving instance ( Transaction transaction , Show transaction ) => Show (GL_Line_Expanded transaction) deriving instance Typeable1 GL_Line_Expanded -- FIXME: use 'Typeable' when dropping GHC-7.6 support -- | Return the given 'GL' with: -- -- * all missing 'Account.ascending' 'Account's inserted, -- -- * and every mapped 'GL_Line' -- added with any 'GL_Line' -- of the 'Account's for which it is 'Account.ascending'. expanded :: Transaction transaction => GL transaction -> Expanded transaction expanded (GL gl) = let from_value = Strict.fromMaybe (assert False undefined) . TreeMap.node_value in TreeMap.map_by_depth_first (\descendants value -> let nodes = TreeMap.nodes descendants in let exclusive = Strict.fromMaybe Data.Map.empty value in GL_Line_Expanded { exclusive , inclusive = getCompose $ snd $ Data.Traversable.mapAccumL (\ms line -> let pamt = posting_amount $ gl_line_posting line in case ms of Nothing -> (Just pamt, line) Just s -> let ls = amount_add s pamt in ( Just ls , line{gl_line_sum=ls} ) ) Nothing $ Compose $ Data.Map.foldr (Data.Map.unionWith (><) . inclusive . from_value) exclusive nodes }) gl