]> Git — Sourcephile - comptalang.git/blob - lcc/Hcompta/LCC/Write/Compta.hs
Remove cli/
[comptalang.git] / lcc / Hcompta / LCC / Write / Compta.hs
1 {-# LANGUAGE NoMonomorphismRestriction #-}
2 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
3 module Hcompta.LCC.Write.Compta where
4
5 import Control.Monad (Monad(..))
6 import Data.Bool
7 import Data.Char (Char)
8 import Data.Decimal
9 import Data.Eq (Eq(..))
10 import Data.Foldable (Foldable(..))
11 import Data.Function (($), (.), flip, id)
12 import Data.Functor ((<$>))
13 import Data.Functor.Compose (Compose(..))
14 import Data.Map.Strict (Map)
15 import Data.Maybe (Maybe(..), fromMaybe)
16 import Data.Monoid (Monoid(..))
17 import Data.Ord (Ord(..))
18 import Data.Semigroup (Semigroup(..))
19 import Data.Tuple (fst)
20 import GHC.Exts (Int(..))
21 import Prelude (Integer, Num(..), RealFrac(..), Show(..), Integral(..), fromIntegral)
22 import System.IO (IO)
23 import qualified Data.ByteString as BS
24 import qualified Data.Char as Char
25 import qualified Data.List as L
26 import qualified Data.Map.Strict as Map
27 import qualified Data.MonoTraversable as MT
28 import qualified Data.NonNull as NonNull
29 import qualified Data.Strict as S
30 import qualified Data.Text as Text
31 import qualified Data.Text.Encoding as Enc
32 import qualified Data.TreeMap.Strict as TreeMap
33
34 import qualified Language.Symantic.Document as D
35
36 import qualified Hcompta as H
37
38 import Hcompta.LCC.Account
39 import Hcompta.LCC.Amount
40 import Hcompta.LCC.Chart
41 import Hcompta.LCC.Compta
42 import Hcompta.LCC.IO
43 import Hcompta.LCC.Journal
44 import Hcompta.LCC.Name
45 import Hcompta.LCC.Posting
46 import Hcompta.LCC.Tag
47 import Hcompta.LCC.Transaction
48 import qualified Hcompta.LCC.Read.Compta as G
49
50 -- * Class 'Writable'
51 class Writable d a where
52 write :: a -> d
53 -- widthWrite :: forall d a. Writable d a => a -> Integer
54 widthWrite = D.width . D.dim . write
55
56 -- import Debug.Trace (trace)
57 -- dbg msg x = trace (msg <> " = " <> show x) x
58
59 -- * Type 'Context_Write'
60 data Context_Write
61 = Context_Write
62 { context_write_account_ref :: Bool
63 , context_write_amounts :: Style_Amounts
64 , context_write_width_acct_amt :: Int
65 }
66
67 context_write :: Context_Write
68 context_write =
69 Context_Write
70 { context_write_account_ref = True
71 , context_write_amounts = Style_Amounts Map.empty
72 , context_write_width_acct_amt = 0
73 }
74
75 instance (D.Doc_Text d, D.Doc_Color d) =>
76 Writable d Date where
77 write dat =
78 let (y, mo, d) = H.gregorianOf dat in
79 (if y == 0 then D.empty else D.integer y <> sep G.char_ymd_sep) <>
80 int2 mo <>
81 sep G.char_ymd_sep <> int2 d <>
82 (case H.todOf dat of
83 (0, 0, 0) -> D.empty
84 (h, m, s) ->
85 sep '_' <> int2 h <>
86 sep ':' <> int2 m <>
87 (case s of
88 0 -> D.empty
89 _ -> sep ':' <>
90 (if s < 10 then D.charH '0' else D.empty) <>
91 D.integer ((truncate s::Integer))))
92 where
93 int2 i = (if i < 10 then D.charH '0' else D.empty) <> D.int i
94 sep = D.blacker . D.charH
95 instance (D.Doc_Text d, D.Doc_Color d, Monoid d) =>
96 Writable d Account where
97 write acct =
98 (`MT.ofoldMap` acct) $ \a ->
99 D.blacker (D.charH G.char_account_sep) <>
100 write a
101 instance D.Doc_Text d =>
102 Writable d NameAccount where
103 write = D.textH . unName
104 instance (D.Doc_Text d, D.Doc_Color d) =>
105 Writable d Tag_Path where
106 write (Tag_Path path) =
107 D.catH $
108 (:) (D.yellower $ D.charH G.char_account_tag_prefix) $
109 L.intersperse
110 (D.yellower $ D.charH G.char_tag_sep)
111 (D.textH . unName <$> NonNull.toNullable path)
112 instance (D.Doc_Text d, D.Doc_Color d) =>
113 Writable d Account_Tag where
114 write (Account_Tag (Tag (Tag_Path path) (Tag_Data value))) =
115 D.catH (
116 (:) (D.yellower $ D.charH G.char_account_tag_prefix) $
117 L.intersperse
118 (D.yellower $ D.charH G.char_tag_sep)
119 (D.textH . unName <$> NonNull.toNullable path) ) <>
120 if Text.null value
121 then D.empty
122 else
123 D.yellower (D.charH G.char_tag_data_prefix) <>
124 D.textH value
125 instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d) =>
126 Writable d (Styled_Amount Amount) where
127 write
128 ( sty@Style_Amount
129 { style_amount_unit_side = uside
130 , style_amount_unit_spaced = uspaced
131 }
132 , Amount u q
133 ) =
134 case uside of
135 S.Just L ->
136 write u <>
137 case uspaced of
138 S.Just True | not (H.null u) -> D.space
139 _ -> D.empty
140 _ -> D.empty
141 <> write (sty, q)
142 <> case uside of
143 S.Just R ->
144 (case uspaced of
145 S.Just True | not (H.null u) -> D.space
146 _ -> D.empty) <>
147 write u
148 S.Nothing ->
149 (case uspaced of
150 S.Just True | not (H.null u) -> D.space
151 _ -> D.empty) <>
152 write u
153 _ -> D.empty
154 instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d) =>
155 Writable d Unit where
156 write (Unit t) =
157 D.yellow $
158 if Text.all
159 (\c -> case Char.generalCategory c of
160 Char.CurrencySymbol -> True
161 Char.LowercaseLetter -> True
162 Char.ModifierLetter -> True
163 Char.OtherLetter -> True
164 Char.TitlecaseLetter -> True
165 Char.UppercaseLetter -> True
166 _ -> False
167 ) t
168 then D.textH t
169 else D.dquote $ D.textH t
170 instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d) =>
171 Writable d (Styled_Amount Quantity) where
172 write
173 ( Style_Amount
174 { style_amount_fractioning
175 , style_amount_grouping_integral
176 , style_amount_grouping_fractional
177 }
178 , qty ) = do
179 let Decimal e n = qty
180 let num = show $ abs n
181 let sign = D.bold $ D.yellow $ D.textH (if n < 0 then "-" else "")
182 if e == 0
183 then sign <> D.bold (D.blue $ D.stringH num)
184 else do
185 let num_len = L.length num
186 let padded =
187 L.concat
188 [ L.replicate (fromIntegral e + 1 - num_len) '0'
189 , num
190 -- , replicate (fromIntegral precision - fromIntegral e) '0'
191 ]
192 let (int, frac) = L.splitAt (max 1 (num_len - fromIntegral e)) padded
193 let default_fractioning =
194 L.head $
195 del_grouping_sep style_amount_grouping_integral $
196 del_grouping_sep style_amount_grouping_fractional $
197 ['.', ',']
198 sign <>
199 D.bold (D.blue $
200 D.stringH (S.maybe id
201 (\g -> L.reverse . group g . L.reverse)
202 style_amount_grouping_integral $ int) <>
203 D.yellow (D.charH (S.fromMaybe default_fractioning style_amount_fractioning)) <>
204 D.stringH (S.maybe id group style_amount_grouping_fractional frac))
205 where
206 group :: Style_Amount_Grouping -> [Char] -> [Char]
207 group (Style_Amount_Grouping sep sizes_) =
208 L.concat . L.reverse .
209 L.map L.reverse . fst .
210 L.foldl'
211 (flip (\digit x -> case x of
212 ([], sizes) -> ([[digit]], sizes)
213 (digits:groups, []) -> ((digit:digits):groups, [])
214 (digits:groups, curr_sizes@(size:sizes)) ->
215 if L.length digits < size
216 then ( (digit:digits):groups, curr_sizes)
217 else ([digit]:[sep]:digits:groups, if L.null sizes then curr_sizes else sizes)
218 ))
219 ([], sizes_)
220 del_grouping_sep grouping =
221 case grouping of
222 S.Just (Style_Amount_Grouping sep _) -> L.delete sep
223 _ -> id
224 instance (D.Doc_Text d, D.Doc_Color d) =>
225 Writable d Comment where
226 write (Comment com) =
227 D.cyan $
228 D.charH G.char_comment_prefix
229 <> (case Text.uncons com of
230 Just (c, _) | not $ Char.isSpace c -> D.space
231 _ -> D.empty)
232 <> D.textH com
233 instance (D.Doc_Text d, D.Doc_Color d) =>
234 Writable d (d, [Comment]) where
235 write (prefix, com) =
236 D.catH $
237 L.intersperse D.eol $
238 (\c -> prefix <> write c) <$> com
239 instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d) =>
240 Writable d (Context_Write, Posting) where
241 write (ctx, Posting
242 { posting_account
243 , posting_account_ref
244 , posting_amounts
245 , posting_comments
246 -- , posting_dates
247 -- , posting_tags
248 }) =
249 let d_indent = D.spaces 2 in
250 d_indent <>
251 let (d_acct, w_acct) =
252 case posting_account_ref of
253 S.Just (a S.:!: sa) | context_write_account_ref ctx ->
254 ( write a <> S.maybe D.empty write sa
255 , widthWrite a + S.maybe 0 widthWrite sa )
256 _ -> (write posting_account, widthWrite posting_account) in
257 (case posting_amounts of
258 Amounts amts | Map.null amts -> d_acct
259 Amounts amts ->
260 fromMaybe D.empty $
261 Map.foldlWithKey
262 (\mdoc unit qty -> Just $
263 let amt = styled_amount (context_write_amounts ctx) $ Amount unit qty in
264 let pad = max 0 $ context_write_width_acct_amt ctx - (w_acct + widthWrite amt) in
265 (case mdoc of
266 Nothing -> D.empty
267 Just doc -> doc <> D.eol <> d_indent) <>
268 d_acct <> D.spaces pad <> D.space <> write amt
269 ) Nothing amts) <>
270 (case posting_comments of
271 [] -> D.empty
272 [c] -> D.space <> write c
273 _ -> D.eol <> write (d_indent <> D.space :: d, posting_comments))
274 instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d) =>
275 Writable d (Context_Write, Transaction) where
276 write (ctx,
277 txn@Transaction
278 { transaction_comments
279 , transaction_dates
280 , transaction_wording = Wording transaction_wording
281 , transaction_postings = Postings transaction_postings
282 , transaction_tags = Transaction_Tags (Tags tags)
283 }) =
284 let ctx' = ctx { context_write_width_acct_amt =
285 let w = context_write_width_acct_amt ctx in
286 if w == 0
287 then w_Transaction ctx txn
288 else w } in
289 D.catH (
290 L.intersperse
291 (D.charH G.char_transaction_date_sep)
292 (write <$> NonNull.toNullable transaction_dates)) <>
293 (case transaction_wording of
294 "" -> D.empty
295 _ -> D.space <> D.magenta (D.textH transaction_wording)) <>
296 D.eol <>
297 (case transaction_comments of
298 [] -> D.empty
299 _ -> write (D.space :: d, transaction_comments) <> D.eol) <>
300 TreeMap.foldr_with_Path
301 (\path -> flip $
302 foldr (\value -> (<>) (D.spaces 2 <>
303 write (Transaction_Tag (Tag (Tag_Path path) value)) <> D.eol)))
304 D.empty tags <>
305 D.catV (write . (ctx',) <$> Compose transaction_postings)
306 instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d) =>
307 Writable d (Context_Write, Map Date [Transaction]) where
308 write (ctx, txns) =
309 let ctx' = ctx{context_write_width_acct_amt =
310 foldr (max . w_Transaction ctx) 0 $ Compose txns} in
311 fromMaybe D.empty $
312 foldl (\mdoc txn -> Just $
313 write (ctx', txn) <>
314 case mdoc of
315 Nothing -> D.eol
316 Just doc -> D.eol <> D.eol <> doc
317 ) Nothing (Compose txns)
318 instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d) =>
319 Writable d Transaction_Tag where
320 write (Transaction_Tag (Tag (Tag_Path path) (Tag_Data value))) =
321 D.catH (
322 (:) (D.yellower $ D.charH G.char_tag_prefix) $
323 L.intersperse
324 (D.yellower $ D.charH G.char_tag_sep)
325 (D.bold . D.textH . unName <$> NonNull.toNullable path)) <>
326 if Text.null value
327 then D.empty
328 else D.yellower (D.charH G.char_tag_data_prefix) <> D.textH value
329 instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d, Writable d (ctx, j)) =>
330 Writable d (ctx, Journal j) where
331 write (ctx, jnl) = write (ctx, journal_content jnl)
332 instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d, Writable d (ctx, j)) =>
333 Writable d (ctx, Journals j) where
334 write (ctx, Journals js) =
335 Map.foldl
336 (\doc j@Journal{journal_file=PathFile jf} ->
337 doc <>
338 write (Comment $ Text.pack jf) <> D.eol <>
339 D.eol <> write (ctx, j)
340 ) D.empty js
341 instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d) =>
342 Writable d Chart where
343 write =
344 TreeMap.foldl_with_Path
345 (\doc acct (Account_Tags (Tags ca)) ->
346 doc <>
347 write (H.to acct :: Account) <> D.eol <>
348 TreeMap.foldl_with_Path
349 (\doc' tp tvs ->
350 doc' <>
351 foldl'
352 (\doc'' tv ->
353 doc'' <> D.spaces 2 <>
354 write (Account_Tag (Tag (Tag_Path tp) tv)) <>
355 D.eol)
356 D.empty
357 tvs)
358 D.empty
359 ca
360 ) D.empty .
361 chart_accounts
362 instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d) =>
363 Writable d Terms where
364 write (ts::Terms) =
365 Map.foldl (\doc t -> doc <> D.text t <> D.eol) D.empty ts
366 instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d, Writable d (Context_Write, j)) =>
367 Writable d (Context_Write, Compta src ss j) where
368 write (ctx, Compta
369 { compta_journals = js
370 , compta_chart = c@Chart{chart_accounts=ca}
371 , compta_style_amounts = amts
372 , compta_terms = terms
373 }) =
374 (if null terms then D.empty else (write terms <> D.eol)) <>
375 (if TreeMap.null ca then D.empty else (write c <> D.eol)) <>
376 write (ctx{context_write_amounts = context_write_amounts ctx <> amts}, js)
377 instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d) =>
378 Writable (IO d) SourcePos where
379 write (SourcePos p (PosFile l) (PosFile c)) = do
380 content <- Enc.decodeUtf8 <$> BS.readFile p
381 let ls = Text.lines content
382 let ll = max 1 $ l - size_ctx
383 let qs =
384 L.take (intFrom $ (l - ll) + 1 + size_ctx) $
385 L.drop (intFrom $ ll-1) ls
386 let ns = show <$> L.take (L.length qs) [ll..]
387 let max_len_n = maximum $ 0 : (L.length <$> ns)
388 let ns' = (<$> ns) $ \n ->
389 L.replicate (max_len_n - L.length n) ' ' <> n
390 let quote =
391 D.catV $
392 L.zipWith (\(n, sn) q ->
393 D.spaces 2 <> D.blacker (D.stringH sn) <>
394 D.spaces 2 <> (if n == l then mark q else D.textH q)
395 ) (L.zip [ll..] ns') qs
396 return $ quote <> D.eol
397 where
398 size_ctx = 2
399 intFrom = fromInteger . toInteger
400 mark q =
401 let (b, a) = Text.splitAt (intFrom c - 1) q in
402 D.textH b <>
403 case Text.uncons a of
404 Nothing -> D.red D.space
405 Just (a0, a') -> D.red (D.charH a0) <> D.textH a'
406
407 -- | Return the width of given 'Postings',
408 -- considering only 'Account's and 'Amount's (not indentation, 'Comment's, nor 'Posting_Tag's).
409 w_Transaction :: Context_Write -> Transaction -> Int
410 -- w_Postings ctx = MT.ofoldr (max . widthWrite ctx) 0
411 w_Transaction ctx =
412 MT.ofoldr (\Posting
413 { posting_account
414 , posting_account_ref
415 , posting_amounts
416 } -> max $
417 let w_Acct =
418 case posting_account_ref of
419 S.Just (a S.:!: sa) | context_write_account_ref ctx ->
420 widthWrite a + S.maybe 0 widthWrite sa
421 _ -> widthWrite posting_account in
422 let w_Amt =
423 case posting_amounts of
424 Amounts amts | Map.null amts -> 0
425 Amounts amts ->
426 Map.foldrWithKey
427 (\unit qty -> max $
428 let amt = styled_amount (context_write_amounts ctx) $ Amount unit qty in
429 widthWrite amt)
430 1 amts in
431 w_Acct + w_Amt
432 ) 0 .
433 transaction_postings