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