]> Git — Sourcephile - comptalang.git/blob - lib/Hcompta/GL.hs
Ajout : GNUmakefile : stats.
[comptalang.git] / 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