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