]> Git — Sourcephile - comptalang.git/blob - lib/Hcompta/Format/Ledger.hs
Modification : filtre dès la lecture pour moins de consommation mémoire.
[comptalang.git] / lib / Hcompta / Format / Ledger.hs
1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE MultiParamTypeClasses #-}
4 {-# LANGUAGE NamedFieldPuns #-}
5 {-# LANGUAGE OverloadedStrings #-}
6 {-# LANGUAGE TupleSections #-}
7 {-# LANGUAGE TypeFamilies #-}
8 module Hcompta.Format.Ledger where
9
10 -- import Control.Applicative (Const(..))
11 import Data.Data (Data(..))
12 -- import qualified Data.Foldable as Data.Foldable
13 import Data.Functor.Compose (Compose(..))
14 import qualified Data.List as Data.List
15 import Data.Map.Strict (Map)
16 import qualified Data.Map.Strict as Data.Map
17 import Data.Text (Text)
18 import Data.Typeable (Typeable)
19 import Text.Parsec.Pos (SourcePos, initialPos)
20
21 import Hcompta.Account (Account)
22 import Hcompta.Amount (Amount)
23 import qualified Hcompta.Amount as Amount
24 -- import Hcompta.Balance (Balance(..))
25 import qualified Hcompta.Balance as Balance
26 import Hcompta.Date (Date)
27 import qualified Hcompta.Date as Date
28 import qualified Hcompta.Filter as Filter
29 import Hcompta.Lib.Consable
30 import Hcompta.Lib.Parsec ()
31 -- import Hcompta.GL (GL(..))
32 import qualified Hcompta.GL as GL
33 import qualified Hcompta.Journal as Journal
34
35 type Code = Text
36 type Description = Text
37 type Status = Bool
38 type Comment = Text
39
40 -- * The 'Journal' type
41
42 data Consable ts t
43 => Journal ts t
44 = Journal
45 { journal_file :: FilePath
46 , journal_includes :: [Journal ts t]
47 , journal_last_read_time :: Date
48 , journal_transactions :: !(ts t)
49 , journal_unit_styles :: Map Amount.Unit Amount.Style
50 } deriving (Data, Eq, Show, Typeable)
51
52 journal :: Consable ts t => Journal ts t
53 journal =
54 Journal
55 { journal_file = ""
56 , journal_includes = []
57 , journal_last_read_time = Date.nil
58 , journal_transactions = mempty
59 , journal_unit_styles = Data.Map.empty
60 }
61
62 -- * The 'Transaction' type
63
64 data Transaction
65 = Transaction
66 { transaction_code :: Code
67 , transaction_comments_before :: [Comment]
68 , transaction_comments_after :: [Comment]
69 , transaction_dates :: (Date, [Date])
70 , transaction_description :: Description
71 , transaction_postings :: Posting_by_Account
72 , transaction_virtual_postings :: Posting_by_Account
73 , transaction_balanced_virtual_postings :: Posting_by_Account
74 , transaction_sourcepos :: SourcePos
75 , transaction_status :: Status
76 , transaction_tags :: Tag_by_Name
77 } deriving (Data, Eq, Show, Typeable)
78
79 transaction :: Transaction
80 transaction =
81 Transaction
82 { transaction_code = ""
83 , transaction_comments_before = []
84 , transaction_comments_after = []
85 , transaction_dates = (Date.nil, [])
86 , transaction_description = ""
87 , transaction_postings = mempty
88 , transaction_virtual_postings = mempty
89 , transaction_balanced_virtual_postings = mempty
90 , transaction_sourcepos = initialPos ""
91 , transaction_status = False
92 , transaction_tags = mempty
93 }
94
95 instance Filter.Transaction Transaction where
96 type Transaction_Posting Transaction = Posting
97 type Transaction_Postings Transaction = Compose [] (Compose (Map Account) [])
98 transaction_date = fst . transaction_dates
99 transaction_description = transaction_description
100 transaction_postings t =
101 Compose
102 [ Compose $ transaction_postings t
103 , Compose $ transaction_virtual_postings t
104 , Compose $ transaction_balanced_virtual_postings t
105 ]
106 transaction_tags = transaction_tags
107
108 instance Journal.Transaction Transaction where
109 transaction_date = fst . transaction_dates
110
111 {-
112 instance Filter.GL (GL.GL_Line Transaction) where
113 type GL_Amount (GL.GL_Line Transaction) = Amount
114 register_account = GL.posting_account . GL.register_line_posting
115 register_date = GL.transaction_date . GL.register_line_transaction
116 register_amount_positive = Amount.sum_positive . GL.posting_amount . GL.register_line_posting
117 register_amount_negative = Amount.sum_negative . GL.posting_amount . GL.register_line_posting
118 register_amount_balance = Amount.sum_balance . GL.posting_amount . GL.register_line_posting
119 register_sum_positive = Amount.sum_positive . GL.register_line_sum
120 register_sum_negative = Amount.sum_negative . GL.register_line_sum
121 register_sum_balance = Amount.sum_balance . GL.register_line_sum
122 -}
123
124 instance GL.Transaction Transaction where
125 type Transaction_Posting Transaction = Posting
126 type Transaction_Postings Transaction = Compose [] (Compose (Map Account) [])
127 transaction_date = fst . transaction_dates
128 transaction_postings t =
129 Compose
130 [ Compose $ transaction_postings t
131 , Compose $ transaction_virtual_postings t
132 , Compose $ transaction_balanced_virtual_postings t
133 ]
134 transaction_postings_filter f t =
135 t{ transaction_postings =
136 Data.Map.mapMaybe
137 (\p -> case filter f p of
138 [] -> Nothing
139 ps -> Just ps)
140 (transaction_postings t)
141 , transaction_virtual_postings =
142 Data.Map.mapMaybe
143 (\p -> case filter f p of
144 [] -> Nothing
145 ps -> Just ps)
146 (transaction_virtual_postings t)
147 , transaction_balanced_virtual_postings =
148 Data.Map.mapMaybe
149 (\p -> case filter f p of
150 [] -> Nothing
151 ps -> Just ps)
152 (transaction_balanced_virtual_postings t)
153 }
154
155 -- | Return a 'Data.Map.Map' associating
156 -- the given 'Transaction's with their respective 'Date'.
157 transaction_by_Date :: [Transaction] -> (Compose (Map Date) []) Transaction
158 transaction_by_Date =
159 Compose .
160 Data.Map.fromListWith (flip (++)) .
161 Data.List.map (\t -> (fst $ transaction_dates t, [t]))
162
163 -- * The 'Posting' type
164
165 data Posting
166 = Posting
167 { posting_account :: Account
168 , posting_amounts :: Map Amount.Unit Amount
169 , posting_comments :: [Comment]
170 , posting_dates :: [Date]
171 , posting_sourcepos :: SourcePos
172 , posting_status :: Bool
173 , posting_tags :: Tag_by_Name
174 } deriving (Data, Eq, Show, Typeable)
175
176 data Posting_Type
177 = Posting_Type_Regular
178 | Posting_Type_Virtual
179 | Posting_Type_Virtual_Balanced
180 deriving (Data, Eq, Read, Show, Typeable)
181
182 posting :: Account -> Posting
183 posting acct =
184 Posting
185 { posting_account = acct
186 , posting_amounts = Data.Map.empty
187 , posting_comments = []
188 , posting_dates = []
189 , posting_status = False
190 , posting_sourcepos = initialPos ""
191 , posting_tags = Data.Map.empty
192 }
193
194 instance
195 Balance.Posting Posting where
196 type Posting_Amount Posting = Amount.Sum Amount
197 posting_account = posting_account
198 posting_amounts = Data.Map.map Amount.sum . posting_amounts
199 posting_set_amounts amounts p =
200 p { posting_amounts=Data.Map.map Amount.sum_balance amounts }
201
202 instance Filter.Posting Posting where
203 type Posting_Amount Posting = Amount
204 posting_account = posting_account
205 posting_amounts = posting_amounts
206
207 instance GL.Posting Posting where
208 type Posting_Amount Posting = Amount.Sum (Map Amount.Unit Amount)
209 posting_account = posting_account
210 posting_amount = Amount.sum . posting_amounts
211
212 -- ** The 'Posting' mappings
213
214 type Posting_by_Account
215 = Map Account [Posting]
216
217 type Posting_by_Amount_and_Account
218 = Map Amount.By_Unit Posting_by_Account
219
220 type Posting_by_Signs_and_Account
221 = Map Amount.Signs Posting_by_Account
222
223 -- | Return a Data.'Data.Map.Map' associating the given 'Posting's with their respective 'Account'.
224 posting_by_Account :: [Posting] -> Posting_by_Account
225 posting_by_Account =
226 Data.Map.fromListWith (flip (++)) .
227 Data.List.map
228 (\p -> (posting_account p, [p]))
229
230 posting_by_Amount_and_Account :: Posting_by_Account -> Posting_by_Amount_and_Account
231 posting_by_Amount_and_Account =
232 Data.Map.foldlWithKey
233 (flip (\acct ->
234 Data.List.foldl
235 (flip (\p ->
236 Data.Map.insertWith
237 (Data.Map.unionWith (++))
238 (posting_amounts p)
239 (Data.Map.singleton acct [p])))))
240 Data.Map.empty
241
242 posting_by_Signs_and_Account :: Posting_by_Account -> Posting_by_Signs_and_Account
243 posting_by_Signs_and_Account =
244 Data.Map.foldlWithKey
245 (flip (\acct ->
246 Data.List.foldl
247 (flip (\p ->
248 Data.Map.insertWith
249 (Data.Map.unionWith (++))
250 (Amount.signs $ posting_amounts p)
251 (Data.Map.singleton acct [p])))))
252 Data.Map.empty
253
254 -- * The 'Tag' type
255
256 type Tag = (Tag_Name, Tag_Value)
257 type Tag_Name = Text
258 type Tag_Value = Text
259
260 type Tag_by_Name = Map Tag_Name [Tag_Value]
261
262 -- | Return a 'Data.Map.Map' associating the 'Value's of the given 'Tag's with their respective 'Name'.
263 tag_by_Name :: [Tag] -> Tag_by_Name
264 tag_by_Name =
265 Data.Map.fromListWith (flip (++)) .
266 Data.List.map (\(n, v) -> (n, [v]))
267
268 -- Instances 'Consable'
269
270 -- 'Transaction's
271 instance Consable [] Transaction where
272 mcons = (:)
273
274 {-
275 -- 'Balance'
276 instance Consable (Const
277 ( Balance (Amount.Sum Amount)
278 , Filter.Simplified (Filter.Filter_Bool (Filter.Filter_Transaction Transaction))
279 , Filter.Simplified (Filter.Filter_Bool (Filter.Filter_Posting Posting))
280 ))
281 Transaction where
282 mcons t c@(Const (bal, ft, fp)) =
283 if Filter.test ft t
284 then Const . (, ft, fp) $
285 balance (Compose $ transaction_postings t) $
286 balance (Compose $ transaction_virtual_postings t) $
287 balance (Compose $ transaction_balanced_virtual_postings t) $
288 bal
289 else c
290 where balance =
291 flip $ Data.Foldable.foldr $ \p ->
292 if Filter.test fp p
293 then Balance.balance
294 ( posting_account p
295 , Balance.Account_Sum $ Data.Map.map Amount.sum (posting_amounts p)
296 )
297 else id
298
299 -- 'Balance.Balance_by_Account'
300 instance Consable (Const
301 ( Balance.Balance_by_Account (Amount.Sum Amount) ))
302 Transaction where
303 mcons t (Const bal) =
304 (\(Const b) -> Const b) $
305 mcons (Compose $ transaction_postings t) $
306 mcons (Compose $ transaction_virtual_postings t) $
307 mcons (Compose $ transaction_balanced_virtual_postings t) $
308 Const bal
309
310 -- 'Balance.Balance_by_Unit'
311 instance Consable (Const
312 ( Balance.Balance_by_Unit (Amount.Sum Amount) ))
313 Transaction where
314 mcons t (Const ts) = Const $
315 Data.Foldable.foldl' (flip Balance.by_unit)
316 ts (Compose $ transaction_postings t)
317 -}