]> Git — Sourcephile - comptalang.git/blob - cli/Hcompta/CLI/Convert.hs
Refactor hcompta-lib.
[comptalang.git] / cli / Hcompta / CLI / Convert.hs
1 {-# LANGUAGE ConstraintKinds #-}
2 {-# LANGUAGE ExistentialQuantification #-}
3 {-# LANGUAGE FlexibleContexts #-}
4 {-# LANGUAGE FlexibleInstances #-}
5 {-# LANGUAGE MultiParamTypeClasses #-}
6 {-# LANGUAGE NamedFieldPuns #-}
7 {-# LANGUAGE OverloadedStrings #-}
8 {-# LANGUAGE Rank2Types #-}
9 {-# LANGUAGE RecordWildCards #-}
10 {-# LANGUAGE ScopedTypeVariables #-}
11 {-# LANGUAGE TypeFamilies #-}
12 module Hcompta.CLI.Convert where
13
14 import Control.Applicative (Const(..))
15 import Data.Bool (Bool(..), not)
16 import qualified Data.Char as Char
17 import Data.Decimal (Decimal)
18 import Data.Function (($), (.), id)
19 import Data.Functor (Functor(..), (<$>))
20 import qualified Data.List as List
21 import Data.List.NonEmpty (NonEmpty(..))
22 import Data.Map.Strict (Map)
23 import qualified Data.Map.Strict as Map
24 import Data.Maybe (Maybe(..))
25 import Data.Monoid (Monoid(..))
26 import Data.Ord (Ord(..))
27 import Data.Sequence (Seq)
28 import Data.Text (Text)
29 import qualified Data.Text as Text
30 import Data.TreeMap.Strict (TreeMap)
31 import qualified Data.TreeMap.Strict as TreeMap
32
33 import qualified Hcompta as H
34 import qualified Hcompta.JCC as JCC
35 import qualified Hcompta.Ledger as Ledger
36
37 import qualified Hcompta.Lib.Strict as Strict
38
39 -- * Class 'Convert'
40
41 -- | Generic class dedicated to transform any type
42 -- into another one encoding more or less
43 -- the same data.
44 class Convert from to where
45 convert :: from -> to
46
47 instance Convert () () where
48 convert = id
49
50 -- Journal
51 instance
52 ( Convert ledger jcc
53 , Monoid jcc
54 , Monoid ledger
55 )
56 => Convert (Ledger.Journal ledger) (JCC.Journal jcc) where
57 convert Ledger.Journal{..} =
58 JCC.Journal
59 { JCC.journal_amount_styles = convert journal_amount_styles
60 , JCC.journal_chart = convert journal_chart
61 , JCC.journal_files
62 , JCC.journal_includes = convert <$> journal_includes
63 , JCC.journal_last_read_time
64 , JCC.journal_content = convert journal_content
65 }
66 instance
67 ( Convert jcc ledger
68 , Monoid jcc
69 , Monoid ledger
70 )
71 => Convert (JCC.Journal jcc) (Ledger.Journal ledger) where
72 convert JCC.Journal{..} =
73 Ledger.Journal
74 { Ledger.journal_amount_styles = convert journal_amount_styles
75 , Ledger.journal_chart = convert journal_chart
76 , Ledger.journal_files
77 , Ledger.journal_includes = convert <$> journal_includes
78 , Ledger.journal_last_read_time
79 , Ledger.journal_content = convert journal_content
80 }
81 instance Convert ledger jcc
82 => Convert
83 (H.Journal ledger)
84 (H.Journal jcc)
85 where
86 convert (H.Journal j) =
87 H.Journal $
88 convert <$>
89 Map.mapKeysMonotonic convert j
90
91 -- Unit
92 instance Convert Ledger.Unit JCC.Unit where
93 convert (Ledger.Unit u) =
94 JCC.Unit $
95 Text.map
96 (\c -> case Char.generalCategory c of
97 Char.CurrencySymbol -> c
98 Char.LowercaseLetter -> c
99 Char.ModifierLetter -> c
100 Char.OtherLetter -> c
101 Char.TitlecaseLetter -> c
102 Char.UppercaseLetter -> c
103 _ -> '_') u
104 instance Convert JCC.Unit Ledger.Unit where
105 convert (JCC.Unit u) =
106 Ledger.Unit u
107
108 -- Account
109 instance Convert H.Account_Anchor H.Account_Anchor where
110 convert = id
111 instance Convert H.Account_Tags H.Account_Tags where
112 convert = id
113
114 -- Amount Style
115 instance Convert Ledger.Amount_Styles JCC.Amount_Styles where
116 convert (Ledger.Amount_Styles sty) =
117 JCC.Amount_Styles $ convert sty
118 instance Convert JCC.Amount_Styles Ledger.Amount_Styles where
119 convert (JCC.Amount_Styles sty) =
120 Ledger.Amount_Styles $ convert sty
121 instance Convert Ledger.Amount_Style JCC.Amount_Style where
122 convert Ledger.Amount_Style{..} =
123 JCC.Amount_Style
124 { JCC.amount_style_fractioning
125 , JCC.amount_style_grouping_integral =
126 (<$> amount_style_grouping_integral) $
127 \(Ledger.Amount_Style_Grouping c l) ->
128 JCC.Amount_Style_Grouping c l
129 , JCC.amount_style_grouping_fractional =
130 (<$> amount_style_grouping_fractional) $
131 \(Ledger.Amount_Style_Grouping c l) ->
132 JCC.Amount_Style_Grouping c l
133 , JCC.amount_style_unit_side =
134 (<$> amount_style_unit_side) $ \s ->
135 case s of
136 Ledger.Amount_Style_Side_Left -> JCC.Amount_Style_Side_Left
137 Ledger.Amount_Style_Side_Right -> JCC.Amount_Style_Side_Right
138 , JCC.amount_style_unit_spaced
139 }
140 instance Convert JCC.Amount_Style Ledger.Amount_Style where
141 convert JCC.Amount_Style{..} =
142 Ledger.Amount_Style
143 { Ledger.amount_style_fractioning
144 , Ledger.amount_style_grouping_integral =
145 (<$> amount_style_grouping_integral) $
146 \(JCC.Amount_Style_Grouping c l) ->
147 Ledger.Amount_Style_Grouping c l
148 , Ledger.amount_style_grouping_fractional =
149 (<$> amount_style_grouping_fractional) $
150 \(JCC.Amount_Style_Grouping c l) ->
151 Ledger.Amount_Style_Grouping c l
152 , Ledger.amount_style_unit_side =
153 (<$> amount_style_unit_side) $ \s ->
154 case s of
155 JCC.Amount_Style_Side_Left -> Ledger.Amount_Style_Side_Left
156 JCC.Amount_Style_Side_Right -> Ledger.Amount_Style_Side_Right
157 , Ledger.amount_style_unit_spaced
158 }
159
160 -- Transaction
161 instance Convert Ledger.Transaction JCC.Transaction where
162 convert Ledger.Transaction{..} =
163 JCC.Transaction
164 { JCC.transaction_anchors = mempty
165 , JCC.transaction_comments =
166 List.filter (not . Text.all Char.isSpace) $
167 Ledger.comments_without_tags $
168 mappend
169 transaction_comments_before
170 transaction_comments_after
171 , JCC.transaction_dates
172 , JCC.transaction_postings = (convert <$>) <$> transaction_postings
173 , JCC.transaction_sourcepos
174 , JCC.transaction_tags =
175 (case transaction_code of
176 t | Text.null t -> id
177 t -> H.transaction_tag_cons (H.transaction_tag ("Code":|[]) t)
178 ) $
179 if transaction_status
180 then H.transaction_tag_cons
181 (H.transaction_tag ("Status":|[]) "")
182 transaction_tags
183 else transaction_tags
184 , JCC.transaction_wording
185 }
186 instance Convert JCC.Transaction Ledger.Transaction where
187 convert JCC.Transaction{..} =
188 let H.Transaction_Tags (H.Tags tags) = transaction_tags in
189 Ledger.Transaction
190 { Ledger.transaction_code = mconcat $ Map.findWithDefault [""] ("Code":|[]) tags
191 , Ledger.transaction_comments_after = mempty
192 , Ledger.transaction_comments_before = transaction_comments
193 , Ledger.transaction_dates
194 , Ledger.transaction_postings = (convert <$>) <$> transaction_postings
195 , Ledger.transaction_sourcepos
196 , Ledger.transaction_status =
197 case Map.lookup ("Status":|[]) tags of
198 Nothing -> False
199 Just _ -> True
200 , Ledger.transaction_tags =
201 H.Transaction_Tags $ H.Tags $
202 Map.delete ("Code":|[]) $
203 Map.delete ("Status":|[]) $
204 tags
205 , Ledger.transaction_wording
206 }
207
208 -- Posting
209 instance Convert Ledger.Posting JCC.Posting where
210 convert Ledger.Posting{..} =
211 JCC.Posting
212 { JCC.posting_account
213 , JCC.posting_account_anchor = Nothing
214 , JCC.posting_amounts =
215 convert <$>
216 Map.mapKeysMonotonic convert posting_amounts
217 , JCC.posting_anchors = mempty
218 , JCC.posting_comments =
219 List.filter (not . Text.all Char.isSpace) $
220 Ledger.comments_without_tags posting_comments
221 , JCC.posting_dates
222 , JCC.posting_sourcepos
223 , JCC.posting_tags =
224 if posting_status
225 then H.posting_tag_cons
226 (H.Posting_Tag $ H.tag ("Status":|[]) "")
227 posting_tags
228 else posting_tags
229 }
230 instance Convert JCC.Posting Ledger.Posting where
231 convert JCC.Posting{..} =
232 let H.Posting_Tags (H.Tags tags) = posting_tags in
233 Ledger.Posting
234 { Ledger.posting_account
235 , Ledger.posting_amounts =
236 convert <$>
237 Map.mapKeysMonotonic convert posting_amounts
238 , Ledger.posting_comments
239 , Ledger.posting_dates
240 , Ledger.posting_status =
241 case Map.lookup ("Status":|[]) tags of
242 Nothing -> False
243 Just _ -> True
244 , Ledger.posting_sourcepos
245 , Ledger.posting_tags =
246 H.Posting_Tags $ H.Tags $
247 Map.delete ("Status":|[]) $
248 tags
249 }
250
251 -- Chart
252 instance Convert JCC.Chart Ledger.Chart where
253 convert JCC.Chart{..} =
254 Ledger.Chart
255 { Ledger.chart_accounts = chart_accounts
256 }
257 instance Convert Ledger.Chart JCC.Chart where
258 convert Ledger.Chart{..} =
259 JCC.Chart
260 { JCC.chart_accounts = chart_accounts
261 , JCC.chart_anchors = mempty
262 }
263 {-
264 instance Convert (Chart.Chart x) (Chart.Chart x) where
265 convert = id
266 instance
267 ( Convert (Chart.Chart a0) (Chart.Chart a1)
268 , Convert x y
269 ) => Convert (Chart.Charted a0 x) (Chart.Charted a1 y) where
270 convert (Chart.Charted a x) =
271 Chart.Charted (convert a) (convert x)
272 -}
273 {-
274 instance Convert (Chart.Chart JCC.Account) (Chart.Chart Ledger.Account) where
275 convert Chart.Chart
276 { Chart.chart_accounts
277 , Chart.chart_anchors
278 } =
279 Chart.Chart
280 { Chart.chart_accounts = convert chart_accounts
281 , Chart.chart_anchors = convert chart_anchors
282 }
283 -}
284
285 instance Convert x y => Convert (JCC.Charted x) (Ledger.Charted y) where
286 convert (JCC.Charted c x) =
287 Ledger.Charted (convert c) (convert x)
288
289 instance Convert x y => Convert (Ledger.Charted x) (JCC.Charted y) where
290 convert (Ledger.Charted c x) =
291 JCC.Charted (convert c) (convert x)
292
293 -- Balance
294 instance
295 ( Convert unit unit_
296 , Convert quantity quantity_
297 ) => Convert (H.Balance_by_Account_Sum unit quantity)
298 (H.Balance_by_Account_Sum unit_ quantity_) where
299 convert (H.Balance_by_Account_Sum m) =
300 H.Balance_by_Account_Sum $
301 convert <$>
302 Map.mapKeysMonotonic convert m
303
304 -- * GL
305
306 -- ** Class 'GL'
307 class
308 ( Convert (H.Account_Section (H.Posting_Account (H.Transaction_Posting x)))
309 (H.Account_Section (H.Posting_Account (H.Transaction_Posting y)))
310 ) => GL x y
311 instance GL JCC.Transaction Ledger.Transaction
312 instance GL Ledger.Transaction JCC.Transaction
313
314 instance GL ( JCC.Charted JCC.Transaction)
315 (Ledger.Charted Ledger.Transaction)
316 instance GL (Ledger.Charted Ledger.Transaction)
317 (JCC.Charted JCC.Transaction)
318
319 instance
320 ( GL x y
321 , GL_Line x y
322 , H.GL_Transaction x
323 , H.GL_Transaction y
324 , Convert x y
325 ) => Convert (H.GL x)
326 (H.GL y) where
327 convert (H.GL m)
328 = H.GL $ TreeMap.map_monotonic convert (convert <$>) m
329 -- NOTE: Date does not need to be converted,
330 -- thus avoid a useless Map.mapKeysMonotonic
331 -- from the Convert instance on Map.
332
333 -- *** Class 'GL_Line'
334
335 class
336 ( Convert (H.GL_Transaction_Line x)
337 (H.GL_Transaction_Line y)
338 , Convert (H.Transaction_Posting x)
339 (H.Transaction_Posting y)
340 , Convert (H.GL_Posting_Quantity (H.Transaction_Posting x))
341 (H.GL_Posting_Quantity (H.Transaction_Posting y))
342 ) => GL_Line x y
343 instance GL_Line JCC.Transaction Ledger.Transaction
344 instance GL_Line Ledger.Transaction JCC.Transaction
345
346 instance GL_Line ( JCC.Charted JCC.Transaction)
347 (Ledger.Charted Ledger.Transaction)
348 instance GL_Line (Ledger.Charted Ledger.Transaction)
349 (JCC.Charted JCC.Transaction)
350
351 instance
352 ( GL_Line x y
353 , H.GL_Transaction x
354 , H.GL_Transaction y
355 , Convert x y
356 ) => Convert (H.GL_Line x)
357 (H.GL_Line y) where
358 convert H.GL_Line{..} =
359 H.GL_Line
360 { H.gl_line_transaction = convert gl_line_transaction
361 , H.gl_line_posting = convert gl_line_posting
362 , H.gl_line_sum = convert gl_line_sum
363 }
364
365 -- Class 'GL_Expanded'
366
367 instance
368 ( GL x y
369 , GL_Line x y
370 , H.GL_Transaction x
371 , H.GL_Transaction y
372 , Convert x y
373 ) => Convert (H.GL_Expanded x)
374 (H.GL_Expanded y) where
375 convert (H.GL_Expanded m)
376 = H.GL_Expanded $ convert m
377
378 -- Class 'GL_Line_Expanded'
379
380 instance
381 Convert x y
382 => Convert (Strict.Clusive x)
383 (Strict.Clusive y) where
384 convert Strict.Clusive{..} =
385 Strict.Clusive
386 { Strict.exclusive = convert exclusive
387 , Strict.inclusive = convert inclusive
388 }
389
390 -- Const
391 instance Convert x y
392 => Convert (Const x w) (Const y w_) where
393 convert (Const x) = Const $ convert x
394
395 -- Polarized
396 instance
397 Convert x y
398 => Convert (H.Polarized x)
399 (H.Polarized y) where
400 convert = (convert <$>)
401
402 -- Date
403 instance Convert H.Date H.Date where
404 convert = id
405
406 -- Quantity
407 instance Convert Decimal Decimal where
408 convert = id
409
410 -- Text
411 instance Convert Text Text where
412 convert = id
413
414 -- List
415 instance Convert x y => Convert [x] [y] where
416 convert = fmap convert
417 instance Convert x y => Convert (NonEmpty x) (NonEmpty y) where
418 convert = fmap convert
419
420 -- TreeMap
421
422 instance (Convert kx ky, Convert x y, Ord kx, Ord ky)
423 => Convert (TreeMap kx x) (TreeMap ky y) where
424 convert = TreeMap.map_monotonic convert convert
425
426 -- Map
427 instance (Convert kx ky, Convert x y, Ord kx)
428 => Convert (Map kx x) (Map ky y) where
429 convert = Map.mapKeysMonotonic convert . fmap convert
430
431 -- Seq
432 instance Convert x y => Convert (Seq x) (Seq y) where
433 convert = fmap convert
434
435 -- * Stats
436
437 -- ** Class 'Stats'
438 class
439 ( Convert (H.Posting_Account (H.Transaction_Posting x))
440 (H.Posting_Account (H.Transaction_Posting y))
441 , Convert (H.Amount_Unit (H.Posting_Amount (H.Transaction_Posting x)))
442 (H.Amount_Unit (H.Posting_Amount (H.Transaction_Posting y)))
443 ) => Stats x y
444
445 instance Stats JCC.Transaction Ledger.Transaction
446 instance Stats Ledger.Transaction JCC.Transaction
447
448 instance Stats ( JCC.Charted JCC.Transaction)
449 (Ledger.Charted Ledger.Transaction)
450 instance Stats (Ledger.Charted Ledger.Transaction)
451 (JCC.Charted JCC.Transaction)
452
453 instance
454 ( Stats x y
455 , H.Stats_Transaction x
456 , H.Stats_Transaction y
457 ) => Convert (H.Stats x) (H.Stats y) where
458 convert s@H.Stats{..} =
459 s
460 { H.stats_accounts = Map.mapKeysMonotonic convert stats_accounts
461 , H.stats_units = Map.mapKeysMonotonic convert stats_units
462 }