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