]> Git — Sourcephile - comptalang.git/blob - lcc/Hcompta/LCC/Read/Test.hs
stack: bump to lts-12.25
[comptalang.git] / lcc / Hcompta / LCC / Read / Test.hs
1 {-# LANGUAGE StandaloneDeriving #-}
2 {-# LANGUAGE NoMonomorphismRestriction #-}
3 {-# LANGUAGE UndecidableInstances #-}
4 {-# OPTIONS_GHC -fno-warn-orphans #-}
5 {-# OPTIONS_GHC -O0 #-}
6 module Read.Test where
7
8 import Test.Tasty
9 import Test.Tasty.HUnit
10
11 import Control.Applicative (Applicative(..), Alternative(..))
12 -- import Control.Arrow (first)
13 import Control.Monad (Monad(..), MonadPlus(..))
14 import Control.Monad.Trans.Class (MonadTrans(..))
15 import Data.Bool
16 import Data.Char (Char)
17 import qualified Data.Kind as Kind
18 import Data.Data ()
19 -- import Data.Decimal (DecimalRaw(..))
20 import Data.Either (Either(..))
21 import Data.Eq (Eq)
22 import Data.Fixed (Pico)
23 import Data.Function (($), (.), const, flip)
24 import Data.Functor (Functor(..), (<$>))
25 import Data.Functor.Identity (Identity(..))
26 import Data.Int (Int)
27 import Data.List.NonEmpty (NonEmpty(..))
28 import Data.Map.Strict (Map)
29 import Data.Maybe (Maybe(..))
30 import Data.Monoid (Monoid(..), (<>))
31 import Data.Ord (Ord(..))
32 import Data.Proxy
33 import Data.String (String)
34 import Data.Text (Text)
35 import Data.Type.Equality ((:~:)(..))
36 import Data.Word (Word)
37 import Prelude (Integer)
38 import System.FilePath.Posix (FilePath)
39 import Text.Show (Show(..))
40 import qualified Control.Exception.Safe as Exn
41 import qualified Control.Monad.Classes as MC
42 import qualified Control.Monad.Trans.State.Strict as SS
43 import qualified Data.Char as Char
44 import qualified Data.Foldable as Foldable
45 import qualified Data.List as List
46 -- import qualified Data.List.NonEmpty as NonEmpty
47 import qualified Data.Map.Strict as Map
48 import qualified Data.NonNull as NonNull
49 -- import qualified Data.Set as Set
50 import qualified Data.Strict as S
51 import qualified Data.Text as Text
52 import qualified Data.Time.Calendar as Time
53 import qualified Data.Time.LocalTime as Time
54 import qualified Data.TreeMap.Strict as TreeMap
55 import qualified Data.TreeMap.Strict.Zipper as TreeMap
56 import qualified Language.Symantic as Sym
57 import qualified Language.Symantic.Lib as Sym
58 -- import qualified Language.Symantic.Parsing as Sym
59 import qualified System.FilePath.Posix as FilePath
60 import qualified System.IO.Error as IO
61 import qualified Text.Megaparsec as P
62 import qualified Text.Megaparsec.Prim as P
63
64 import qualified Hcompta as H
65 import qualified Hcompta.LCC as LCC
66 import qualified Hcompta.LCC.Lib.Strict as S
67 import qualified Hcompta.LCC.Sym as Sym
68 -- import System.IO (IO)
69 import Prelude (Bounded)
70 -- import Control.Applicative (Alternative)
71 import Data.NonNull (NonNull)
72
73 test :: Text -> Assertion -> TestTree
74 test = testCase . elide . Foldable.foldMap escapeChar . Text.unpack
75
76 escapeChar :: Char -> String
77 escapeChar c | Char.isPrint c = [c]
78 escapeChar c = Char.showLitChar c ""
79
80 elide :: String -> String
81 elide s | List.length s > 42 = List.take 42 s <> ['…']
82 elide s = s
83
84 account :: [Text] -> LCC.Account
85 account = LCC.Account . NonNull.impureNonNull . (LCC.Name <$>)
86
87 tag :: [Text] -> Text -> LCC.Tag
88 tag p v = LCC.Tag
89 (LCC.Tag_Path $ NonNull.impureNonNull (LCC.Name <$> p))
90 (LCC.Tag_Data v)
91
92 account_ref :: [Text] -> LCC.Tag_Path
93 account_ref p = LCC.Tag_Path $ NonNull.impureNonNull $ LCC.Name <$> p
94
95 account_refs :: [([Text], [[Text]])] -> Map LCC.Tag_Path (Map LCC.Account ())
96 account_refs l =
97 Map.fromList $
98 (<$> l) $ \(anch, accts) ->
99 ( LCC.Tag_Path $ NonNull.impureNonNull $ LCC.Name <$> anch
100 , Map.fromList $ (,()) . account <$> accts
101 )
102
103 tags :: [([Text], Text)] -> LCC.Tags
104 tags l =
105 LCC.Tags $
106 TreeMap.from_List (flip (<>)) $
107 (<$> l) $ \(p, v) ->
108 (NonNull.impureNonNull (LCC.Name <$> p), [LCC.Tag_Data v])
109
110 amounts :: [(Text, LCC.Quantity)] -> LCC.Amounts
111 amounts l =
112 LCC.Amounts $
113 Map.fromList $
114 (<$> l) $ \(u, q) ->
115 (LCC.Unit u, q)
116
117 postings :: [LCC.Posting] -> LCC.Postings
118 postings l =
119 LCC.Postings $
120 Map.fromListWith (flip (<>)) $
121 (<$> l) $ \p ->
122 (LCC.posting_account p, [p])
123
124 comments :: [Text] -> [LCC.Comment]
125 comments = (LCC.Comment <$>)
126
127 sourcePos :: FilePath -> Word -> Word -> P.SourcePos
128 sourcePos fp l c = P.SourcePos fp (P.unsafePos l) (P.unsafePos c)
129
130 date :: Integer -> Int -> Int -> Int -> Int -> Pico -> Time.TimeZone -> LCC.Date
131 date y m d h m' s tz =
132 Time.zonedTimeToUTC $
133 Time.ZonedTime
134 (Time.LocalTime
135 (Time.fromGregorian y m d)
136 (Time.TimeOfDay h m' s))
137 tz
138
139 -- * Type 'Parsec'
140 newtype Parsec e s m a
141 = Parsec { unParsec :: P.ParsecT e s m a }
142 deriving (Functor, Applicative, Monad, MonadTrans, Alternative, MonadPlus, P.MonadParsec e s)
143
144 type instance MC.CanDo (Parsec e s m) (MC.EffState a) = 'False
145 type instance MC.CanDo (Parsec e s m) (MC.EffReader P.SourcePos) = 'True
146 type instance MC.CanDo (Parsec e s m) (MC.EffReader (S.Either Exn.IOException LCC.CanonFile)) = 'True
147
148 instance -- Gram_File
149 ( LCC.ParsecC e s
150 , Monad m
151 , MC.MonadState Context_Test (Parsec e s m)
152 , P.MonadParsec e s (P.ParsecT e s m)
153 , P.MonadParsec e s (Parsec e s m)
154 , s ~ Text
155 ) => LCC.Gram_IO (Parsec e Text m) where
156 g_canonfile g = do
157 fp <- g
158 return (fp, Right $ LCC.CanonFile fp)
159 g_read g_path g = do
160 lr <- LCC.g_at $ do
161 lr_path <- g_path
162 case lr_path of
163 S.Left e -> return $ \at -> S.Left $ at e
164 S.Right fp -> do
165 db <- context_test_files <$> MC.get
166 case Map.lookup fp db of
167 Nothing -> return $ \at -> S.Left $ at $
168 LCC.Error_Journal_Read fp $
169 IO.userError $ show db
170 Just txt -> return $ const $ S.Right (fp, txt)
171 case lr of
172 S.Left e -> return $ S.Left [e]
173 S.Right (LCC.PathFile fp_new, s_new) -> do
174 P.pushPosition $ P.initialPos fp_new
175 s_old <- P.getInput; P.setInput s_new
176
177 lr_a <- g
178
179 P.setInput s_old
180 P.popPosition
181
182 return lr_a
183 deriving instance LCC.ParsecC e s => Sym.Alter (Parsec e s m)
184 deriving instance LCC.ParsecC e s => Sym.Alt (Parsec e s m)
185 deriving instance LCC.ParsecC e s => Sym.App (Parsec e s m)
186 deriving instance LCC.ParsecC e s => Sym.Try (Parsec e s m)
187 deriving instance LCC.ParsecC e s => Sym.Gram_Rule (Parsec e s m)
188 deriving instance LCC.ParsecC e s => Sym.Gram_Terminal (Parsec e s m)
189 deriving instance LCC.ParsecC e s => Sym.Gram_RegR (Parsec e s m)
190 deriving instance LCC.ParsecC e s => Sym.Gram_RegL (Parsec e s m)
191 deriving instance LCC.ParsecC e s => Sym.Gram_CF (Parsec e s m)
192 deriving instance LCC.ParsecC e s => Sym.Gram_Meta P.SourcePos (Parsec e s m)
193 deriving instance LCC.ParsecC e s => Sym.Gram_Lexer (Parsec e s m)
194 deriving instance LCC.ParsecC e s => Sym.Gram_Op (Parsec e s m)
195 deriving instance LCC.ParsecC e s => LCC.Gram_Count (Parsec e s m)
196 deriving instance LCC.ParsecC e s => LCC.Gram_At (Parsec e s m)
197 deriving instance LCC.ParsecC e s => LCC.Gram_Char (Parsec e s m)
198 deriving instance LCC.ParsecC e s => LCC.Gram_Comment (Parsec e s m)
199 deriving instance LCC.ParsecC e s => LCC.Gram_Tag (Parsec e s m)
200 deriving instance LCC.ParsecC e s => LCC.Gram_Account (Parsec e s m)
201 deriving instance LCC.ParsecC e s => LCC.Gram_Amount (Parsec e s m)
202 deriving instance -- Gram_Posting
203 ( LCC.ParsecC e s
204 , LCC.Gram_Posting (P.ParsecT e s m)
205 , MC.MonadState (S.Maybe LCC.Unit) m
206 , MC.MonadState LCC.Chart m
207 , MC.MonadState LCC.Style_Amounts m
208 , MC.MonadState LCC.Year m
209 ) => LCC.Gram_Posting (Parsec e s m)
210 deriving instance -- Gram_Date
211 ( LCC.ParsecC e s
212 , LCC.Gram_Date (P.ParsecT e s m)
213 , MC.MonadState LCC.Year m
214 ) => LCC.Gram_Date (Parsec e s m)
215 deriving instance -- Gram_Transaction
216 ( LCC.ParsecC e s
217 , LCC.Gram_Transaction (P.ParsecT e s m)
218 , MC.MonadState (S.Maybe LCC.Unit) m
219 , MC.MonadState LCC.Chart m
220 , MC.MonadState LCC.Section m
221 , MC.MonadState LCC.Style_Amounts m
222 , MC.MonadState LCC.Year m
223 ) => LCC.Gram_Transaction (Parsec e s m)
224 deriving instance -- Gram_Chart
225 ( LCC.ParsecC e s
226 , LCC.Gram_Chart (P.ParsecT e s m)
227 , MC.MonadState LCC.Chart m
228 , MC.MonadState LCC.Section m
229 ) => LCC.Gram_Chart (Parsec e s m)
230 deriving instance (LCC.ParsecC e s, LCC.Gram_File (P.ParsecT e s m))
231 => LCC.Gram_File (Parsec e s m)
232 instance -- Gram_Journal
233 ( LCC.Gram_Account g
234 , LCC.Gram_At g
235 , LCC.Gram_Chart g
236 , LCC.Gram_File g
237 , LCC.Gram_IO g
238 , LCC.Gram_Reader (S.Either Exn.IOException LCC.CanonFile) g
239 , LCC.Gram_State Context_Test g
240 , LCC.Gram_State (LCC.Context_Read j) g
241 , LCC.Gram_State (LCC.Journal j) g
242 , LCC.Gram_State (LCC.Journals j) g
243 , LCC.Gram_State (LCC.Env cs is) g
244 , LCC.Gram_State (LCC.ProtoEnv cs is) g
245 , LCC.Gram_Transaction g
246 , LCC.Gram_Term cs is (Parsec e Text m)
247 , LCC.ParsecC e Text
248 , Sym.Try g
249 , Sym.Gram_Lexer g
250 , Monoid j
251 , g ~ Parsec e Text m
252 ) => LCC.Gram_Journal cs is j (Parsec e Text m)
253 deriving instance -- Gram_Term
254 ( Sym.Gram_Term is LCC.Meta (P.ParsecT e s m)
255 , Sym.Gram_Term_AtomsR LCC.Meta is is (Parsec e s m)
256 , LCC.ParsecC e s
257 ) => Sym.Gram_Term is LCC.Meta (Parsec e s m)
258 deriving instance LCC.ParsecC e s => Sym.Gram_Meta LCC.Meta (Parsec e s m)
259 deriving instance LCC.ParsecC e s => Sym.Gram_Error (Parsec e s m)
260 deriving instance LCC.ParsecC e s => Sym.Gram_Name (Parsec e s m)
261 deriving instance LCC.ParsecC e s => Sym.Gram_Term_Type LCC.Meta (Parsec e s m)
262 deriving instance LCC.ParsecC e s => Sym.Gram_Type LCC.Meta (Parsec e s m)
263 deriving instance -- Gram_Term
264 ( LCC.Gram_Term cs is (P.ParsecT e s m)
265 , Sym.Gram_Term is LCC.Meta (Parsec e s m)
266 , MC.MonadState (LCC.Env cs is) m
267 , MC.MonadState (LCC.ProtoEnv cs is) m
268 , LCC.ParsecC e s
269 ) => LCC.Gram_Term cs is (Parsec e s m)
270 instance -- Gram_State
271 ( LCC.ParsecC e s
272 , MC.MonadState ctx (Parsec e s m)
273 ) => LCC.Gram_State ctx (Parsec e s m) where
274 g_get g = do
275 f <- g
276 s <- MC.get
277 return (f s)
278 g_state g = do
279 f <- g
280 s <- MC.get
281 let (s', a) = f s
282 MC.put s'
283 return a
284 g_put g = do
285 (s, a) <- g
286 MC.put s
287 return a
288 instance -- Gram_Reader
289 ( LCC.ParsecC e s
290 , MC.MonadReader ctx (Parsec e s m)
291 ) => LCC.Gram_Reader ctx (Parsec e s m) where
292 g_ask g = do
293 f <- g
294 s <- MC.ask
295 return (f s)
296 g_ask_before g = do
297 s <- MC.ask
298 f <- g
299 return (f s)
300 instance LCC.ParsecC e s => MC.MonadReaderN 'MC.Zero
301 P.SourcePos (Parsec e s m) where
302 askN _px = Parsec P.getPosition
303 instance LCC.ParsecC e s => MC.MonadReaderN 'MC.Zero
304 (NonEmpty P.SourcePos) (Parsec e s m) where
305 askN _px = Parsec $ P.statePos <$> P.getParserState
306 instance LCC.ParsecC e s => MC.MonadReaderN 'MC.Zero
307 (S.Either Exn.IOException LCC.CanonFile) (Parsec e s m) where
308 askN _px = Parsec $ S.Right . LCC.CanonFile . LCC.PathFile . P.sourceName <$> P.getPosition
309
310 -- * Type 'Context_Test'
311 data Context_Test
312 = Context_Test
313 { context_test_files :: Map LCC.PathFile Text
314 } deriving (Eq, Show)
315 type instance MC.CanDo (S.StateT (LCC.Context_Read j) m) (MC.EffState Context_Test) = 'False
316 type instance MC.CanDo (S.StateT Context_Test m) (MC.EffState Context_Test) = 'True
317 type instance MC.CanDo (S.StateT (LCC.Context_Sym cs is) m) (MC.EffState Context_Test) = 'False
318 instance Monad m => MC.MonadStateN 'MC.Zero Context_Test (S.StateT Context_Test m) where
319 stateN _px = S.StateT . SS.state
320
321 type instance MC.CanDo (S.StateT Context_Test m) (MC.EffState (Sym.Tokenizers meta is)) = 'False
322
323 read
324 :: forall is j cs e m a.
325 ( Monoid j
326 , LCC.Gram_File (P.ParsecT P.Dec Text m)
327 , Sym.Tokenize LCC.Meta is
328 , m ~ S.StateT (LCC.Context_Read j)
329 (S.StateT (LCC.Context_Sym cs is)
330 (S.StateT Context_Test Identity))
331 , e ~ P.ParseError Char P.Dec
332 , cs ~ Sym.TyConsts_of_Ifaces is
333 ) => Sym.CF (Parsec P.Dec Text m) a
334 -> [(LCC.PathFile, Text)]
335 -> FilePath
336 -> Text
337 -> Either (P.ParseError Char P.Dec) a
338 read g files fp inp =
339 runIdentity $
340 S.evalState Context_Test{ context_test_files = Map.fromList files } $
341 S.evalState LCC.context_sym $
342 S.evalState LCC.context_read $
343 P.runParserT (unParsec . Sym.unCF $ g <* Sym.eoi)
344 (case fp of "" -> ""; _ -> FilePath.normalise fp) inp
345
346 type M cs is j
347 = S.StateT (LCC.Context_Read j)
348 (S.StateT (LCC.Context_Sym cs is)
349 (S.StateT Context_Test Identity))
350
351 test_compile
352 :: forall is is' cs h j.
353 ( Eq h
354 , is ~ (Proxy LCC.Quantity ': Proxy Bool ': {-Proxy LCC.Journal ': Proxy LCC.Transaction ': Proxy [] ':-} is')
355 , Sym.Tokenize LCC.Meta is
356 , Sym.Inj_Token LCC.Meta is (->)
357 , Sym.Inj_TyConst cs (->)
358 , Sym.Inj_TyConst cs Bool
359 , Sym.Inj_TyConst cs LCC.Journal
360 , Sym.Inj_TyConst cs LCC.Transaction
361 , Sym.Inj_TyConst cs LCC.Quantity
362 , Sym.Inj_TyConst cs []
363 -- , Sym.Inj_TyConst cs Show
364 -- , Sym.Inj_TyConst cs Eq
365 , Show h
366 , Sym.Show_Token LCC.Meta is
367 , Sym.Show_TyConst cs
368 , Sym.Compile cs is
369 , Sym.Eq_Token LCC.Meta is
370 , Sym.Gram_Term is LCC.Meta (P.ParsecT P.Dec Text (M cs is j))
371 , Sym.Sym_of_Ifaces is Sym.HostI
372 , Sym.Gram_Term_AtomsR LCC.Meta is is (P.ParsecT P.Dec Text (M cs is j))
373 , Sym.Gram_Term_AtomsR LCC.Meta is is (Parsec P.Dec Text (M cs is j))
374 , cs ~ Sym.TyConsts_of_Ifaces is
375 , Monoid j
376 ) => Proxy j
377 -> [Text]
378 -> ( Sym.TeName
379 , Sym.Type cs h
380 , Either (Either (P.ParseError Char P.Dec)
381 (LCC.At (Sym.Error_Term LCC.Meta cs is)))
382 h
383 )
384 -> TestTree
385 test_compile _j i (n_exp, ty_exp, lr_exp) =
386 let inp = Text.intercalate "\n" i in
387 {-
388 let env :: LCC.Env cs is = Map.fromList
389 [ ("j" , Sym.ETermClosed (Sym.ty @Bool) $
390 Sym.TermClosed $ Sym.bool True)
391 , ("jnl", Sym.ETermClosed (Sym.ty @LCC.Journal Sym.:$ (Sym.ty @[] Sym.:$ Sym.ty @LCC.Transaction)) $
392 Sym.TermClosed $ Sym.journal LCC.journal)
393 ] in
394 -}
395 test inp $
396 case read @is @j ({-LCC.g_put (pure (env, ())) *>-} LCC.g_term) [] "" inp of
397 Left err_syn -> Left (Left err_syn) @?= lr_exp
398 Right (n_got, lr_sem) ->
399 case lr_sem of
400 Left err_sem -> Left (Right err_sem) @?= lr_exp
401 Right got ->
402 case lr_exp of
403 Left err -> Right ("…"::Text) @?= Left err
404 Right (_te_exp::h) ->
405 (>>= (@?= (n_exp, lr_exp))) $
406 ((n_got,) <$>) $
407 return $
408 case got `Sym.feed_args`
409 [ Sym.ETermClosed
410 (Sym.ty @LCC.Quantity)
411 (Sym.TermClosed $ Sym.quantity 42)
412 , Sym.ETermClosed
413 (Sym.ty @Bool)
414 (Sym.TermClosed $ Sym.bool True)
415 ] of
416 Sym.ETermClosed ty_got (Sym.TermClosed te_got) ->
417 case ty_got `Sym.eq_Type` ty_exp of
418 Nothing -> err_type (Sym.EType ty_got)
419 Just Refl -> Right $ Sym.host_from_term te_got
420 where
421 err_type ty_got =
422 Left $ Right $
423 LCC.At (P.initialPos "" :| []) (P.initialPos "") $
424 Sym.Error_Term_Con_Type $ Right $
425 Sym.Con_TyEq
426 (Right $ Sym.At Nothing ty_got)
427 (Sym.At Nothing $ Sym.EType ty_exp)
428
429 read_gram
430 :: forall is cs j e m a.
431 ( Monoid j
432 , LCC.Gram_File (P.ParsecT P.Dec Text m)
433 , Sym.Tokenize LCC.Meta is
434 , m ~ S.StateT (LCC.Context_Read j)
435 (S.StateT (LCC.Context_Sym cs is)
436 (S.StateT Context_Test Identity))
437 , e ~ P.ParseError Char P.Dec
438 , j ~ [LCC.Transaction]
439 , cs ~ Sym.TyConsts_of_Ifaces is
440 , is ~ '[Proxy (->)]
441 )
442 => Sym.CF (Parsec P.Dec Text m) a
443 -> Text
444 -> Either (P.ParseError Char P.Dec) a
445 read_gram g inp =
446 runIdentity $
447 S.evalState Context_Test{ context_test_files = Map.fromList [] } $
448 S.evalState LCC.context_sym $
449 S.evalState LCC.context_read $
450 P.runParserT (unParsec . Sym.unCF $ g <* Sym.eoi) "" inp
451
452 tests :: TestTree
453 tests = testGroup "Read"
454 [{- testGroup "Date" $
455 let (==>) inp exp =
456 test inp $
457 read_gram LCC.g_date inp @?= Right (S.Right exp) in
458 [ "2000-01-13" ==> date 2000 01 13 0 0 0 Time.utc
459 , "2000-01-13_12:34" ==> date 2000 01 13 12 34 0 Time.utc
460 , "2000-01-13_12:34:56" ==> date 2000 01 13 12 34 56 Time.utc
461 , "2000-01-13_12:34_CET" ==> date 2000 01 13 12 34 0 (Time.TimeZone 60 True "CET")
462 , "2000-01-13_12:34+01:30" ==> date 2000 01 13 12 34 0 (Time.TimeZone 90 False "+01:30")
463 , "2000-01-13_12:34:56_CET" ==> date 2000 01 13 12 34 56 (Time.TimeZone 60 True "CET")
464 , "01-01" ==> date 1970 01 01 0 0 0 Time.utc
465 , testGroup "Parsing errors" $
466 let (!=>) inp exp =
467 test inp $
468 read_gram LCC.g_date inp @?= Left exp in
469 [ "2000/01/13" !=> P.ParseError
470 { P.errorPos = sourcePos "" 1 5 :| []
471 , P.errorUnexpected = Set.fromList [P.Tokens ('/' :| "")]
472 , P.errorExpected = Set.fromList [P.Tokens ('-' :| "")]
473 , P.errorCustom = Set.fromList []
474 }
475 ]
476 , testGroup "Semantic errors" $
477 let (=!>) inp exp =
478 test inp $
479 read_gram LCC.g_date inp @?= Right (S.Left exp) in
480 [ "2000-13-01" =!> LCC.At
481 { LCC.atBegin = pure $ sourcePos "" 1 1
482 , LCC.atEnd = sourcePos "" 1 11
483 , LCC.atItem = LCC.Error_Date_Day_invalid (2000, 13, 01) }
484 , "2001-02-29" =!> LCC.At
485 { LCC.atBegin = pure $ sourcePos "" 1 1
486 , LCC.atEnd = sourcePos "" 1 11
487 , LCC.atItem = LCC.Error_Date_Day_invalid (2001, 2, 29) }
488 , "2000-01-13_12:60" =!> LCC.At
489 { LCC.atBegin = pure $ sourcePos "" 1 12
490 , LCC.atEnd = sourcePos "" 1 17
491 , LCC.atItem = LCC.Error_Date_TimeOfDay_invalid (12, 60, 0) }
492 ]
493 ]
494 , testGroup "Account_Section" $
495 let (==>) inp exp =
496 test inp $
497 rights [read_gram LCC.g_account_section inp]
498 @?= [LCC.Name inp | exp] in
499 [ "A" ==> True
500 , "AA" ==> True
501 , "(A)A" ==> True
502 , "(A)" ==> True
503 , "A(A)" ==> True
504 , "[A]A" ==> True
505 , "[A]" ==> True
506 , testGroup "Parsing errors"
507 [ "" ==> False
508 , " " ==> False
509 , "/" ==> False
510 , "A/" ==> False
511 , "/A" ==> False
512 , "A " ==> False
513 , "A A" ==> False
514 , "A " ==> False
515 , "A\t" ==> False
516 , "A \n" ==> False
517 , "( )A" ==> False
518 , "(A) A" ==> False
519 , "[ ] A" ==> False
520 , "(A) " ==> False
521 , "[A] A" ==> False
522 , "[A] " ==> False
523 ]
524 ]
525 , testGroup "Account" $
526 let (==>) inp exp =
527 test inp $
528 read_gram LCC.g_account inp
529 @?= Right (account exp) in
530 [ "/A" ==> ["A"]
531 , "/A/B" ==> ["A", "B"]
532 , "/A/B/C" ==> ["A", "B","C"]
533 , "/Aa/Bbb/Cccc" ==> ["Aa", "Bbb", "Cccc"]
534 , "/A/B/(C)" ==> ["A", "B", "(C)"]
535 , testGroup "Parsing errors" $
536 let (!=>) inp _exp =
537 test inp $
538 rights [read_gram LCC.g_account inp]
539 @?= [] in
540 [ "" !=> []
541 , "A" !=> []
542 , "A/" !=> []
543 , "A " !=> []
544 , " A" !=> []
545 , "/A/ /C" !=> []
546 , "/A//C" !=> []
547 , "/A a / B b b / C c c c" !=> []
548 ]
549 ]
550 , testGroup "Amount" $
551 let (==>) inp exp =
552 test inp $
553 read_gram LCC.g_amount inp @?= Right exp in
554 [ "0" ==>
555 ( LCC.style_amount
556 , LCC.amount { LCC.amount_quantity = Decimal 0 0 } )
557 , "00" ==>
558 ( LCC.style_amount
559 , LCC.amount { LCC.amount_quantity = Decimal 0 0 } )
560 , "0." ==>
561 ( LCC.style_amount { LCC.style_amount_fractioning = pure '.' }
562 , LCC.amount { LCC.amount_quantity = Decimal 0 0 } )
563 , "0," ==>
564 ( LCC.style_amount { LCC.style_amount_fractioning = pure ',' }
565 , LCC.amount { LCC.amount_quantity = Decimal 0 0 } )
566 , "0.0" ==>
567 ( LCC.style_amount { LCC.style_amount_fractioning = pure '.' }
568 , LCC.amount { LCC.amount_quantity = Decimal 1 0 } )
569 , "00.00" ==>
570 ( LCC.style_amount { LCC.style_amount_fractioning = pure '.' }
571 , LCC.amount { LCC.amount_quantity = Decimal 2 0 } )
572 , "0,0" ==>
573 ( LCC.style_amount { LCC.style_amount_fractioning = pure ',' }
574 , LCC.amount { LCC.amount_quantity = Decimal 1 0 } )
575 , "00,00" ==>
576 ( LCC.style_amount { LCC.style_amount_fractioning = pure ',' }
577 , LCC.amount { LCC.amount_quantity = Decimal 2 0 } )
578 , "0_0" ==>
579 ( LCC.style_amount { LCC.style_amount_grouping_integral = pure $ LCC.Style_Amount_Grouping '_' [1] }
580 , LCC.amount { LCC.amount_quantity = Decimal 0 0 } )
581 , "00_00" ==>
582 ( LCC.style_amount { LCC.style_amount_grouping_integral = pure $ LCC.Style_Amount_Grouping '_' [2] }
583 , LCC.amount { LCC.amount_quantity = Decimal 0 0 } )
584 , "0,000.00" ==>
585 ( LCC.style_amount
586 { LCC.style_amount_fractioning = pure '.'
587 , LCC.style_amount_grouping_integral = pure $ LCC.Style_Amount_Grouping ',' [3] }
588 , LCC.amount { LCC.amount_quantity = Decimal 2 0 } )
589 , "0.000,00" ==>
590 ( LCC.style_amount
591 { LCC.style_amount_fractioning = pure ','
592 , LCC.style_amount_grouping_integral = pure $ LCC.Style_Amount_Grouping '.' [3] }
593 , LCC.amount { LCC.amount_quantity = Decimal 2 0 } )
594 , "1,000.00" ==>
595 ( LCC.style_amount
596 { LCC.style_amount_fractioning = pure '.'
597 , LCC.style_amount_grouping_integral = pure $ LCC.Style_Amount_Grouping ',' [3] }
598 , LCC.amount { LCC.amount_quantity = Decimal 2 100000 } )
599 , "1.000,00" ==>
600 ( LCC.style_amount
601 { LCC.style_amount_fractioning = pure ','
602 , LCC.style_amount_grouping_integral = pure $ LCC.Style_Amount_Grouping '.' [3] }
603 , LCC.amount { LCC.amount_quantity = Decimal 2 100000 } )
604 , "123" ==>
605 ( LCC.style_amount
606 , LCC.amount { LCC.amount_quantity = Decimal 0 123 } )
607 , "1.2" ==>
608 ( LCC.style_amount { LCC.style_amount_fractioning = pure '.' }
609 , LCC.amount { LCC.amount_quantity = Decimal 1 12 } )
610 , "1,2" ==>
611 ( LCC.style_amount { LCC.style_amount_fractioning = pure ',' }
612 , LCC.amount { LCC.amount_quantity = Decimal 1 12 } )
613 , "12.34" ==>
614 ( LCC.style_amount { LCC.style_amount_fractioning = pure '.' }
615 , LCC.amount { LCC.amount_quantity = Decimal 2 1234 } )
616 , "12,34" ==>
617 ( LCC.style_amount { LCC.style_amount_fractioning = pure ',' }
618 , LCC.amount { LCC.amount_quantity = Decimal 2 1234 } )
619 , "1_2" ==>
620 ( LCC.style_amount { LCC.style_amount_grouping_integral = pure $ LCC.Style_Amount_Grouping '_' [1] }
621 , LCC.amount { LCC.amount_quantity = Decimal 0 12 } )
622 , "1_23" ==>
623 ( LCC.style_amount { LCC.style_amount_grouping_integral = pure $ LCC.Style_Amount_Grouping '_' [2] }
624 , LCC.amount { LCC.amount_quantity = Decimal 0 123 } )
625 , "1_23_456" ==>
626 ( LCC.style_amount { LCC.style_amount_grouping_integral = pure $ LCC.Style_Amount_Grouping '_' [3, 2] }
627 , LCC.amount { LCC.amount_quantity = Decimal 0 123456 } )
628 , "1_23_456,7890_12345_678901" ==>
629 ( LCC.style_amount
630 { LCC.style_amount_fractioning = pure ','
631 , LCC.style_amount_grouping_integral = pure $ LCC.Style_Amount_Grouping '_' [3, 2]
632 , LCC.style_amount_grouping_fractional = pure $ LCC.Style_Amount_Grouping '_' [4, 5, 6] }
633 , LCC.amount { LCC.amount_quantity = Decimal 15 123456789012345678901 } )
634 , "1_23_456.7890_12345_678901" ==>
635 ( LCC.style_amount
636 { LCC.style_amount_fractioning = pure '.'
637 , LCC.style_amount_grouping_integral = pure $ LCC.Style_Amount_Grouping '_' [3, 2]
638 , LCC.style_amount_grouping_fractional = pure $ LCC.Style_Amount_Grouping '_' [4, 5, 6] }
639 , LCC.amount { LCC.amount_quantity = Decimal 15 123456789012345678901 } )
640 , "1,23,456.7890_12345_678901" ==>
641 ( LCC.style_amount
642 { LCC.style_amount_fractioning = pure '.'
643 , LCC.style_amount_grouping_integral = pure $ LCC.Style_Amount_Grouping ',' [3, 2]
644 , LCC.style_amount_grouping_fractional = pure $ LCC.Style_Amount_Grouping '_' [4, 5, 6] }
645 , LCC.amount { LCC.amount_quantity = Decimal 15 123456789012345678901 } )
646 , "1.23.456,7890_12345_678901" ==>
647 ( LCC.style_amount
648 { LCC.style_amount_fractioning = pure ','
649 , LCC.style_amount_grouping_integral = pure $ LCC.Style_Amount_Grouping '.' [3, 2]
650 , LCC.style_amount_grouping_fractional = pure $ LCC.Style_Amount_Grouping '_' [4, 5, 6] }
651 , LCC.amount { LCC.amount_quantity = Decimal 15 123456789012345678901 } )
652 , "123456_78901_2345.678_90_1" ==>
653 ( LCC.style_amount
654 { LCC.style_amount_fractioning = pure '.'
655 , LCC.style_amount_grouping_integral = pure $ LCC.Style_Amount_Grouping '_' [4, 5, 6]
656 , LCC.style_amount_grouping_fractional = pure $ LCC.Style_Amount_Grouping '_' [3, 2] }
657 , LCC.amount { LCC.amount_quantity = Decimal 6 123456789012345678901 } )
658 , "$1" ==>
659 ( LCC.style_amount
660 { LCC.style_amount_unit_side = pure LCC.L
661 , LCC.style_amount_unit_spaced = pure False }
662 , LCC.amount
663 { LCC.amount_quantity = Decimal 0 1
664 , LCC.amount_unit = "$" } )
665 , "1$" ==>
666 ( LCC.style_amount
667 { LCC.style_amount_unit_side = pure LCC.R
668 , LCC.style_amount_unit_spaced = pure False }
669 , LCC.amount
670 { LCC.amount_quantity = Decimal 0 1
671 , LCC.amount_unit = "$" } )
672 , "$ 1" ==>
673 ( LCC.style_amount
674 { LCC.style_amount_unit_side = pure LCC.L
675 , LCC.style_amount_unit_spaced = pure True }
676 , LCC.amount
677 { LCC.amount_quantity = Decimal 0 1
678 , LCC.amount_unit = "$" } )
679 , "1 $" ==>
680 ( LCC.style_amount
681 { LCC.style_amount_unit_side = pure LCC.R
682 , LCC.style_amount_unit_spaced = pure True }
683 , LCC.amount
684 { LCC.amount_quantity = Decimal 0 1
685 , LCC.amount_unit = "$" } )
686 , "-$1" ==>
687 ( LCC.style_amount
688 { LCC.style_amount_unit_side = pure LCC.L
689 , LCC.style_amount_unit_spaced = pure False }
690 , LCC.amount
691 { LCC.amount_quantity = Decimal 0 (-1)
692 , LCC.amount_unit = "$" } )
693 , "$1.000,00" ==>
694 ( LCC.style_amount
695 { LCC.style_amount_fractioning = pure ','
696 , LCC.style_amount_grouping_integral = pure $ LCC.Style_Amount_Grouping '.' [3]
697 , LCC.style_amount_unit_side = pure LCC.L
698 , LCC.style_amount_unit_spaced = pure False }
699 , LCC.amount
700 { LCC.amount_quantity = Decimal 2 100000
701 , LCC.amount_unit = "$" } )
702 , "1.000,00$" ==>
703 ( LCC.style_amount
704 { LCC.style_amount_fractioning = pure ','
705 , LCC.style_amount_grouping_integral = pure $ LCC.Style_Amount_Grouping '.' [3]
706 , LCC.style_amount_unit_side = pure LCC.R
707 , LCC.style_amount_unit_spaced = pure False }
708 , LCC.amount
709 { LCC.amount_quantity = Decimal 2 100000
710 , LCC.amount_unit = "$" } )
711 , testGroup "Parsing errors" $
712 let (!=>) inp _exp =
713 test inp $
714 rights [read_gram LCC.g_amount inp] @?= [] in
715 [ "" !=> []
716 , ".0" !=> []
717 , ",0" !=> []
718 , "0_" !=> []
719 , "_0" !=> []
720 , "1,000.00." !=> []
721 , "1.000,00," !=> []
722 , "1,000.00_" !=> []
723 ]
724 ]
725 , testGroup "Comment" $
726 let (==>) (inp, post) exp =
727 test inp $
728 rights [read_gram (LCC.g_comment <* post) inp]
729 @?= (LCC.Comment <$> exp) in
730 [ ("; a b c" , Sym.eoi) ==> [ "a b c" ]
731 , ("; #a" , Sym.eoi) ==> [ "#a" ]
732 , ("; a b c \n" , Sym.string " \n") ==> [ "a b c" ]
733 , ("; a b c \r\n", Sym.string " \r\n") ==> [ "a b c" ]
734 -- , ("; a b c\n ; d e f", Sym.eoi) ==> [ ["a b c", "d e f"] ]
735 -- , ("; a b c \n", Sym.string " \n") ==> [ ["a b c"] ]
736 ]
737 , testGroup "Transaction_Tag" $
738 let (==>) inp exp =
739 test inp $
740 read_gram LCC.g_transaction_tag inp
741 @?= Right (LCC.Transaction_Tag exp) in
742 [ "#Name" ==> tag ["Name"] ""
743 , "#Name:name" ==> tag ["Name", "name"] ""
744 , "#Name=Value" ==> tag ["Name"] "Value"
745 , "#Name = Value" ==> tag ["Name"] "Value"
746 , "#Name=Val ue" ==> tag ["Name"] "Val ue"
747 , "#Name=," ==> tag ["Name"] ","
748 , "#Name=Val,ue" ==> tag ["Name"] "Val,ue"
749 , "#Name=Val,ue:" ==> tag ["Name"] "Val,ue:"
750 , "#Name=Val,ue :" ==> tag ["Name"] "Val,ue :"
751 , testGroup "Parsing errors" $
752 let (!=>) inp _exp =
753 test inp $
754 rights [read_gram LCC.g_transaction_tag inp] @?= [] in
755 [ "#Name:" !=> []
756 , "#Name=Value\n" !=> []
757 ]
758 ]
759 , testGroup "Posting" $
760 let (==>) inp exp =
761 test inp $
762 read_gram LCC.g_posting inp @?= Right (S.Right exp) in
763 [ "/A/B/C" ==> LCC.posting (account ["A", "B", "C"])
764 , "/A/B/C $1" ==> (LCC.posting $ account ["A", "B", "C"])
765 { LCC.posting_amounts = amounts [("$", 1)] }
766 , "/A/B/C $1" ==> (LCC.posting $ account ["A", "B", "C"])
767 { LCC.posting_amounts = amounts [("$", 1)] }
768 , "/A/B/C 1€" ==> (LCC.posting $ account ["A", "B", "C"])
769 { LCC.posting_amounts = amounts [("€", 1)] }
770 , "/A/B/C $1; some comment" ==> (LCC.posting $ account ["A", "B", "C"])
771 { LCC.posting_amounts = amounts [("$", 1)]
772 , LCC.posting_comments = comments ["some comment"] }
773 , "/A/B/C; some comment" ==>
774 (LCC.posting $ account ["A", "B", "C"])
775 { LCC.posting_comments = comments ["some comment"] }
776 , "/A/B/C ; some comment" ==> (LCC.posting $ account ["A", "B", "C"])
777 { LCC.posting_amounts = amounts []
778 , LCC.posting_comments = comments ["some comment"] }
779 , "/A/B/C ; some comment\n ; some other comment" ==>
780 (LCC.posting $ account ["A", "B", "C"])
781 { LCC.posting_amounts = amounts []
782 , LCC.posting_comments = comments ["some comment", "some other comment"] }
783 , "/A/B/C $1 ; some comment" ==>
784 (LCC.posting $ account ["A", "B", "C"])
785 { LCC.posting_amounts = amounts [("$", 1)]
786 , LCC.posting_comments = comments ["some comment"] }
787 , "/A/B/C #N=V" ==>
788 (LCC.posting $ account ["A", "B", "C"])
789 { LCC.posting_tags = LCC.Posting_Tags $ tags [ (["N"], "V") ] }
790 , "/A/B/C #N:O=V" ==>
791 (LCC.posting $ account ["A", "B", "C"])
792 { LCC.posting_tags = LCC.Posting_Tags $ tags [ (["N", "O"], "V") ] }
793 , "/A/B/C #N=Val;ue" ==>
794 (LCC.posting $ account ["A", "B", "C"])
795 { LCC.posting_tags = LCC.Posting_Tags $ tags [ (["N"], "Val;ue") ] }
796 , "/A/B/C #N=Val#ue" ==>
797 (LCC.posting $ account ["A", "B", "C"])
798 { LCC.posting_tags = LCC.Posting_Tags $ tags [ (["N"], "Val#ue") ] }
799 , "/A/B/C #N=V ; not a comment" ==>
800 (LCC.posting $ account ["A", "B", "C"])
801 { LCC.posting_tags = LCC.Posting_Tags $ tags [ (["N"], "V ; not a comment") ] }
802 , "/A/B/C #N=V #O" ==>
803 (LCC.posting $ account ["A", "B", "C"])
804 { LCC.posting_tags = LCC.Posting_Tags $ tags [ (["N"], "V #O") ] }
805 , "/A/B/C #N#O" ==>
806 (LCC.posting $ account ["A", "B", "C"])
807 { LCC.posting_tags = LCC.Posting_Tags $ tags [ (,) ["N"] "", (,) ["O"] "" ] }
808 , "/A/B/C #N; #O" ==>
809 (LCC.posting $ account ["A", "B", "C"])
810 { LCC.posting_tags = LCC.Posting_Tags $ tags [ (["N"], "") ]
811 , LCC.posting_comments = comments ["#O"] }
812 , "/A/B/C #N #O" ==>
813 (LCC.posting $ account ["A", "B", "C"])
814 { LCC.posting_tags = LCC.Posting_Tags $ tags [ (,) ["N"] "", (,) ["O"] "" ] }
815 , "/A/B/C \n #N=V" ==>
816 (LCC.posting $ account ["A", "B", "C"])
817 { LCC.posting_tags = LCC.Posting_Tags $ tags [ (["N"], "V") ] }
818 , "/A/B/C ; some comment\n #N=V" ==>
819 (LCC.posting $ account ["A", "B", "C"])
820 { LCC.posting_comments = comments ["some comment"]
821 , LCC.posting_tags = LCC.Posting_Tags $ tags [ (["N"], "V") ] }
822 , "/A/B/C ; some comment\n #N=V v\n #N2=V2 v2" ==>
823 (LCC.posting $ account ["A", "B", "C"])
824 { LCC.posting_comments = comments ["some comment"]
825 , LCC.posting_tags = LCC.Posting_Tags $ tags
826 [ (["N"], "V v")
827 , (["N2"], "V2 v2") ] }
828 , "/A/B/C\n #N=V\n #N=V2" ==>
829 (LCC.posting $ account ["A", "B", "C"])
830 { LCC.posting_tags = LCC.Posting_Tags $ tags
831 [ (["N"], "V")
832 , (["N"], "V2")
833 ] }
834 , "/A/B/C\n #N=V\n #N2=V" ==>
835 (LCC.posting $ account ["A", "B", "C"])
836 { LCC.posting_tags = LCC.Posting_Tags $ tags
837 [ (["N"], "V")
838 , (["N2"], "V")
839 ] }
840 ]
841 , testGroup "Transaction" $
842 let (==>) i e =
843 let inp = Text.intercalate "\n" i in
844 test inp $
845 read_gram LCC.g_transaction inp @?= Right (S.Right e) in
846 [ [ "2000-01-01 some wording"
847 , " /A/B/C $1"
848 , " /D/E/F $-1"
849 ] ==> LCC.transaction
850 { LCC.transaction_dates = date 2000 01 01 0 0 0 Time.utc `NonNull.ncons` []
851 , LCC.transaction_wording = "some wording"
852 , LCC.transaction_postings = postings
853 [ (LCC.posting $ account ["A", "B", "C"])
854 { LCC.posting_amounts = amounts [ ("$", 1) ]
855 , LCC.posting_sourcepos = sourcePos "" 2 2 }
856 , (LCC.posting $ account ["D", "E", "F"])
857 { LCC.posting_amounts = amounts [ ("$", -1) ]
858 , LCC.posting_sourcepos = sourcePos "" 3 2 }
859 ]
860 }
861 , [ "2000-01-01 some wording ; not a comment"
862 , "; some other;comment"
863 , " ; some last comment"
864 , " /A/B/C $1"
865 , " /D/E/F"
866 ] ==> LCC.transaction
867 { LCC.transaction_comments = comments
868 [ "some other;comment"
869 , "some last comment"
870 ]
871 , LCC.transaction_dates = date 2000 01 01 0 0 0 Time.utc `NonNull.ncons` []
872 , LCC.transaction_wording = "some wording ; not a comment"
873 , LCC.transaction_postings = postings
874 [ (LCC.posting $ account ["A", "B", "C"])
875 { LCC.posting_amounts = amounts [ ("$", 1) ]
876 , LCC.posting_sourcepos = sourcePos "" 4 2 }
877 , (LCC.posting $ account ["D", "E", "F"])
878 { LCC.posting_amounts = amounts [ ("$", -1) ]
879 , LCC.posting_sourcepos = sourcePos "" 5 2 }
880 ]
881 }
882 , testGroup "Semantic errors" $
883 let (=!>) i e =
884 let inp = Text.intercalate "\n" i in
885 test inp $
886 read_gram LCC.g_transaction inp @?= Right (S.Left e) in
887 [ [ "2000-01-01 wording"
888 , " /A/B/C $1"
889 , " /D/E/F $-2"
890 ] =!> LCC.At
891 { LCC.atBegin = pure $ sourcePos "" 1 1
892 , LCC.atEnd = sourcePos "" 3 12
893 , LCC.atItem = LCC.Error_Transaction_not_equilibrated
894 LCC.transaction
895 { LCC.transaction_dates = date 2000 01 01 0 0 0 Time.utc `NonNull.ncons` []
896 , LCC.transaction_wording = "wording"
897 , LCC.transaction_postings = postings
898 [ (LCC.posting $ account ["A", "B", "C"])
899 { LCC.posting_amounts = amounts [ ("$", 1) ]
900 , LCC.posting_sourcepos = sourcePos "" 2 2 }
901 , (LCC.posting $ account ["D", "E", "F"])
902 { LCC.posting_amounts = amounts [ ("$", -2) ]
903 , LCC.posting_sourcepos = sourcePos "" 3 2 }
904 ]
905 }
906 [( LCC.Unit "$"
907 , H.SumByUnit
908 { H.sumByUnit_quantity = H.Polarized_Both (-2) 1
909 , H.sumByUnit_accounts = Map.fromList []
910 })]
911 }
912 ]
913 ]
914 ,-} testGroup "Term" $
915 let (==>) = test_compile
916 @'[ Proxy LCC.Quantity
917 , Proxy Bool
918 , Proxy LCC.Journal
919 , Proxy LCC.Transaction
920 , Proxy []
921 -- , Proxy LCC.Postings
922 , Proxy LCC.Posting
923 , Proxy (->)
924 , Proxy Alternative
925 , Proxy Bounded
926 , Proxy Either
927 , Proxy H.Addable
928 , Proxy H.Negable
929 , Proxy H.Subable
930 , Proxy LCC.Account
931 , Proxy LCC.Amounts
932 , Proxy LCC.Date
933 , Proxy LCC.PathFile
934 , Proxy LCC.Unit
935 , Proxy Map
936 , Proxy NonNull
937 , Proxy TreeMap.Zipper
938 , Proxy []
939 , Proxy (,)
940 ] (Proxy @[LCC.Transaction]) in
941 [ [ "x = 42" ] ==> ("x", Sym.ty @LCC.Quantity, Right 42.0)
942 , [ "x = 40 + 2" ] ==> ("x", Sym.ty @LCC.Quantity, Right 42.0)
943 , [ "x = $4.2" ] ==> ("x", Sym.ty @LCC.Amounts, Right $ amounts [ ("$", 4.2) ])
944 , [ "x = 4,2€" ] ==> ("x", Sym.ty @LCC.Amounts, Right $ amounts [ ("€", 4.2) ])
945 , [ "x = 4,2€ + $2.4" ] ==> ("x", Sym.ty @LCC.Amounts, Right $ amounts [ ("$", 2.4), ("€", 4.2) ])
946 , [ "x = 4,0€ + 0.2€" ] ==> ("x", Sym.ty @LCC.Amounts, Right $ amounts [ ("€", 4.2) ])
947 , [ "x (q:Quantity) = q" ] ==> ("x", Sym.ty @LCC.Quantity, Right 42.0)
948 , [ "x (b:Bool) = b" ] ==> ("x", Sym.ty @Bool, Right True)
949 , [ "x (b:Bool) = (b,b)" ] ==> ("x", Sym.ty @(,) Sym.:$ Sym.ty @Bool Sym.:$ Sym.ty @Bool, Right (True, True))
950 , [ "x (b:Bool) (q:Quantity) = (b,q)" ] ==> ("x", Sym.ty @(,) Sym.:$ Sym.ty @Bool Sym.:$ Sym.ty @LCC.Quantity, Right (True, 42))
951 -- , [ "x = j" ] ==> ("x", Sym.ty @Bool, Right $ True )
952 -- , [ "x = q" ] ==> ("x", Sym.ty @LCC.Quantity, Right $ 42 )
953 , testGroup "Semantic errors" $
954 let (=!>) i e =
955 let inp = Text.intercalate "\n" i in
956 test inp $
957 read_gram LCC.g_transaction inp @?= Right (S.Left e) in
958 [
959 ]
960 ]
961 {-, testGroup "Chart" $
962 let (==>) i e =
963 let inp = Text.intercalate "\n" i in
964 test inp $
965 read_gram (
966 LCC.g_get $ (\_txn ch -> ch) <$>
967 LCC.g_journal @(Sym.TyConsts_of_Ifaces '[Proxy (->)]) @'[Proxy (->)] (:)
968 ) inp @?= Right e in
969 let acct_path = NonEmpty.fromList . (LCC.Name <$>) in
970 let acct_tags = LCC.Account_Tags . tags in
971 [ [ "/A/B/C"
972 , "/D/E/F"
973 ] ==>
974 LCC.Chart
975 { LCC.chart_accounts = TreeMap.from_List (<>)
976 [ (acct_path ["A", "B", "C"], acct_tags [])
977 , (acct_path ["D", "E", "F"], acct_tags [])
978 ]
979 , LCC.chart_tags = Map.empty
980 }
981 , [ "/A/B/C"
982 , " ~t0:t1"
983 , " ~a0:a1:a2"
984 , "/D/E/F"
985 , " ~t0:t1 = v0"
986 , " ~t0:t1 = v1"
987 ] ==>
988 LCC.Chart
989 { LCC.chart_accounts = TreeMap.from_List (<>)
990 [ (acct_path ["A", "B", "C"], acct_tags
991 [ (["t0", "t1"], "")
992 , (["a0", "a1", "a2"], "")
993 ])
994 , (acct_path ["D", "E", "F"], acct_tags
995 [ (["t0", "t1"], "v0")
996 , (["t0", "t1"], "v1") ])
997 ]
998 , LCC.chart_tags = account_refs
999 [ (,) ["t0", "t1"]
1000 [ ["A", "B", "C"]
1001 , ["D", "E", "F"] ]
1002 , (,) ["a0", "a1", "a2"]
1003 [ ["A", "B", "C"] ]
1004 ]
1005 }
1006 ]
1007 , testGroup "Journal" $
1008 let run fe i e =
1009 let inp = (Text.intercalate "\n" <$>) <$> i in
1010 let jnl = fromMaybe "" $ List.lookup "" inp in
1011 let exp = ((LCC.Journals . Map.fromList . (first LCC.CanonFile <$>)) <$>) <$> fe e in
1012 test jnl $
1013 read @'[Proxy (->)] @[LCC.Transaction] (
1014 LCC.g_get $ (\j (js::LCC.Journals [LCC.Transaction]) -> const js <$> j) <$>
1015 LCC.g_journal
1016 @(Sym.TyConsts_of_Ifaces '[Proxy (->)])
1017 @'[Proxy (->)]
1018 (:)
1019 ) inp "" jnl @?= exp in
1020 let (==>) = run (Right . S.Right) ; infixr 0 ==> in
1021 let jnl :: LCC.Journal [LCC.Transaction] = LCC.journal in
1022 [ [ ("",)
1023 [ "2000-01-01 wording"
1024 , " /A/B/C $1"
1025 , " /D/E/F"
1026 ]
1027 ] ==>
1028 [ ("",) jnl
1029 { LCC.journal_content =
1030 [ LCC.transaction
1031 { LCC.transaction_dates = date 2000 01 01 0 0 0 Time.utc `NonNull.ncons` []
1032 , LCC.transaction_wording = "wording"
1033 , LCC.transaction_sourcepos = sourcePos "" 1 1
1034 , LCC.transaction_postings = postings
1035 [ (LCC.posting $ account ["A", "B", "C"])
1036 { LCC.posting_amounts = amounts [ ("$", 1) ]
1037 , LCC.posting_sourcepos = sourcePos "" 2 2
1038 }
1039 , (LCC.posting $ account ["D", "E", "F"])
1040 { LCC.posting_amounts = amounts [ ("$", -1) ]
1041 , LCC.posting_sourcepos = sourcePos "" 3 2
1042 }
1043 ]
1044 }
1045 ]
1046 {-, LCC.journal_amount_styles = LCC.Amount_Styles $ Map.fromList
1047 [ ( LCC.Unit "$"
1048 , mempty
1049 { LCC.amount_style_unit_side = Just LCC.L
1050 , LCC.amount_style_unit_spaced = Just False }
1051 )
1052 ]
1053 -}
1054 }
1055 ]
1056 , [ ("",)
1057 [ "2000-01-01 1° wording"
1058 , " /A/B/C $1"
1059 , " /D/E/F"
1060 , "2000-01-02 2° wording"
1061 , " /A/B/C $1"
1062 , " /x/y/z"
1063 ]
1064 ] ==>
1065 [ ("",) jnl
1066 { LCC.journal_content =
1067 [ LCC.transaction
1068 { LCC.transaction_dates = date 2000 01 02 0 0 0 Time.utc `NonNull.ncons` []
1069 , LCC.transaction_wording = "2° wording"
1070 , LCC.transaction_sourcepos = sourcePos "" 4 1
1071 , LCC.transaction_postings = postings
1072 [ (LCC.posting $ account ["A", "B", "C"])
1073 { LCC.posting_amounts = amounts [ ("$", 1) ]
1074 , LCC.posting_sourcepos = sourcePos "" 5 2
1075 }
1076 , (LCC.posting $ account ["x", "y", "z"])
1077 { LCC.posting_amounts = amounts [ ("$", -1) ]
1078 , LCC.posting_sourcepos = sourcePos "" 6 2
1079 }
1080 ]
1081 }
1082 , LCC.transaction
1083 { LCC.transaction_dates = date 2000 01 01 0 0 0 Time.utc `NonNull.ncons` []
1084 , LCC.transaction_wording = "1° wording"
1085 , LCC.transaction_sourcepos = sourcePos "" 1 1
1086 , LCC.transaction_postings = postings
1087 [ (LCC.posting $ account ["A", "B", "C"])
1088 { LCC.posting_amounts = amounts [ ("$", 1) ]
1089 , LCC.posting_sourcepos = sourcePos "" 2 2
1090 }
1091 , (LCC.posting $ account ["D", "E", "F"])
1092 { LCC.posting_amounts = amounts [ ("$", -1) ]
1093 , LCC.posting_sourcepos = sourcePos "" 3 2
1094 }
1095 ]
1096 }
1097 ]
1098 }
1099 ]
1100 , [ ("",)
1101 [ "/A/B ~AB"
1102 , ""
1103 , "2000-01-01 wording"
1104 , " ~AB/C $1"
1105 , " /D/E/F"
1106 ]
1107 ] ==>
1108 [ ("",) jnl
1109 { LCC.journal_content =
1110 [ LCC.transaction
1111 { LCC.transaction_dates = date 2000 01 01 0 0 0 Time.utc `NonNull.ncons` []
1112 , LCC.transaction_wording = "wording"
1113 , LCC.transaction_sourcepos = sourcePos "" 3 1
1114 , LCC.transaction_postings = postings
1115 [ (LCC.posting $ account ["A", "B", "C"])
1116 { LCC.posting_amounts = amounts [ ("$", 1) ]
1117 , LCC.posting_account_ref = S.Just $ account_ref ["AB"] S.:!: S.Just (account ["C"])
1118 , LCC.posting_sourcepos = sourcePos "" 4 2
1119 }
1120 , (LCC.posting $ account ["D", "E", "F"])
1121 { LCC.posting_amounts = amounts [ ("$", -1) ]
1122 , LCC.posting_sourcepos = sourcePos "" 5 2
1123 }
1124 ]
1125 }
1126 ]
1127 }
1128 ]
1129 , [ ("",)
1130 [ "./chart"
1131 , ""
1132 , "2000-01-01 wording"
1133 , " ~AB/C $1"
1134 , " ~D/E/F"
1135 ]
1136 , ("chart",)
1137 [ "/A/B ~AB"
1138 , "/D"
1139 , "; comment"
1140 , " ~D"
1141 ]
1142 ] ==>
1143 [ ("",) jnl
1144 { LCC.journal_includes =
1145 [ LCC.CanonFile "chart"
1146 ]
1147 , LCC.journal_content =
1148 [ LCC.transaction
1149 { LCC.transaction_dates = date 2000 01 01 0 0 0 Time.utc `NonNull.ncons` []
1150 , LCC.transaction_wording = "wording"
1151 , LCC.transaction_sourcepos = sourcePos "" 3 1
1152 , LCC.transaction_postings = postings
1153 [ (LCC.posting $ account ["A", "B", "C"])
1154 { LCC.posting_amounts = amounts [ ("$", 1) ]
1155 , LCC.posting_account_ref = S.Just $ account_ref ["AB"] S.:!: S.Just (account ["C"])
1156 , LCC.posting_sourcepos = sourcePos "" 4 2
1157 }
1158 , (LCC.posting $ account ["D", "E", "F"])
1159 { LCC.posting_amounts = amounts [ ("$", -1) ]
1160 , LCC.posting_account_ref = S.Just $ account_ref ["D"] S.:!: S.Just (account ["E", "F"])
1161 , LCC.posting_sourcepos = sourcePos "" 5 2
1162 }
1163 ]
1164 }
1165 ]
1166 }
1167 , ("chart",) jnl
1168 { LCC.journal_file = "chart"
1169 }
1170 ]
1171 , [ ("",)
1172 [ "2000-01-01 w"
1173 , " /A/B/C $1"
1174 , " /D/E/F"
1175 , "./0"
1176 , "./1"
1177 ]
1178 , ("0",)
1179 [ "2000-01-02 w0"
1180 , " /A/B/C $2"
1181 , " /D/E/F"
1182 ]
1183 , ("1",)
1184 [ "2000-01-03 w1"
1185 , " /A/B/C $3"
1186 , " /D/E/F"
1187 ]
1188 ] ==>
1189 [ ("",) jnl
1190 { LCC.journal_includes =
1191 [ LCC.CanonFile "0"
1192 , LCC.CanonFile "1"
1193 ]
1194 , LCC.journal_content =
1195 [ LCC.transaction
1196 { LCC.transaction_dates = date 2000 01 01 0 0 0 Time.utc `NonNull.ncons` []
1197 , LCC.transaction_wording = "w"
1198 , LCC.transaction_sourcepos = sourcePos "" 1 1
1199 , LCC.transaction_postings = postings
1200 [ (LCC.posting $ account ["A", "B", "C"])
1201 { LCC.posting_amounts = amounts [ ("$", 1) ]
1202 , LCC.posting_sourcepos = sourcePos "" 2 2
1203 }
1204 , (LCC.posting $ account ["D", "E", "F"])
1205 { LCC.posting_amounts = amounts [ ("$", -1) ]
1206 , LCC.posting_sourcepos = sourcePos "" 3 2
1207 }
1208 ]
1209 }
1210 ]
1211 }
1212 , ("0",) jnl
1213 { LCC.journal_file = "0"
1214 , LCC.journal_content =
1215 [ LCC.transaction
1216 { LCC.transaction_dates = date 2000 01 02 0 0 0 Time.utc `NonNull.ncons` []
1217 , LCC.transaction_wording = "w0"
1218 , LCC.transaction_sourcepos = sourcePos "0" 1 1
1219 , LCC.transaction_postings = postings
1220 [ (LCC.posting $ account ["A", "B", "C"])
1221 { LCC.posting_amounts = amounts [ ("$", 2) ]
1222 , LCC.posting_sourcepos = sourcePos "0" 2 2
1223 }
1224 , (LCC.posting $ account ["D", "E", "F"])
1225 { LCC.posting_amounts = amounts [ ("$", -2) ]
1226 , LCC.posting_sourcepos = sourcePos "0" 3 2
1227 }
1228 ]
1229 }
1230 ]
1231 }
1232 , ("1",) jnl
1233 { LCC.journal_file = "1"
1234 , LCC.journal_content =
1235 [ LCC.transaction
1236 { LCC.transaction_dates = date 2000 01 03 0 0 0 Time.utc `NonNull.ncons` []
1237 , LCC.transaction_wording = "w1"
1238 , LCC.transaction_sourcepos = sourcePos "1" 1 1
1239 , LCC.transaction_postings = postings
1240 [ (LCC.posting $ account ["A", "B", "C"])
1241 { LCC.posting_amounts = amounts [ ("$", 3) ]
1242 , LCC.posting_sourcepos = sourcePos "1" 2 2
1243 }
1244 , (LCC.posting $ account ["D", "E", "F"])
1245 { LCC.posting_amounts = amounts [ ("$", -3) ]
1246 , LCC.posting_sourcepos = sourcePos "1" 3 2
1247 }
1248 ]
1249 }
1250 ]
1251 }
1252 ]
1253 , testGroup "Parsing errors" $
1254 let (!=>) = run Left ; infixr 0 !=> in
1255 [ [ ("",)
1256 [ "./j"
1257 ]
1258 , ("j",)
1259 [ "2000-01_01 wording"
1260 , " /A/B/C $1"
1261 , " /D/E/F"
1262 ]
1263 ] !=> P.ParseError
1264 { P.errorPos = sourcePos "j" 1 8 :| [sourcePos "" 1 4]
1265 , P.errorUnexpected = Set.fromList [P.Tokens ('_' :| "")]
1266 , P.errorExpected = Set.fromList [P.Tokens ('-' :| "")]
1267 , P.errorCustom = Set.fromList []
1268 }
1269 ]
1270 , testGroup "Semantic errors" $
1271 let (=!>) = run (Right . S.Left) ; infixr 0 =!> in
1272 [ [ ("",)
1273 [ "2000-01-01 wording"
1274 , " /A/B/C $1"
1275 , " /D/E/F"
1276 , ""
1277 , "./chart"
1278 , ""
1279 , "2000-01-01 wording"
1280 , " ~AB/C $1"
1281 , " /D/E/F"
1282 ]
1283 , ("chart",)
1284 [ "/A/B ~AB"
1285 ]
1286 ] =!>
1287 [ LCC.At
1288 { LCC.atBegin = sourcePos "chart" 1 1 :| [sourcePos "" 5 8]
1289 , LCC.atEnd = sourcePos "chart" 1 9
1290 , LCC.atItem =
1291 LCC.Error_Journal_Section
1292 LCC.Section_Transaction
1293 LCC.Section_Chart
1294 }
1295 , LCC.At
1296 { LCC.atBegin = sourcePos "" 8 2 :| []
1297 , LCC.atEnd = sourcePos "" 8 5
1298 , LCC.atItem =
1299 LCC.Error_Journal_Transaction $
1300 LCC.Error_Transaction_Posting $
1301 LCC.Error_Posting_Account_Ref_unknown $
1302 account_ref ["AB"]
1303 }
1304 ]
1305 , [ ("",)
1306 [ "./j"
1307 ]
1308 , ("j",)
1309 [ "2000-01-01 wording"
1310 , " /A/B/C $1"
1311 , " /D/E/F"
1312 , ""
1313 , "./j"
1314 ]
1315 ] =!>
1316 [ LCC.At
1317 { LCC.atBegin = sourcePos "j" 5 1 :| [sourcePos "" 1 4]
1318 , LCC.atEnd = sourcePos "j" 5 4
1319 , LCC.atItem = LCC.Error_Journal_Include_loop $ LCC.CanonFile "j"
1320 }
1321 ]
1322 ]
1323 ]
1324 -}]