]> Git — Sourcephile - comptalang.git/blob - lib/Hcompta/Format/Ledger/Write.hs
Ajout : Hcompta.Chart.
[comptalang.git] / lib / Hcompta / Format / Ledger / Write.hs
1 {-# LANGUAGE FlexibleContexts #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE NamedFieldPuns #-}
4 {-# LANGUAGE OverloadedStrings #-}
5 {-# LANGUAGE ScopedTypeVariables #-}
6 {-# LANGUAGE TypeFamilies #-}
7 module Hcompta.Format.Ledger.Write where
8
9 import Control.Applicative ((<$>), (<*>), (<*))
10 import Control.Monad (Monad(..))
11 import Data.Bool
12 import Data.Char (Char, isSpace)
13 import Data.Either (Either(..))
14 import Data.Eq (Eq(..))
15 import qualified Data.Foldable
16 import Data.Foldable (Foldable(..))
17 import Data.Functor (Functor(..))
18 import qualified Data.Functor.Compose
19 import Data.List
20 import qualified Data.List.NonEmpty
21 import qualified Data.Map.Strict as Data.Map
22 import Data.Maybe (Maybe(..))
23 import Data.Monoid (Monoid(..))
24 import Data.Ord (Ord(..))
25 import qualified Data.Text as Text
26 import qualified Data.Text.Lazy as TL
27 import Prelude (($), (.), Bounded(..), Int, IO, Num(..), flip, uncurry)
28 import System.IO (Handle)
29 import Text.Parsec (Stream, ParsecT)
30 import qualified Text.Parsec as R hiding (satisfy, char)
31
32 import Hcompta.Account (Account)
33 import qualified Hcompta.Account as Account
34 import qualified Hcompta.Account.Read as Account.Read
35 import qualified Hcompta.Amount as Amount
36 import qualified Hcompta.Amount.Write as Amount.Write
37 import Hcompta.Chart (Chart)
38 import qualified Hcompta.Chart as Chart
39 import qualified Hcompta.Date.Write as Date.Write
40 import qualified Hcompta.Format.Ledger as Ledger
41 import Hcompta.Format.Ledger
42 ( Comment
43 , Journal(..)
44 , Posting(..), Posting_by_Account
45 , Transaction(..)
46 )
47 import qualified Hcompta.Format.Ledger.Read as Read
48 -- import Hcompta.Lib.Consable (Consable(..))
49 import Hcompta.Lib.Leijen (Doc, (<>))
50 import qualified Hcompta.Lib.Leijen as W
51 import qualified Hcompta.Lib.Parsec as R
52 import Hcompta.Posting (Posting_Type(..))
53 import Hcompta.Tag (Tag)
54 import qualified Hcompta.Tag as Tag
55 import qualified Hcompta.Lib.TreeMap as TreeMap
56
57 -- * Write 'Account'
58
59 account :: Posting_Type -> Account -> Doc
60 account type_ =
61 case type_ of
62 Posting_Type_Regular -> account_
63 Posting_Type_Virtual -> \acct ->
64 W.char Read.posting_type_virtual_begin <> do
65 account_ acct <> do
66 W.char Read.posting_type_virtual_end
67 Posting_Type_Virtual_Balanced -> \acct ->
68 W.char Read.posting_type_virtual_balanced_begin <> do
69 account_ acct <> do
70 W.char Read.posting_type_virtual_balanced_end
71 where
72 account_ :: Account -> Doc
73 account_ acct =
74 W.align $ W.hcat $
75 Data.List.NonEmpty.toList $
76 Data.List.NonEmpty.intersperse
77 (W.bold $ W.yellow $ W.char Account.Read.section_sep)
78 (Data.List.NonEmpty.map account_section acct)
79
80 account_section :: Account.Account_Section -> Doc
81 account_section = W.strict_text
82
83 -- ** Measure 'Account'
84
85 account_length :: Posting_Type -> Account -> Int
86 account_length type_ acct =
87 Data.Foldable.foldl
88 (\acc -> (1 +) . (acc +) . Text.length)
89 (- 1) acct +
90 case type_ of
91 Posting_Type_Regular -> 0
92 Posting_Type_Virtual -> 2
93 Posting_Type_Virtual_Balanced -> 2
94
95 -- ** Measure 'Amount's
96
97 amounts_length :: Amount.By_Unit -> Int
98 amounts_length amts =
99 if Data.Map.null amts
100 then 0
101 else
102 Data.Map.foldr
103 (\n -> (3 +) . (+) (Amount.Write.amount_length n))
104 (-3) amts
105
106 -- * Write 'Comment'
107
108 comment :: Comment -> Doc
109 comment com =
110 W.cyan $ do
111 W.char Read.comment_begin
112 <> (case Text.uncons com of
113 Just (c, _) | not $ Data.Char.isSpace c -> W.space
114 _ -> W.empty)
115 <> do W.if_color colorize (W.strict_text com)
116 where
117 colorize :: Doc
118 colorize =
119 case R.runParser (do
120 pre <- R.many $ R.try $ do
121 ns <- R.many $ R.satisfy (\c -> c /= Read.tag_value_sep && not (Data.Char.isSpace c))
122 sh <- R.space_horizontal
123 return (ns ++ [sh])
124 ((W.text $ TL.pack $ concat pre) <>) <$> tags <* R.eof)
125 () "" com of
126 Left _ -> W.strict_text com
127 Right doc -> doc
128 tags :: Stream s m Char => ParsecT s u m Doc
129 tags = do
130 (<>)
131 <$> tag_
132 <*> (W.hcat <$> R.many (R.try (tag_sep >>= (\s -> (s <>) <$> tag_))))
133 where
134 tag_sep :: Stream s m Char => ParsecT s u m Doc
135 tag_sep = do
136 s <- R.char Read.tag_sep
137 sh <- R.many R.space_horizontal
138 return $
139 do W.cyan $ W.char s
140 <> do W.text $ TL.pack sh
141 tag_ :: Stream s m Char => ParsecT s u m Doc
142 tag_ = do
143 (p, v) <- Read.tag
144 return $
145 foldMap (\s -> W.dullyellow (W.strict_text s) <> do
146 W.bold $ W.dullblack $ W.char Read.tag_value_sep) p <>
147 (W.red $ W.strict_text v)
148
149 comments :: Doc -> [Comment] -> Doc
150 comments prefix =
151 W.hcat .
152 Data.List.intersperse W.line .
153 Data.List.map (\c -> prefix <> comment c)
154
155 -- * Write 'Tag'
156
157 tag :: Tag -> Doc
158 tag (p, v) =
159 foldMap (\s -> W.dullyellow (W.strict_text s) <> W.char Read.tag_value_sep) p <>
160 (W.dullred $ W.strict_text v)
161
162 -- * Write 'Posting'
163
164 posting :: Posting_Lengths -> Posting_Type -> Posting -> Doc
165 posting max_posting_length type_
166 Posting
167 { posting_account=acct
168 , posting_amounts
169 , posting_comments=cmts
170 -- , posting_dates
171 , posting_status=status_
172 -- , posting_tags
173 } =
174 W.char '\t' <> do
175 status status_ <> do
176 case Data.Map.null posting_amounts of
177 True -> account type_ acct
178 False ->
179 let len_acct = account_length type_ acct in
180 let len_amts = amounts_length posting_amounts in
181 account type_ acct <> do
182 W.fill (2 + max_posting_length - (len_acct + len_amts)) (W.space <> W.space) <> do
183 W.intercalate
184 (W.space <> (W.bold $ W.yellow $ W.char Read.amount_sep) <> W.space)
185 Amount.Write.amount posting_amounts
186 <> (case cmts of
187 [] -> W.empty
188 [c] -> W.space <> comment c
189 _ -> W.line <> do comments (W.text "\t ") cmts)
190
191 status :: Ledger.Status -> Doc
192 status = \x -> case x of
193 True -> W.char '!'
194 False -> W.empty
195
196 -- ** Measure 'Posting'
197
198 type Posting_Lengths = (Int)
199
200 postings_lengths
201 :: Posting_Type
202 -> Posting_by_Account
203 -> Posting_Lengths
204 -> Posting_Lengths
205 postings_lengths type_ ps pl =
206 Data.Foldable.foldr
207 (\p ->
208 max
209 ( account_length type_ (posting_account p)
210 + amounts_length (posting_amounts p) )
211 ) pl
212 (Data.Functor.Compose.Compose ps)
213
214 -- * Write 'Transaction'
215
216 transaction :: Transaction -> Doc
217 transaction t = transaction_with_lengths (transaction_lengths t 0) t
218
219 transactions :: Foldable ts => ts Transaction -> Doc
220 transactions ts = do
221 let transaction_lengths_ =
222 Data.Foldable.foldr transaction_lengths 0 ts
223 Data.Foldable.foldr
224 (\t doc ->
225 transaction_with_lengths transaction_lengths_ t <>
226 (if W.is_empty doc then W.empty else W.line <> doc)
227 )
228 W.empty
229 ts
230
231 transaction_with_lengths :: Transaction_Lengths -> Transaction -> Doc
232 transaction_with_lengths
233 posting_lengths_
234 Transaction
235 { transaction_code=code_
236 , transaction_comments_before
237 , transaction_comments_after
238 , transaction_dates=(first_date, dates)
239 , transaction_description
240 , transaction_postings
241 , transaction_virtual_postings
242 , transaction_balanced_virtual_postings
243 , transaction_status=status_
244 -- , transaction_tags
245 } = do
246 (case transaction_comments_before of
247 [] -> W.empty
248 _ -> comments W.space transaction_comments_before <> W.line) <> do
249 (W.hcat $
250 Data.List.intersperse
251 (W.char Read.date_sep)
252 (Data.List.map Date.Write.date (first_date:dates))) <> do
253 (case status_ of
254 True -> W.space <> status status_
255 False -> W.empty) <> do
256 code code_ <> do
257 (case transaction_description of
258 "" -> W.empty
259 _ -> W.space <> (W.dullmagenta $ W.strict_text transaction_description)) <> do
260 W.line <> do
261 (case transaction_comments_after of
262 [] -> W.empty
263 _ -> comments W.space transaction_comments_after <> W.line) <> do
264 W.vsep
265 (fmap
266 (\(type_, ps) ->
267 (W.intercalate W.line
268 (W.vsep . fmap (posting posting_lengths_ type_))
269 )
270 (ps)
271 )
272 [ (Posting_Type_Regular , transaction_postings)
273 , (Posting_Type_Virtual , transaction_virtual_postings)
274 , (Posting_Type_Virtual_Balanced, transaction_balanced_virtual_postings)
275 ]
276 ) <> W.line
277
278 code :: Ledger.Code -> Doc
279 code = \x -> case x of
280 "" -> W.empty
281 t -> W.space <> W.char '(' <> W.strict_text t <> W.char ')'
282
283 -- ** Measure 'Transaction'
284
285 type Transaction_Lengths = Posting_Lengths
286
287 transaction_lengths :: Transaction -> Posting_Lengths -> Posting_Lengths
288 transaction_lengths
289 Transaction
290 { transaction_postings
291 , transaction_virtual_postings
292 , transaction_balanced_virtual_postings
293 } posting_lengths_ = do
294 Data.List.foldl
295 (flip (uncurry postings_lengths))
296 posting_lengths_
297 [ (Posting_Type_Regular, transaction_postings)
298 , (Posting_Type_Virtual, transaction_virtual_postings)
299 , (Posting_Type_Virtual_Balanced, transaction_balanced_virtual_postings)
300 ]
301
302 -- * Write 'Journal'
303
304 journal ::
305 ( Foldable ts
306 , Monoid (ts Transaction)
307 ) => Journal (ts Transaction) -> Doc
308 journal Journal{ journal_sections } =
309 transactions journal_sections
310
311 -- * Write 'Chart'
312
313 chart :: Chart -> Doc
314 chart =
315 TreeMap.foldl_with_Path
316 (\doc acct ca ->
317 doc <>
318 account Posting_Type_Regular acct <> W.line <>
319 Data.Map.foldlWithKey
320 (\dd tn tvs ->
321 dd <>
322 foldl'
323 (\ddd tv ->
324 ddd <> W.char '\t' <> tag (tn, tv) <> W.line)
325 W.empty
326 tvs
327 )
328 W.empty
329 (Tag.unTags $ Chart.chart_account_tags ca)
330 ) W.empty
331
332 -- * Rendering
333
334 data Style
335 = Style
336 { style_align :: Bool
337 , style_color :: Bool
338 }
339 style :: Style
340 style =
341 Style
342 { style_align = True
343 , style_color = True
344 }
345
346 show :: Style -> Doc -> TL.Text
347 show Style{style_color, style_align} =
348 W.displayT .
349 if style_align
350 then W.renderPretty style_color 1.0 maxBound
351 else W.renderCompact style_color
352
353 put :: Style -> Handle -> Doc -> IO ()
354 put Style{style_color, style_align} handle =
355 W.displayIO handle .
356 if style_align
357 then W.renderPretty style_color 1.0 maxBound
358 else W.renderCompact style_color