1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE FlexibleContexts #-}
3 {-# LANGUAGE FlexibleInstances #-}
4 {-# LANGUAGE NamedFieldPuns #-}
5 {-# LANGUAGE StandaloneDeriving #-}
6 {-# LANGUAGE TypeFamilies #-}
7 {-# OPTIONS_GHC -fno-warn-deprecations #-} -- FIXME: to be removed when dropping GHC-7.6 support
9 module Hcompta.GL where -- General Ledger
11 import Control.Exception (assert)
13 import qualified Data.Foldable
14 -- import Data.Foldable (Foldable)
15 import Data.Functor.Compose (Compose(..))
16 import Data.Maybe (fromMaybe)
17 import qualified Data.Sequence
18 import Data.Sequence (Seq, (><), (|>), ViewR(..))
19 import qualified Data.Traversable
20 import qualified Data.Map.Strict as Data.Map
21 import Data.Map.Strict (Map)
22 import Data.Typeable ()
24 import qualified Hcompta.Account as Account
25 import Hcompta.Account (Account)
26 import Hcompta.Date (Date)
27 import qualified Hcompta.Lib.TreeMap as TreeMap
28 import Hcompta.Lib.TreeMap (TreeMap)
30 -- * Requirements' interface
34 ( Data (Amount_Unit a)
38 , Show (Amount_Unit a)
40 , Typeable (Amount_Unit a)
43 amount_add :: a -> a -> a
47 -- | A 'posting' used to produce a 'GL'
48 -- must be an instance of this class.
49 class Amount (Posting_Amount p)
52 posting_account :: p -> Account
53 posting_amount :: p -> Posting_Amount p
55 instance (Amount amount)
56 => Posting (Account, amount)
58 type Posting_Amount (Account, amount) = amount
59 posting_account (x, _) = x
60 posting_amount (_, x) = x
62 -- ** Class 'Transaction'
65 ( Posting (Transaction_Posting t)
66 , Data (Transaction_Posting t)
67 , Eq (Transaction_Posting t)
68 , Show (Transaction_Posting t)
69 , Foldable (Transaction_Postings t)
70 ) => Transaction t where
71 type Transaction_Posting t
72 type Transaction_Postings t :: * -> *
73 transaction_date :: t -> Date
74 transaction_postings :: t -> Transaction_Postings t (Transaction_Posting t)
81 ) => Transaction (Date, Map Account ([] posting))
83 type Transaction_Posting (Date, Map Account ([] posting)) = posting
84 type Transaction_Postings (Date, Map Account ([] posting)) = Compose (Map Account) []
85 transaction_date = fst
86 transaction_postings = Compose . snd
90 newtype Transaction transaction
92 = GL (TreeMap Account.Name (Map Date (Seq (GL_Line transaction))))
93 deriving instance ( Transaction transaction
95 , Typeable transaction
97 ) => Data (GL transaction)
98 deriving instance ( Transaction transaction
100 ) => Eq (GL transaction)
101 deriving instance ( Transaction transaction
103 ) => Show (GL transaction)
104 deriving instance Typeable1 GL
105 -- FIXME: use 'Typeable' when dropping GHC-7.6 support
108 Transaction transaction
109 => GL_Line transaction
111 { gl_line_transaction :: transaction
112 , gl_line_posting :: Transaction_Posting transaction
113 , gl_line_sum :: Posting_Amount (Transaction_Posting transaction)
115 deriving instance ( Transaction transaction
117 , Typeable transaction
119 ) => Data (GL_Line transaction)
120 deriving instance ( Transaction transaction
122 ) => Eq (GL_Line transaction)
123 deriving instance ( Transaction transaction
125 ) => Show (GL_Line transaction)
126 deriving instance Typeable1 GL_Line
127 -- FIXME: use 'Typeable' when dropping GHC-7.6 support
132 :: Transaction transaction
134 nil = GL TreeMap.empty
136 -- | Return the given 'GL'
137 -- updated by the given 'Transaction'.
139 :: Transaction transaction
143 general_ledger t (GL gl) =
149 { gl_line_transaction = t
150 , gl_line_posting = p
151 , gl_line_sum = posting_amount p
154 Data.Map.singleton (transaction_date t) $
155 Data.Sequence.singleton first_line in
158 let (nlt, leq, neq, ngt) =
159 case Data.Map.splitLookup (transaction_date t) old of
160 (olt, Nothing, ogt) | Data.Map.null olt ->
161 (olt, first_line, Data.Sequence.singleton first_line, ogt)
162 (olt, Nothing, ogt) ->
164 case Data.Sequence.viewr $ snd $ Data.Map.findMax olt of
165 (_:>GL_Line{gl_line_sum = s}) ->
166 first_line{gl_line_sum = amount_add s $ posting_amount p}
168 in (olt, line, Data.Sequence.singleton line, ogt)
169 (olt, Just oeq, ogt) ->
170 case Data.Sequence.viewr oeq of
171 (_:>GL_Line{gl_line_sum = s}) ->
172 let line = first_line{gl_line_sum = amount_add s $ posting_amount p} in
173 (olt, line, oeq |> line, ogt)
174 _ -> (olt, first_line, Data.Sequence.singleton first_line, ogt)
177 Data.Map.insert (transaction_date t) neq $
178 Data.Map.map (fmap (\l -> l{gl_line_sum =
179 amount_add (gl_line_sum leq) $
186 (transaction_postings t)
190 -- | Descending propagation of 'Amount's accross 'Account's.
191 type Expanded transaction
192 = TreeMap Account.Name (GL_Line_Expanded transaction)
193 data Transaction transaction
194 => GL_Line_Expanded transaction
196 { exclusive :: Map Date (Seq (GL_Line transaction))
197 , inclusive :: Map Date (Seq (GL_Line transaction)) -- ^ 'amount_add' folded over 'exclusive' and 'inclusive' of 'Lib.TreeMap.node_descendants'
199 deriving instance ( Transaction transaction
201 ) => Data (GL_Line_Expanded transaction)
202 deriving instance ( Transaction transaction
204 ) => Eq (GL_Line_Expanded transaction)
205 deriving instance ( Transaction transaction
207 ) => Show (GL_Line_Expanded transaction)
208 deriving instance Typeable1 GL_Line_Expanded
209 -- FIXME: use 'Typeable' when dropping GHC-7.6 support
211 -- | Return the given 'GL' with:
213 -- * all missing 'Account.ascending' 'Account's inserted,
215 -- * and every mapped 'GL_Line'
216 -- added with any 'GL_Line'
217 -- of the 'Account's for which it is 'Account.ascending'.
219 :: Transaction transaction
221 -> Expanded transaction
223 let from_value = fromMaybe (assert False undefined) . TreeMap.node_value in
224 TreeMap.map_by_depth_first
225 (\descendants value ->
226 let nodes = TreeMap.nodes descendants in
227 let exclusive = fromMaybe Data.Map.empty value in
233 Data.Traversable.mapAccumL
235 let pamt = posting_amount $ gl_line_posting line in
237 Nothing -> (Just pamt, line)
239 let ls = amount_add s pamt in
241 , line{gl_line_sum=ls} )
245 (Data.Map.unionWith (><) . inclusive . from_value)