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