]> Git — Sourcephile - comptalang.git/blob - lib/Hcompta/GL.hs
Ajout : syntax/ledger.vim : ledgerChart.
[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.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.Name (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.Name (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