]> Git — Sourcephile - comptalang.git/blob - ledger/Test/Main.hs
sourcephile / git / comptalang.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
Ajout : Hcompta.Format.JCC.
[comptalang.git] / ledger / Test / Main.hs
1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE ScopedTypeVariables #-}
3 {-# LANGUAGE StandaloneDeriving #-}
4
5 import Test.HUnit hiding (test)
6 import Test.Framework.Providers.HUnit (hUnitTestToTests)
7 import Test.Framework.Runners.Console (defaultMain)
8
9 import Control.Applicative (Applicative(..))
10 import Control.Monad (Monad(..))
11 import Control.Monad.IO.Class (liftIO)
12 import Data.Bool (Bool(..))
13 import Data.Decimal (DecimalRaw(..))
14 import qualified Data.Either
15 import Data.Either (rights, either)
16 import Data.Eq (Eq(..))
17 import Data.Function (($), (.), id, const)
18 import Data.Functor (Functor(..), (<$>))
19 import Data.List ((++))
20 import Data.List.NonEmpty (NonEmpty(..))
21 import qualified Data.Map.Strict as Map
22 import Data.Maybe (Maybe(..), maybe)
23 import Data.Monoid (Monoid(..))
24 import Data.Text (Text)
25 import qualified Data.Text as Text
26 import qualified Data.Text.Lazy as TL
27 import qualified Data.Time.Calendar as Time
28 import qualified Data.Time.LocalTime as Time
29 import System.IO (IO)
30 import qualified Text.Parsec as R hiding (char, space, spaces, string)
31 import qualified Text.Parsec.Pos as R
32
33 import qualified Hcompta.Chart as Chart
34 import qualified Hcompta.Date as Date
35 import qualified Hcompta.Lib.Parsec as R
36 import qualified Hcompta.Posting as Posting
37 import qualified Hcompta.Tag as Tag
38 import qualified Hcompta.Transaction as Transaction
39
40 import qualified Hcompta.Format.Ledger as Ledger
41 import qualified Hcompta.Format.Ledger.Read as Ledger
42 import qualified Hcompta.Format.Ledger.Write as Ledger
43
44 deriving instance Eq Ledger.Amount
45
46 main :: IO ()
47 main = defaultMain $ hUnitTestToTests test
48
49 test :: Test
50 test = TestList
51 [ "Read" ~: TestList
52 [ "read_date" ~:
53 let (==>) (txt::Text) =
54 (~:) (Text.unpack txt) .
55 (~?=)
56 (rights [R.runParser_with_Error
57 (Ledger.read_date id Nothing <* R.eof) () "" txt])
58 in TestList $
59 [ "2000-01-01" ==>
60 [ Time.zonedTimeToUTC $
61 Time.ZonedTime
62 (Time.LocalTime
63 (Time.fromGregorian 2000 01 01)
64 (Time.TimeOfDay 0 0 0))
65 (Time.utc) ]
66 , "2000/01/01" ==>
67 [ Time.zonedTimeToUTC $
68 Time.ZonedTime
69 (Time.LocalTime
70 (Time.fromGregorian 2000 01 01)
71 (Time.TimeOfDay 0 0 0))
72 (Time.utc) ]
73 , "2000-01-01_12:34" ==>
74 [ Time.zonedTimeToUTC $
75 Time.ZonedTime
76 (Time.LocalTime
77 (Time.fromGregorian 2000 01 01)
78 (Time.TimeOfDay 12 34 0))
79 (Time.utc) ]
80 , "2000-01-01_12:34:56" ==>
81 [ Time.zonedTimeToUTC $
82 Time.ZonedTime
83 (Time.LocalTime
84 (Time.fromGregorian 2000 01 01)
85 (Time.TimeOfDay 12 34 56))
86 (Time.utc) ]
87 , "2000-01-01_12:34_CET" ==>
88 [ Time.zonedTimeToUTC $
89 Time.ZonedTime
90 (Time.LocalTime
91 (Time.fromGregorian 2000 01 01)
92 (Time.TimeOfDay 12 34 0))
93 (Time.TimeZone 60 True "CET") ]
94 , "2000-01-01_12:34+01:30" ==>
95 [ Time.zonedTimeToUTC $
96 Time.ZonedTime
97 (Time.LocalTime
98 (Time.fromGregorian 2000 01 01)
99 (Time.TimeOfDay 12 34 0))
100 (Time.TimeZone 90 False "+01:30") ]
101 , "2000-01-01_12:34:56_CET" ==>
102 [ Time.zonedTimeToUTC $
103 Time.ZonedTime
104 (Time.LocalTime
105 (Time.fromGregorian 2000 01 01)
106 (Time.TimeOfDay 12 34 56))
107 (Time.TimeZone 60 True "CET") ]
108 , "2001-02-29" ==> []
109 ] ++
110 let (==>) (txt::Text, def) =
111 (~:) (Text.unpack txt) .
112 (~?=) (rights [R.runParser_with_Error
113 (Ledger.read_date id (Just def) <* R.eof) () "" txt])
114 in
115 [ ("01-01", 2000) ==>
116 [ Time.zonedTimeToUTC $
117 Time.ZonedTime
118 (Time.LocalTime
119 (Time.fromGregorian 2000 01 01)
120 (Time.TimeOfDay 0 0 0))
121 (Time.utc)]
122 ]
123 , "read_account_section" ~:
124 let (==>) (txt::Text) b =
125 (~:) (Text.unpack txt) $
126 (~?=)
127 (rights [R.runParser (Ledger.read_account_section <* R.eof) () "" txt])
128 (if b then [txt] else [])
129 in TestList
130 [ "" ==> False
131 , "A" ==> True
132 , "AA" ==> True
133 , " " ==> False
134 , ":" ==> False
135 , "A:" ==> False
136 , ":A" ==> False
137 , "A " ==> False
138 , "A A" ==> True
139 , "A " ==> False
140 , "A\t" ==> False
141 , "A \n" ==> False
142 , "(A)A" ==> True
143 , "( )A" ==> True
144 , "(A) A" ==> True
145 , "[ ] A" ==> True
146 , "(A) " ==> False
147 , "(A)" ==> True
148 , "A(A)" ==> True
149 , "[A]A" ==> True
150 , "[A] A" ==> True
151 , "[A] " ==> False
152 , "[A]" ==> True
153 , "\"A \"" ~:
154 (rights
155 [R.runParser
156 (Ledger.read_account_section)
157 () "" ("A "::Text)])
158 ~?=
159 ["A"]
160 ]
161 , "read_account" ~:
162 let (==>) (txt::Text) =
163 (~:) (Text.unpack txt) .
164 (~?=) (rights [R.runParser
165 (Ledger.read_account <* R.eof) () "" txt])
166 in TestList
167 [ "" ==> []
168 , "A" ==> ["A":|[]]
169 , "A:" ==> []
170 , ":A" ==> []
171 , "A " ==> []
172 , " A" ==> []
173 , "A:B" ==> ["A":|["B"]]
174 , "A:B:C" ==> ["A":|["B","C"]]
175 , "Aa:Bbb:Cccc" ==> ["Aa":|["Bbb", "Cccc"]]
176 , "A a : B b b : C c c c" ==> ["A a ":|[" B b b ", " C c c c"]]
177 , "A: :C" ==> ["A":|[" ", "C"]]
178 , "A::C" ==> []
179 , "A:B:(C)" ==> ["A":|["B", "(C)"]]
180 ]
181 , "read_amount" ~:
182 let (==>) (txt::Text) =
183 (~:) (Text.unpack txt) .
184 (~?=) (rights [R.runParser (Ledger.read_amount <* R.eof) () "" txt])
185 in TestList
186 [ "" ==> []
187 , "0" ==>
188 [( mempty
189 , Ledger.amount { Ledger.amount_quantity = Decimal 0 0 } )]
190 , "00" ==>
191 [( mempty
192 , Ledger.amount { Ledger.amount_quantity = Decimal 0 0 } )]
193 , "0." ==>
194 [( mempty { Ledger.amount_style_fractioning = Just '.' }
195 , Ledger.amount { Ledger.amount_quantity = Decimal 0 0 } )]
196 , ".0" ==>
197 [( mempty { Ledger.amount_style_fractioning = Just '.' }
198 , Ledger.amount { Ledger.amount_quantity = Decimal 1 0 } )]
199 , "0," ==>
200 [( mempty { Ledger.amount_style_fractioning = Just ',' }
201 , Ledger.amount { Ledger.amount_quantity = Decimal 0 0 } )]
202 , ",0" ==>
203 [( mempty { Ledger.amount_style_fractioning = Just ',' }
204 , Ledger.amount { Ledger.amount_quantity = Decimal 1 0 } )]
205 , "0_" ==> []
206 , "_0" ==> []
207 , "0.0" ==>
208 [( mempty { Ledger.amount_style_fractioning = Just '.' }
209 , Ledger.amount { Ledger.amount_quantity = Decimal 1 0 } )]
210 , "00.00" ==>
211 [( mempty { Ledger.amount_style_fractioning = Just '.' }
212 , Ledger.amount { Ledger.amount_quantity = Decimal 2 0 } )]
213 , "0,0" ==>
214 [( mempty { Ledger.amount_style_fractioning = Just ',' }
215 , Ledger.amount { Ledger.amount_quantity = Decimal 1 0 } )]
216 , "00,00" ==>
217 [( mempty { Ledger.amount_style_fractioning = Just ',' }
218 , Ledger.amount { Ledger.amount_quantity = Decimal 2 0 } )]
219 , "0_0" ==>
220 [( mempty { Ledger.amount_style_grouping_integral = Just $ Ledger.Amount_Style_Grouping '_' [1] }
221 , Ledger.amount { Ledger.amount_quantity = Decimal 0 0 } )]
222 , "00_00" ==>
223 [( mempty { Ledger.amount_style_grouping_integral = Just $ Ledger.Amount_Style_Grouping '_' [2] }
224 , Ledger.amount { Ledger.amount_quantity = Decimal 0 0 } )]
225 , "0,000.00" ==>
226 [( mempty
227 { Ledger.amount_style_fractioning = Just '.'
228 , Ledger.amount_style_grouping_integral = Just $ Ledger.Amount_Style_Grouping ',' [3] }
229 , Ledger.amount { Ledger.amount_quantity = Decimal 2 0 } )]
230 , "0.000,00" ==>
231 [( mempty
232 { Ledger.amount_style_fractioning = Just ','
233 , Ledger.amount_style_grouping_integral = Just $ Ledger.Amount_Style_Grouping '.' [3] }
234 , Ledger.amount { Ledger.amount_quantity = Decimal 2 0 } )]
235 , "1,000.00" ==>
236 [( mempty
237 { Ledger.amount_style_fractioning = Just '.'
238 , Ledger.amount_style_grouping_integral = Just $ Ledger.Amount_Style_Grouping ',' [3] }
239 , Ledger.amount { Ledger.amount_quantity = Decimal 2 100000 } )]
240 , "1.000,00" ==>
241 [( mempty
242 { Ledger.amount_style_fractioning = Just ','
243 , Ledger.amount_style_grouping_integral = Just $ Ledger.Amount_Style_Grouping '.' [3] }
244 , Ledger.amount { Ledger.amount_quantity = Decimal 2 100000 } )]
245 , "1,000.00." ==> []
246 , "1.000,00," ==> []
247 , "1,000.00_" ==> []
248 , "123" ==>
249 [( mempty
250 , Ledger.amount { Ledger.amount_quantity = Decimal 0 123 } )]
251 , "1.2" ==>
252 [( mempty { Ledger.amount_style_fractioning = Just '.' }
253 , Ledger.amount { Ledger.amount_quantity = Decimal 1 12 } )]
254 , "1,2" ==>
255 [( mempty { Ledger.amount_style_fractioning = Just ',' }
256 , Ledger.amount { Ledger.amount_quantity = Decimal 1 12 } )]
257 , "12.34" ==>
258 [( mempty { Ledger.amount_style_fractioning = Just '.' }
259 , Ledger.amount { Ledger.amount_quantity = Decimal 2 1234 } )]
260 , "12,34" ==>
261 [( mempty { Ledger.amount_style_fractioning = Just ',' }
262 , Ledger.amount { Ledger.amount_quantity = Decimal 2 1234 } )]
263 , "1_2" ==>
264 [( mempty { Ledger.amount_style_grouping_integral = Just $ Ledger.Amount_Style_Grouping '_' [1] }
265 , Ledger.amount { Ledger.amount_quantity = Decimal 0 12 } )]
266 , "1_23" ==>
267 [( mempty { Ledger.amount_style_grouping_integral = Just $ Ledger.Amount_Style_Grouping '_' [2] }
268 , Ledger.amount { Ledger.amount_quantity = Decimal 0 123 } )]
269 , "1_23_456" ==>
270 [( mempty { Ledger.amount_style_grouping_integral = Just $ Ledger.Amount_Style_Grouping '_' [3, 2] }
271 , Ledger.amount { Ledger.amount_quantity = Decimal 0 123456 } )]
272 , "1_23_456,7890_12345_678901" ==>
273 [( mempty
274 { Ledger.amount_style_fractioning = Just ','
275 , Ledger.amount_style_grouping_integral = Just $ Ledger.Amount_Style_Grouping '_' [3, 2]
276 , Ledger.amount_style_grouping_fractional = Just $ Ledger.Amount_Style_Grouping '_' [4, 5, 6] }
277 , Ledger.amount { Ledger.amount_quantity = Decimal 15 123456789012345678901 } )]
278 , "1_23_456.7890_12345_678901" ==>
279 [( mempty
280 { Ledger.amount_style_fractioning = Just '.'
281 , Ledger.amount_style_grouping_integral = Just $ Ledger.Amount_Style_Grouping '_' [3, 2]
282 , Ledger.amount_style_grouping_fractional = Just $ Ledger.Amount_Style_Grouping '_' [4, 5, 6] }
283 , Ledger.amount { Ledger.amount_quantity = Decimal 15 123456789012345678901 } )]
284 , "1,23,456.7890_12345_678901" ==>
285 [( mempty
286 { Ledger.amount_style_fractioning = Just '.'
287 , Ledger.amount_style_grouping_integral = Just $ Ledger.Amount_Style_Grouping ',' [3, 2]
288 , Ledger.amount_style_grouping_fractional = Just $ Ledger.Amount_Style_Grouping '_' [4, 5, 6] }
289 , Ledger.amount { Ledger.amount_quantity = Decimal 15 123456789012345678901 } )]
290 , "1.23.456,7890_12345_678901" ==>
291 [( mempty
292 { Ledger.amount_style_fractioning = Just ','
293 , Ledger.amount_style_grouping_integral = Just $ Ledger.Amount_Style_Grouping '.' [3, 2]
294 , Ledger.amount_style_grouping_fractional = Just $ Ledger.Amount_Style_Grouping '_' [4, 5, 6] }
295 , Ledger.amount { Ledger.amount_quantity = Decimal 15 123456789012345678901 } )]
296 , "123456_78901_2345.678_90_1" ==>
297 [( mempty
298 { Ledger.amount_style_fractioning = Just '.'
299 , Ledger.amount_style_grouping_integral = Just $ Ledger.Amount_Style_Grouping '_' [4, 5, 6]
300 , Ledger.amount_style_grouping_fractional = Just $ Ledger.Amount_Style_Grouping '_' [3, 2] }
301 , Ledger.amount { Ledger.amount_quantity = Decimal 6 123456789012345678901 } )]
302 , "$1" ==>
303 [( mempty
304 { Ledger.amount_style_unit_side = Just Ledger.Amount_Style_Side_Left
305 , Ledger.amount_style_unit_spaced = Just False }
306 , Ledger.amount
307 { Ledger.amount_quantity = Decimal 0 1
308 , Ledger.amount_unit = "$" } )]
309 , "1$" ==>
310 [( mempty
311 { Ledger.amount_style_unit_side = Just Ledger.Amount_Style_Side_Right
312 , Ledger.amount_style_unit_spaced = Just False }
313 , Ledger.amount
314 { Ledger.amount_quantity = Decimal 0 1
315 , Ledger.amount_unit = "$" } )]
316 , "$ 1" ==>
317 [( mempty
318 { Ledger.amount_style_unit_side = Just Ledger.Amount_Style_Side_Left
319 , Ledger.amount_style_unit_spaced = Just True }
320 , Ledger.amount
321 { Ledger.amount_quantity = Decimal 0 1
322 , Ledger.amount_unit = "$" } )]
323 , "1 $" ==>
324 [( mempty
325 { Ledger.amount_style_unit_side = Just Ledger.Amount_Style_Side_Right
326 , Ledger.amount_style_unit_spaced = Just True }
327 , Ledger.amount
328 { Ledger.amount_quantity = Decimal 0 1
329 , Ledger.amount_unit = "$" } )]
330 , "-$1" ==>
331 [( mempty
332 { Ledger.amount_style_unit_side = Just Ledger.Amount_Style_Side_Left
333 , Ledger.amount_style_unit_spaced = Just False }
334 , Ledger.amount
335 { Ledger.amount_quantity = Decimal 0 (-1)
336 , Ledger.amount_unit = "$" } )]
337 , "\"4 2\"1" ==>
338 [( mempty
339 { Ledger.amount_style_unit_side = Just Ledger.Amount_Style_Side_Left
340 , Ledger.amount_style_unit_spaced = Just False }
341 , Ledger.amount
342 { Ledger.amount_quantity = Decimal 0 1
343 , Ledger.amount_unit = "4 2" } )]
344 , "1\"4 2\"" ==>
345 [( mempty
346 { Ledger.amount_style_unit_side = Just Ledger.Amount_Style_Side_Right
347 , Ledger.amount_style_unit_spaced = Just False }
348 , Ledger.amount
349 { Ledger.amount_quantity = Decimal 0 1
350 , Ledger.amount_unit = "4 2" } )]
351 , "$1.000,00" ==>
352 [( mempty
353 { Ledger.amount_style_fractioning = Just ','
354 , Ledger.amount_style_grouping_integral = Just $ Ledger.Amount_Style_Grouping '.' [3]
355 , Ledger.amount_style_unit_side = Just Ledger.Amount_Style_Side_Left
356 , Ledger.amount_style_unit_spaced = Just False }
357 , Ledger.amount
358 { Ledger.amount_quantity = Decimal 2 100000
359 , Ledger.amount_unit = "$" } )]
360 , "1.000,00$" ==>
361 [( mempty
362 { Ledger.amount_style_fractioning = Just ','
363 , Ledger.amount_style_grouping_integral = Just $ Ledger.Amount_Style_Grouping '.' [3]
364 , Ledger.amount_style_unit_side = Just Ledger.Amount_Style_Side_Right
365 , Ledger.amount_style_unit_spaced = Just False }
366 , Ledger.amount
367 { Ledger.amount_quantity = Decimal 2 100000
368 , Ledger.amount_unit = "$" } )]
369 ]
370 , "read_posting_type" ~:
371 let (==>) a (ty, ac) =
372 let read (t::Text) = rights [R.runParser
373 (Ledger.read_account <* R.eof) () "" t] in
374 (~:) (Text.unpack a) $
375 (~?=)
376 (Ledger.read_posting_type <$> read a)
377 (Ledger.Posting_Typed ty <$> read (maybe a id ac))
378 in TestList
379 [ "A" ==> (Ledger.Posting_Type_Regular, Nothing)
380 , "(" ==> (Ledger.Posting_Type_Regular, Nothing)
381 , ")" ==> (Ledger.Posting_Type_Regular, Nothing)
382 , "()" ==> (Ledger.Posting_Type_Regular, Nothing)
383 , "( )" ==> (Ledger.Posting_Type_Regular, Nothing)
384 , "(A)" ==> (Ledger.Posting_Type_Virtual, Just "A")
385 , "(A:B:C)" ==> (Ledger.Posting_Type_Virtual, Just "A:B:C")
386 , "A:B:C" ==> (Ledger.Posting_Type_Regular, Nothing)
387 , "(A):B:C" ==> (Ledger.Posting_Type_Regular, Nothing)
388 , "A:(B):C" ==> (Ledger.Posting_Type_Regular, Nothing)
389 , "A:B:(C)" ==> (Ledger.Posting_Type_Regular, Nothing)
390 , "[" ==> (Ledger.Posting_Type_Regular, Nothing)
391 , "]" ==> (Ledger.Posting_Type_Regular, Nothing)
392 , "[]" ==> (Ledger.Posting_Type_Regular, Nothing)
393 , "[ ]" ==> (Ledger.Posting_Type_Regular, Nothing)
394 , "[A]" ==> (Ledger.Posting_Type_Virtual_Balanced, Just "A")
395 , "[A:B:C]" ==> (Ledger.Posting_Type_Virtual_Balanced, Just "A:B:C")
396 , "A:B:C" ==> (Ledger.Posting_Type_Regular, Nothing)
397 , "[A]:B:C" ==> (Ledger.Posting_Type_Regular, Nothing)
398 , "A:[B]:C" ==> (Ledger.Posting_Type_Regular, Nothing)
399 , "A:B:[C]" ==> (Ledger.Posting_Type_Regular, Nothing)
400 ]
401 , "read_comment" ~:
402 let (==>) (txt::Text, end) =
403 (~:) (Text.unpack txt) .
404 (~?=) (rights [R.runParser (Ledger.read_comment <* end) () "" txt])
405 in TestList
406 [ ("; some comment", R.eof) ==> [" some comment"]
407 , ("; some comment \n", R.newline <* R.eof) ==> [ " some comment " ]
408 , ("; some comment \r\n", R.string "\r\n" <* R.eof) ==> [ " some comment " ]
409 ]
410 , "read_comments" ~:
411 let (==>) (txt::Text, end) =
412 (~:) (Text.unpack txt) .
413 (~?=) (rights [R.runParser (Ledger.read_comments <* end) () "" txt])
414 in TestList
415 [ ("; some comment\n ; some other comment", R.eof) ==> [ [" some comment", " some other comment"] ]
416 , ("; some comment \n", R.string "\n" <* R.eof) ==> [ [" some comment "] ]
417 ]
418 , "read_tag_value" ~:
419 let (==>) (txt::Text, end) =
420 (~:) (Text.unpack txt) .
421 (~?=) (rights [R.runParser (Ledger.read_tag_value <* end) () "" txt])
422 in TestList
423 [ (",", R.eof) ==> [","]
424 , (",\n", R.char '\n' <* R.eof) ==> [","]
425 , (",x", R.eof) ==> [",x"]
426 , (",x:", R.string ",x:" <* R.eof) ==> [""]
427 , ("v, v, n:", R.string ", n:" <* R.eof) ==> ["v, v"]
428 ]
429 , "read_tag" ~:
430 let (==>) (txt::Text, end) =
431 (~:) (Text.unpack txt) .
432 (~?=) (rights [R.runParser (Ledger.read_tag <* end) () "" txt])
433 in TestList
434 [ ("Name:" , R.eof) ==> [("Name":|[], "")]
435 , ("Name:Value" , R.eof) ==> [("Name":|[], "Value")]
436 , ("Name:Value\n" , R.string "\n" <* R.eof) ==> [("Name":|[], "Value")]
437 , ("Name:Val ue" , R.eof) ==> [("Name":|[], "Val ue")]
438 , ("Name:," , R.eof) ==> [("Name":|[], ",")]
439 , ("Name:Val,ue" , R.eof) ==> [("Name":|[], "Val,ue")]
440 , ("Name:Val,ue:" , R.string ",ue:" <* R.eof) ==> [("Name":|[], "Val")]
441 , ("Name:Val,ue :", R.eof) ==> [("Name":|[], "Val,ue :")]
442 ]
443 , "read_tags" ~:
444 let (==>) (txt::Text) =
445 (~:) (Text.unpack txt) .
446 (~?=) (rights [R.runParser (Ledger.read_tags <* R.eof) () "" txt]) .
447 pure . Map.fromList
448 in TestList
449 [ "Name:" ==> [ ("Name":|[], [""]) ]
450 , "Name:," ==> [ ("Name":|[], [","]) ]
451 , "Name:,Name:" ==> [ ("Name":|[], ["", ""]) ]
452 , "Name:,Name2:" ==>
453 [ ("Name":|[], [""])
454 , ("Name2":|[], [""])
455 ]
456 , "Name: , Name2:" ==>
457 [ ("Name":|[], [" "])
458 , ("Name2":|[], [""])
459 ]
460 , "Name:,Name2:,Name3:" ==>
461 [ ("Name":|[], [""])
462 , ("Name2":|[], [""])
463 , ("Name3":|[], [""])
464 ]
465 , "Name:Val ue,Name2:V a l u e,Name3:V al ue" ==>
466 [ ("Name":|[], ["Val ue"])
467 , ("Name2":|[], ["V a l u e"])
468 , ("Name3":|[], ["V al ue"])
469 ]
470 ]
471 , "read_posting" ~:
472 let (==>) (txt::Text) =
473 let read_context =
474 ( Ledger.read_context (const ()) Ledger.journal
475 ::Ledger.Read_Context () ()) in
476 (~:) (Text.unpack txt) .
477 (~?=) (rights [R.runParser_with_Error
478 (Ledger.read_posting <* R.eof) read_context "" txt]) .
479 fmap (\p -> Ledger.Posting_Typed Ledger.Posting_Type_Regular
480 p { Ledger.posting_sourcepos = R.newPos "" 1 1 })
481 in TestList
482 [ " A:B:C" ==> [Ledger.posting ("A":|["B", "C"])]
483 , "A:B:C" ==> []
484 , " !A:B:C" ==> [(Ledger.posting ("A":|["B", "C"]))
485 { Ledger.posting_status = True }]
486 , " *A:B:C" ==> [(Ledger.posting ("A":|["B", "C"]))
487 { Ledger.posting_status = True }]
488 , " A:B:C $1" ==> [Ledger.posting ("A":|["B", "C $1"])]
489 , " A:B:C $1" ==> [(Ledger.posting ("A":|["B", "C"]))
490 { Ledger.posting_amounts = Map.fromList [("$", 1)] }]
491 , " A:B:C $1 + 1€" ==> [(Ledger.posting ("A":|["B", "C"]))
492 { Ledger.posting_amounts = Map.fromList [("$", 1), ("€", 1)] }]
493 , " A:B:C $1 + 1$" ==> [(Ledger.posting ("A":|["B", "C"]))
494 { Ledger.posting_amounts = Map.fromList [("$", 2)] }]
495 , " A:B:C $1 + 1$ + 1$" ==> [(Ledger.posting ("A":|["B", "C"]))
496 { Ledger.posting_amounts = Map.fromList [("$", 3)] }]
497 , " A:B:C ; some comment" ==> [(Ledger.posting ("A":|["B", "C"]))
498 { Ledger.posting_amounts = Map.fromList []
499 , Ledger.posting_comments = [" some comment"] }]
500 , " A:B:C ; some comment\n ; some other comment" ==>
501 [(Ledger.posting ("A":|["B", "C"]))
502 { Ledger.posting_amounts = Map.fromList []
503 , Ledger.posting_comments = [" some comment", " some other comment"] }]
504 , " A:B:C $1 ; some comment" ==>
505 [(Ledger.posting ("A":|["B", "C"]))
506 { Ledger.posting_amounts = Map.fromList [("$", 1)]
507 , Ledger.posting_comments = [" some comment"] }]
508 , " A:B:C ; N:V" ==>
509 [(Ledger.posting ("A":|["B", "C"]))
510 { Ledger.posting_comments = [" N:V"]
511 , Ledger.posting_tags = Posting.Posting_Tags $
512 Tag.from_List [ ("N":|[], "V") ] }]
513 , " A:B:C ; some comment N:V" ==>
514 [(Ledger.posting ("A":|["B", "C"]))
515 { Ledger.posting_comments = [" some comment N:V"]
516 , Ledger.posting_tags = Posting.Posting_Tags $
517 Tag.from_List [ ("N":|[], "V") ] }]
518 , " A:B:C ; some comment N:V v, N2:V2 v2" ==>
519 [(Ledger.posting ("A":|["B", "C"]))
520 { Ledger.posting_comments = [" some comment N:V v, N2:V2 v2"]
521 , Ledger.posting_tags = Posting.Posting_Tags $
522 Tag.from_List
523 [ ("N":|[], "V v")
524 , ("N2":|[], "V2 v2") ] }]
525 , " A:B:C ; N:V\n ; N:V2" ==>
526 [(Ledger.posting ("A":|["B", "C"]))
527 { Ledger.posting_comments = [" N:V", " N:V2"]
528 , Ledger.posting_tags = Posting.Posting_Tags $
529 Tag.from_List
530 [ ("N":|[], "V")
531 , ("N":|[], "V2")
532 ] }]
533 , " A:B:C ; N:V\n ; N2:V" ==>
534 [(Ledger.posting ("A":|["B", "C"]))
535 { Ledger.posting_comments = [" N:V", " N2:V"]
536 , Ledger.posting_tags = Posting.Posting_Tags $
537 Tag.from_List
538 [ ("N":|[], "V")
539 , ("N2":|[], "V")
540 ] }]
541 , " A:B:C ; date:2001-01-01" ==>
542 [(Ledger.posting ("A":|["B", "C"]))
543 { Ledger.posting_comments = [" date:2001-01-01"]
544 , Ledger.posting_dates =
545 [ Time.zonedTimeToUTC $
546 Time.ZonedTime
547 (Time.LocalTime
548 (Time.fromGregorian 2001 01 01)
549 (Time.TimeOfDay 0 0 0))
550 Time.utc
551 ]
552 , Ledger.posting_tags = Posting.Posting_Tags $
553 Tag.from_List
554 [ ("date":|[], "2001-01-01") ] }]
555 , " (A:B:C) = Right (A:B:C)" ~:
556 (rights [R.runParser_with_Error
557 (Ledger.read_posting <* R.eof)
558 ( Ledger.read_context (const ()) Ledger.journal
559 ::Ledger.Read_Context () ())
560 "" (" (A:B:C)"::Text)]) ~?=
561 [Ledger.Posting_Typed
562 Ledger.Posting_Type_Virtual
563 (Ledger.posting ("A":|["B", "C"]))]
564 , " [A:B:C] = Right [A:B:C]" ~:
565 (rights [R.runParser_with_Error
566 (Ledger.read_posting <* R.eof)
567 ( Ledger.read_context (const ()) Ledger.journal
568 ::Ledger.Read_Context () ())
569 "" (" [A:B:C]"::Text)]) ~?=
570 [Ledger.Posting_Typed
571 Ledger.Posting_Type_Virtual_Balanced
572 (Ledger.posting ("A":|["B", "C"]))]
573 ]
574 , "read_transaction" ~:
575 let (==>) (txt::Text) =
576 let read_context =
577 ( Ledger.read_context (const ()) Ledger.journal
578 ::Ledger.Read_Context () ()) in
579 (~:) (Text.unpack txt) .
580 (~?=) (rights [R.runParser_with_Error
581 (Ledger.read_transaction <* R.eof) read_context "" txt]) .
582 fmap (\t -> t { Ledger.transaction_sourcepos = R.newPos "" 1 1 })
583 in TestList
584 [ "2000-01-01 some wording\n A:B:C $1\n a:b:c" ==>
585 [Ledger.transaction
586 { Ledger.transaction_dates=
587 ( Time.zonedTimeToUTC $
588 Time.ZonedTime
589 (Time.LocalTime
590 (Time.fromGregorian 2000 01 01)
591 (Time.TimeOfDay 0 0 0))
592 (Time.utc)
593 , [] )
594 , Ledger.transaction_wording="some wording"
595 , Ledger.transaction_postings = Ledger.postings_by_account
596 [ (Ledger.posting ("A":|["B", "C"]))
597 { Ledger.posting_amounts = Map.fromList [ ("$", 1) ]
598 , Ledger.posting_sourcepos = R.newPos "" 2 1 }
599 , (Ledger.posting ("a":|["b", "c"]))
600 { Ledger.posting_amounts = Map.fromList [ ("$", -1) ]
601 , Ledger.posting_sourcepos = R.newPos "" 3 1 }
602 ]
603 }]
604 , "2000-01-01 some wording\n A:B:C $1\n a:b:c\n" ==> []
605 , "2000-01-01 some wording ; some comment\n ; some other;comment\n ; some Tag:\n ; some last comment\n A:B:C $1\n a:b:c" ==>
606 [Ledger.transaction
607 { Ledger.transaction_comments_after =
608 [ " some comment"
609 , " some other;comment"
610 , " some Tag:"
611 , " some last comment"
612 ]
613 , Ledger.transaction_dates=
614 ( Time.zonedTimeToUTC $
615 Time.ZonedTime
616 (Time.LocalTime
617 (Time.fromGregorian 2000 01 01)
618 (Time.TimeOfDay 0 0 0))
619 (Time.utc)
620 , [] )
621 , Ledger.transaction_wording="some wording"
622 , Ledger.transaction_postings = Ledger.postings_by_account
623 [ (Ledger.posting ("A":|["B", "C"]))
624 { Ledger.posting_amounts = Map.fromList [ ("$", 1) ]
625 , Ledger.posting_sourcepos = R.newPos "" 5 1 }
626 , (Ledger.posting ("a":|["b", "c"]))
627 { Ledger.posting_amounts = Map.fromList [ ("$", -1) ]
628 , Ledger.posting_sourcepos = R.newPos "" 6 1 } ]
629 , Ledger.transaction_tags = Transaction.Transaction_Tags $
630 Tag.from_List [ ("Tag":|[], "") ] }]
631 ]
632 , "read_journal" ~: TestList
633 [ "2000-01-01 1° wording\\n A:B:C $1\\n a:b:c\\n2000-01-02 2° wording\\n A:B:C $1\\n x:y:z" ~: TestCase $ do
634 jnl <- liftIO $
635 R.runParserT_with_Error
636 (Ledger.read_journal "" {-<* R.eof-})
637 ( Ledger.read_context id Ledger.journal
638 ::Ledger.Read_Context (Ledger.Charted Ledger.Transaction)
639 ([Ledger.Charted Ledger.Transaction]))
640 "" ("2000-01-01 1° wording\n A:B:C $1\n a:b:c\n2000-01-02 2° wording\n A:B:C $1\n x:y:z"::Text)
641 ((\j -> j{Ledger.journal_last_read_time=Date.nil}) <$>
642 Data.Either.rights [jnl])
643 @?=
644 [Ledger.journal
645 { Ledger.journal_content =
646 fmap (Chart.Charted mempty) $
647 [ Ledger.transaction
648 { Ledger.transaction_dates=
649 ( Time.zonedTimeToUTC $
650 Time.ZonedTime
651 (Time.LocalTime
652 (Time.fromGregorian 2000 01 02)
653 (Time.TimeOfDay 0 0 0))
654 (Time.utc)
655 , [] )
656 , Ledger.transaction_wording="2° wording"
657 , Ledger.transaction_postings = Ledger.postings_by_account
658 [ (Ledger.posting ("A":|["B", "C"]))
659 { Ledger.posting_amounts = Map.fromList
660 [ ("$", 1)
661 ]
662 , Ledger.posting_sourcepos = R.newPos "" 5 1
663 }
664 , (Ledger.posting ("x":|["y", "z"]))
665 { Ledger.posting_amounts = Map.fromList
666 [ ("$", -1)
667 ]
668 , Ledger.posting_sourcepos = R.newPos "" 6 1
669 }
670 ]
671 , Ledger.transaction_sourcepos = R.newPos "" 4 1
672 }
673 , Ledger.transaction
674 { Ledger.transaction_dates=
675 ( Time.zonedTimeToUTC $
676 Time.ZonedTime
677 (Time.LocalTime
678 (Time.fromGregorian 2000 01 01)
679 (Time.TimeOfDay 0 0 0))
680 (Time.utc)
681 , [] )
682 , Ledger.transaction_wording="1° wording"
683 , Ledger.transaction_postings = Ledger.postings_by_account
684 [ (Ledger.posting ("A":|["B", "C"]))
685 { Ledger.posting_amounts = Map.fromList
686 [ ("$", 1)
687 ]
688 , Ledger.posting_sourcepos = R.newPos "" 2 1
689 }
690 , (Ledger.posting ("a":|["b", "c"]))
691 { Ledger.posting_amounts = Map.fromList
692 [ ("$", -1)
693 ]
694 , Ledger.posting_sourcepos = R.newPos "" 3 1
695 }
696 ]
697 , Ledger.transaction_sourcepos = R.newPos "" 1 1
698 }
699 ]
700 , Ledger.journal_files = [""]
701 , Ledger.journal_amount_styles = Ledger.Amount_Styles $ Map.fromList
702 [ ( Ledger.Unit "$"
703 , mempty
704 { Ledger.amount_style_unit_side = Just Ledger.Amount_Style_Side_Left
705 , Ledger.amount_style_unit_spaced = Just False }
706 )
707 ]
708 }
709 ]
710 ]
711 ]
712 , "Write" ~: TestList
713 [ "write_date" ~:
714 let (==>) (txt::Text) e =
715 (~:) (Text.unpack txt) $
716 (~?=)
717 (Ledger.write
718 Ledger.write_style
719 { Ledger.write_style_color = False
720 , Ledger.write_style_align = True } .
721 Ledger.write_date <$>
722 rights [R.runParser_with_Error
723 (Ledger.read_date id Nothing <* R.eof) () "" txt])
724 [e]
725 in TestList
726 [ "" ~:
727 ((Ledger.write
728 Ledger.write_style
729 { Ledger.write_style_color = False
730 , Ledger.write_style_align = True } $
731 Ledger.write_date Date.nil)
732 ~?= "1970-01-01")
733 , "2000-01-01" ==> "2000-01-01"
734 , "2000-01-01_12:34:51_CET" ==> "2000-01-01_11:34:51"
735 , "2000-01-01_12:34:51+01:10" ==> "2000-01-01_11:24:51"
736 , "2000-01-01_12:34:51-01:10" ==> "2000-01-01_13:44:51"
737 , "2000-01-01_01:02:03" ==> "2000-01-01_01:02:03"
738 , "2000-01-01_01:02" ==> "2000-01-01_01:02"
739 , "2000-01-01_01:00" ==> "2000-01-01_01:00"
740 ]
741 , "write_amount" ~:
742 let (<==) (txt::Text) e =
743 (~:) (Text.unpack txt) $
744 (~?=)
745 (Ledger.write
746 Ledger.write_style
747 { Ledger.write_style_color = False
748 , Ledger.write_style_align = True } $
749 Ledger.write_amount e)
750 (TL.fromStrict txt)
751 in TestList
752 [ "0" <==
753 ( mempty
754 , Ledger.amount )
755 , "0.00" <==
756 ( mempty
757 , Ledger.amount { Ledger.amount_quantity = Decimal 2 0 } )
758 , "123" <==
759 ( mempty
760 , Ledger.amount { Ledger.amount_quantity = Decimal 0 123 } )
761 , "-123" <==
762 ( mempty
763 , Ledger.amount { Ledger.amount_quantity = Decimal 0 (- 123) } )
764 , "12.3" <==
765 ( mempty { Ledger.amount_style_fractioning = Just '.' }
766 , Ledger.amount { Ledger.amount_quantity = Decimal 1 123 } )
767 , "1,234.56" <==
768 ( mempty
769 { Ledger.amount_style_fractioning = Just '.'
770 , Ledger.amount_style_grouping_integral = Just $ Ledger.Amount_Style_Grouping ',' [3]
771 }
772 , Ledger.amount { Ledger.amount_quantity = Decimal 2 123456 })
773 , "123,456,789,01,2.3456789" <==
774 ( mempty
775 { Ledger.amount_style_fractioning = Just '.'
776 , Ledger.amount_style_grouping_integral = Just $ Ledger.Amount_Style_Grouping ',' [1, 2, 3]
777 }
778 , Ledger.amount { Ledger.amount_quantity = Decimal 7 1234567890123456789 } )
779 , "1234567.8_90_123_456_789" <==
780 ( mempty
781 { Ledger.amount_style_fractioning = Just '.'
782 , Ledger.amount_style_grouping_fractional = Just $ Ledger.Amount_Style_Grouping '_' [1, 2, 3]
783 }
784 , Ledger.amount { Ledger.amount_quantity = Decimal 12 1234567890123456789 })
785 , "1,2,3,4,5,6,7,89,012.3456789" <==
786 ( mempty
787 { Ledger.amount_style_fractioning = Just '.'
788 , Ledger.amount_style_grouping_integral = Just $ Ledger.Amount_Style_Grouping ',' [3, 2, 1]
789 }
790 , Ledger.amount { Ledger.amount_quantity = Decimal 7 1234567890123456789 })
791 , "1234567.890_12_3_4_5_6_7_8_9" <==
792 ( mempty
793 { Ledger.amount_style_fractioning = Just '.'
794 , Ledger.amount_style_grouping_fractional = Just $ Ledger.Amount_Style_Grouping '_' [3, 2, 1]
795 }
796 , Ledger.amount { Ledger.amount_quantity = Decimal 12 1234567890123456789 })
797 ]
798 , "write_amount_length" ~:
799 let (==>) (txt::Text) =
800 (~:) (Text.unpack txt) $
801 (~?=)
802 (Ledger.write_amount_length <$>
803 rights [R.runParser (Ledger.read_amount <* R.eof) () "" txt])
804 [Text.length txt]
805 in TestList $ (==>) <$>
806 [ "0.00"
807 , "123"
808 , "-123"
809 , "12.3"
810 , "12.5"
811 , "12.3"
812 , "1,234.56"
813 , "123,456,789,01,2.3456789"
814 , "1234567.8_90_123_456_789"
815 , "1,2,3,4,5,6,7,89,012.3456789"
816 , "1234567.890_12_3_4_5_6_7_8_9"
817 , "1000000.000_00_0_0_0_0_0_0_0"
818 , "999"
819 , "1000"
820 , "10,00€"
821 , "10,00 €"
822 , "€10,00"
823 , "€ 10,00"
824 , "EUR 10,00"
825 , "10,00 EUR"
826 , "\"4 2\" 10,00"
827 ]
828 , "write_account" ~:
829 let (==>) txt =
830 (~:) (Text.unpack txt) $
831 (~?=)
832 (let read (t::Text) =
833 rights [R.runParser
834 (Ledger.read_account <* R.eof)
835 () "" t] in
836 Ledger.write
837 Ledger.write_style
838 { Ledger.write_style_color = False
839 , Ledger.write_style_align = True } <$>
840 (read txt >>= \a ->
841 let Ledger.Posting_Typed ty ac = Ledger.read_posting_type a in
842 return $ Ledger.write_account ty ac)
843 )
844 [TL.fromStrict txt]
845 in TestList $ (==>) <$>
846 [ "A"
847 , "(A:B:C)"
848 , "[A:B:C]"
849 ]
850 , "write_transaction" ~:
851 let (==>) (txt::Text) =
852 (~:) (Text.unpack txt) .
853 (~?=) (
854 let write (txn, ctx) =
855 Ledger.write
856 Ledger.write_style
857 { Ledger.write_style_color = False
858 , Ledger.write_style_align = True } $
859 let jnl = Ledger.read_context_journal ctx in
860 let sty = Ledger.journal_amount_styles jnl in
861 Ledger.write_transaction sty txn in
862 either (const []) (pure . write) $
863 R.runParser_with_Error
864 (R.and_state (Ledger.read_transaction <* R.eof))
865 ( Ledger.read_context Chart.charted Ledger.journal
866 ::Ledger.Read_Context Ledger.Transaction [Ledger.Transaction] )
867 "" txt)
868 in TestList $
869 [ "2000-01-01 some wording\n A:B:C $1\n a:b:c" ==>
870 ["2000-01-01 some wording\n\tA:B:C $1\n\ta:b:c $-1\n"]
871 , "2000-01-01 some wording\n\tA:B:C $1\n\ta:b:c\n\t ; first comment\n\t ; second comment\n\t ; third comment" ==>
872 ["2000-01-01 some wording\n\tA:B:C $1\n\ta:b:c $-1\n\t ; first comment\n\t ; second comment\n\t ; third comment\n"]
873 , "2000-01-01 some wording\n\tA:B:C $1\n\tAA:BB:CC $123" ==> []
874 ] ++
875 [ "nil" ~:
876 ((Ledger.write
877 Ledger.write_style
878 { Ledger.write_style_color = False
879 , Ledger.write_style_align = True } $
880 Ledger.write_transaction
881 Ledger.amount_styles
882 Ledger.transaction)
883 ~?= "1970-01-01\n\n")
884 ]
885 ]
886 ]
A language for accounting