]> Git — Sourcephile - comptalang.git/blob - lcc/Hcompta/LCC/Read/Compta.hs
Gather into Writeable instances.
[comptalang.git] / lcc / Hcompta / LCC / Read / Compta.hs
1 {-# LANGUAGE AllowAmbiguousTypes #-}
2 {-# LANGUAGE ExistentialQuantification #-}
3 {-# LANGUAGE RecordWildCards #-}
4 {-# LANGUAGE UndecidableSuperClasses #-}
5 module Hcompta.LCC.Read.Compta where
6
7 import Control.Applicative (Applicative(..), liftA2)
8 import Control.Monad (Monad(..), void)
9 import Data.Bool
10 import Data.Char (Char)
11 import Data.Decimal
12 import Data.Either (Either(..), either)
13 import Data.Eq (Eq(..))
14 import Data.Foldable
15 import Data.Function (($), (.), const, id, flip)
16 import Data.Functor (Functor(..), (<$>), (<$))
17 import Data.Functor.Compose (Compose(..))
18 import Data.List.NonEmpty (NonEmpty(..), (<|))
19 import Data.Map.Strict (Map)
20 import Data.Maybe (Maybe(..), maybe, isJust)
21 import Data.Monoid (Monoid(..))
22 import Data.NonNull (NonNull)
23 import Data.Ord (Ord(..))
24 import Data.Semigroup (Semigroup(..))
25 import Data.String (String)
26 import Data.Text (Text)
27 import Data.Time.LocalTime (TimeZone(..))
28 import Data.Traversable (sequenceA)
29 import Data.Tuple (fst)
30 import Data.Typeable (Typeable)
31 import Prelude (Int, Integer, Enum(..), Num(..), Integral(..), fromIntegral, error)
32 import System.FilePath ((</>))
33 import Text.Show (Show(..))
34 import qualified Control.Exception.Safe as Exn
35 import qualified Control.Monad.Classes as MC
36 import qualified Control.Monad.Trans.State.Strict as SS
37 import qualified Data.Char as Char
38 import qualified Data.List as L
39 import qualified Data.List.NonEmpty as NonEmpty
40 import qualified Data.Map.Strict as Map
41 import qualified Data.NonNull as NonNull
42 import qualified Data.Strict as S
43 import qualified Data.Text as Text
44 import qualified Data.Time.Calendar as Time
45 import qualified Data.Time.LocalTime as Time
46 import qualified Data.TreeMap.Strict as TreeMap
47 import qualified Hcompta as H
48 import qualified System.FilePath as FilePath
49
50 import qualified Language.Symantic.Grammar as G
51 import Language.Symantic.Grammar (CF, At(..), Gram_Rule(..), Gram_Terminal(..), Gram_Alt(..), Gram_AltApp(..), Gram_Try(..), Gram_CF(..))
52 import Language.Symantic.Lib ()
53 import qualified Language.Symantic as Sym
54 import qualified Language.Symantic.Grammar as Sym
55
56 import Hcompta.LCC.Account
57 import Hcompta.LCC.Amount
58 import Hcompta.LCC.Balance ()
59 import Hcompta.LCC.Chart
60 import Hcompta.LCC.Compta
61 import Hcompta.LCC.IO
62 import Hcompta.LCC.Journal
63 import Hcompta.LCC.Name
64 import Hcompta.LCC.Posting
65 import Hcompta.LCC.Tag
66 import Hcompta.LCC.Transaction
67
68 import qualified Hcompta.LCC.Lib.Strict as S
69
70 {-
71 import Debug.Trace (trace)
72 dbg :: Show a => String -> a -> a
73 dbg msg x = trace (msg <> " = " <> show x) x
74 -}
75
76 -- * Type 'Context_Read'
77 data Context_Read src =
78 forall j. (Typeable j, H.Zeroable j) =>
79 Context_Read
80 { context_read_year :: !Year
81 , context_read_unit :: !(S.Maybe Unit)
82 , context_read_canonfiles :: !(NonEmpty CanonFile)
83 , context_read_warnings :: ![At src Warning_Compta]
84 , context_read_section :: !Section
85
86 , context_read_style_amounts :: !Style_Amounts
87 , context_read_chart :: !Chart
88 , context_read_journals :: !(Journals j)
89 , context_read_journal :: !(NonEmpty (Journal j))
90 , context_read_consTxn :: !(Transaction -> j -> j)
91 } -- deriving (Eq, Show)
92
93 -- deriving instance Show src => Show (Context_Read src)
94
95 --
96 -- Readers
97 --
98
99 -- NonEmpty CanonFile
100 type instance MC.CanDo (S.StateT (Context_Read src) m) (MC.EffReader (NonEmpty CanonFile)) = 'True
101 instance Monad m => MC.MonadReaderN 'MC.Zero (NonEmpty CanonFile) (S.StateT (Context_Read src) m) where
102 askN _n = MC.gets $ \(x::Context_Read src) -> context_read_canonfiles x
103
104 --
105 -- States handled by a nested Monad
106 --
107 type instance MC.CanDo (S.StateT (Context_Read src) m) (MC.EffState (Sym.Imports ns, Sym.Modules src ss)) = 'False
108 type instance MC.CanDo (S.StateT (Context_Read src) m) (MC.EffState (Sym.Imports ns, Sym.ModulesTy src)) = 'False
109 type instance MC.CanDo (S.StateT (Context_Read src) m) (MC.EffState (Env src ss)) = 'False
110 type instance MC.CanDo (S.StateT (Context_Read src) m) (MC.EffState Terms) = 'False
111
112 context_read ::
113 Typeable j =>
114 H.Zeroable j =>
115 (Transaction -> j -> j) ->
116 Context_Read src
117 context_read consTxn =
118 Context_Read
119 { context_read_year = Year $ H.yearOf (H.epoch::Date)
120 , context_read_style_amounts = mempty
121 , context_read_chart = mempty
122 , context_read_unit = S.Nothing
123 , context_read_journals = Journals Map.empty
124 , context_read_journal = journal H.zero :| []
125 , context_read_canonfiles = CanonFile "" :| []
126 , context_read_warnings = []
127 , context_read_section = Section_Terms
128 , context_read_consTxn = consTxn
129 }
130
131 -- * Type 'Context_Sym'
132 data Context_Sym src ss
133 = Context_Sym
134 { context_sym_imports :: !(Sym.Imports Sym.NameTe)
135 , context_sym_importsTy :: !(Sym.Imports Sym.NameTy)
136 , context_sym_modules :: !(Sym.Modules src ss)
137 , context_sym_modulesTy :: !(Sym.ModulesTy src)
138 , context_sym_env :: !(Env src ss)
139 , context_sym_terms :: !Terms
140 } deriving (Eq, Show)
141
142 context_sym ::
143 forall src ss.
144 Sym.Source src =>
145 Sym.ImportTypes ss =>
146 Sym.ModulesInj src ss =>
147 Sym.ModulesTyInj ss =>
148 Context_Sym src ss
149 context_sym =
150 let mods = either (error . show) id Sym.modulesInj in
151 Context_Sym
152 { context_sym_imports = Sym.importModules [] mods
153 , context_sym_importsTy = Sym.importTypes @ss []
154 , context_sym_modules = mods
155 , context_sym_modulesTy = Sym.modulesTyInj @ss
156 , context_sym_env = Map.empty
157 , context_sym_terms = Map.empty
158 }
159
160 --
161 -- States
162 --
163
164 -- (Sym.Imports Sym.NameTe, Sym.Modules src ss)
165 type instance MC.CanDo (S.StateT (Context_Sym src ss) m) (MC.EffState (Sym.Imports Sym.NameTe, Sym.Modules src ss)) = 'True
166 instance Monad m => MC.MonadStateN 'MC.Zero (Sym.Imports Sym.NameTe, Sym.Modules src ss) (S.StateT (Context_Sym src ss) m) where
167 stateN _px f = S.StateT $ SS.state $ \ctx ->
168 (\(imps, mods) -> ctx{context_sym_imports=imps, context_sym_modules=mods})
169 <$> f (context_sym_imports ctx, context_sym_modules ctx)
170
171 -- (Sym.Imports Sym.NameTy, Sym.ModulesTy src)
172 type instance MC.CanDo (S.StateT (Context_Sym src ss) m) (MC.EffState (Sym.Imports Sym.NameTy, Sym.ModulesTy src)) = 'True
173 instance Monad m => MC.MonadStateN 'MC.Zero (Sym.Imports Sym.NameTy, Sym.ModulesTy src) (S.StateT (Context_Sym src ss) m) where
174 stateN _px f = S.StateT $ SS.state $ \ctx ->
175 (\(imps, mods) -> ctx{context_sym_importsTy=imps, context_sym_modulesTy=mods})
176 <$> f (context_sym_importsTy ctx, context_sym_modulesTy ctx)
177
178 -- Terms
179 type instance MC.CanDo (S.StateT (Context_Sym src ss) m) (MC.EffState Terms) = 'True
180 instance Monad m => MC.MonadStateN 'MC.Zero Terms (S.StateT (Context_Sym src ss) m) where
181 stateN _px f = S.StateT $ SS.state $ \ctx ->
182 (\a -> ctx{context_sym_terms = a})
183 <$> f (context_sym_terms ctx)
184
185 -- Env src ss
186 type instance MC.CanDo (S.StateT (Context_Sym src ss) m) (MC.EffState (Env src ss)) = 'True
187 instance Monad m => MC.MonadStateN 'MC.Zero (Env src ss) (S.StateT (Context_Sym src ss) m) where
188 stateN _px f = S.StateT $ SS.state $ \ctx ->
189 (\a -> ctx{context_sym_env = a})
190 <$> f (context_sym_env ctx)
191
192 -- Context_Read src
193 type instance MC.CanDo (S.StateT (Context_Read src) m) (MC.EffState (Context_Read src)) = 'True
194 instance Monad m => MC.MonadStateN 'MC.Zero (Context_Read src) (S.StateT (Context_Read src) m) where
195 stateN _px = S.StateT . SS.state
196
197 -- S.Maybe Unit
198 type instance MC.CanDo (S.StateT (Context_Read src) m) (MC.EffState (S.Maybe Unit)) = 'True
199 instance Monad m => MC.MonadStateN 'MC.Zero (S.Maybe Unit) (S.StateT (Context_Read src) m) where
200 stateN _px f = S.StateT $ SS.state $ \ctx ->
201 (\a -> ctx{context_read_unit = a})
202 <$> f (context_read_unit ctx)
203
204 -- Chart
205 type instance MC.CanDo (S.StateT (Context_Read src) m) (MC.EffState Chart) = 'True
206 instance Monad m => MC.MonadStateN 'MC.Zero Chart (S.StateT (Context_Read src) m) where
207 stateN _px f = S.StateT $ SS.state $ \ctx ->
208 (\a -> ctx{context_read_chart = a})
209 <$> f (context_read_chart ctx)
210
211 -- Year
212 type instance MC.CanDo (S.StateT (Context_Read src) m) (MC.EffState Year) = 'True
213 instance Monad m => MC.MonadStateN 'MC.Zero Year (S.StateT (Context_Read src) m) where
214 stateN _px f = S.StateT $ SS.state $ \ctx ->
215 (\a -> ctx{context_read_year = a})
216 <$> f (context_read_year ctx)
217
218 -- Section
219 type instance MC.CanDo (S.StateT (Context_Read src) m) (MC.EffState Section) = 'True
220 instance Monad m => MC.MonadStateN 'MC.Zero Section (S.StateT (Context_Read src) m) where
221 stateN _px f = S.StateT $ SS.state $ \ctx ->
222 (\a -> ctx{context_read_section = a})
223 <$> f (context_read_section ctx)
224
225 -- * Style_Amounts
226 type instance MC.CanDo (S.StateT (Context_Read src) m) (MC.EffState Style_Amounts) = 'True
227 instance Monad m => MC.MonadStateN 'MC.Zero Style_Amounts (S.StateT (Context_Read src) m) where
228 stateN _px f = S.StateT $ SS.state $ \ctx ->
229 (\s -> ctx{context_read_style_amounts = s})
230 <$> f (context_read_style_amounts ctx)
231
232 -- * Class 'Gram_Path'
233 class Gram_Path g where
234 g_canonfile
235 :: g PathFile
236 -> g (PathFile, Either Exn.IOException CanonFile)
237 deriving instance Gram_Path g => Gram_Path (CF g)
238
239 -- * Class 'Gram_IO'
240 class G.Gram_Source src g => Gram_IO src g where
241 g_read
242 :: g (S.Either (Error_Compta src) PathFile)
243 -> g (S.Either [At src (Error_Compta src)] a)
244 -> g (S.Either [At src (Error_Compta src)] a)
245 deriving instance Gram_IO src g => Gram_IO src (CF g)
246
247 -- * Class 'Gram_Count'
248 class
249 ( G.Gram_App g
250 , G.Gram_Alt g
251 , G.Gram_AltApp g
252 ) => Gram_Count g where
253 count :: Int -> CF g a -> CF g [a]
254 count n p
255 | n <= 0 = pure []
256 | otherwise = sequenceA $ L.replicate n p
257 count' :: Int -> Int -> CF g a -> CF g [a]
258 count' m n p
259 | n <= 0 || m > n = pure []
260 | m > 0 = (:) <$> p <*> count' (pred m) (pred n) p
261 | otherwise =
262 let f t ts = maybe [] (:ts) t
263 in f <$> G.optional p <*> count' 0 (pred n) p
264
265 -- * Class 'Gram_Char'
266 class
267 ( G.Gram_Terminal g
268 , G.Gram_Rule g
269 , G.Gram_Alt g
270 , G.Gram_AltApp g
271 , G.Gram_Try g
272 , G.Gram_App g
273 , G.Gram_AltApp g
274 , G.Gram_Comment g
275 ) => Gram_Char g where
276 g_eol :: CF g ()
277 g_eol = rule "EOL" $ void (char '\n') <+> void (G.string "\r\n")
278 g_tab :: CF g ()
279 g_tab = rule "Tab" $ void $ char '\t'
280 g_space :: CF g Char
281 g_space = rule "Space" $ char ' '
282 g_spaces :: CF g Text
283 g_spaces = Text.pack <$> many g_space
284 g_spaces1 :: CF g ()
285 g_spaces1 = void $ some g_space
286 g_char :: CF g Char
287 g_char = g_char_passive <+> g_char_active
288 g_char_passive :: CF g Char
289 g_char_passive = choice $ G.unicat <$> [G.Unicat_Letter, G.Unicat_Number, G.Unicat_Mark]
290 g_char_active :: CF g Char
291 g_char_active = choice $ G.unicat <$> [G.Unicat_Punctuation, G.Unicat_Symbol]
292 g_char_attribute :: G.Reg lr g Char
293 g_char_attribute = choice $ char <$> "#/:;@~="
294 g_word :: CF g Text
295 g_word = rule "Word" $ Text.pack <$> some g_char
296 g_words :: CF g Text
297 g_words = Text.concat <$> many (try $ (<>) <$> g_spaces <*> g_word)
298 g_09 :: CF g Char
299 g_09 = range ('0', '9')
300 g_19 :: CF g Char
301 g_19 = range ('1', '9')
302 g_sign :: Num int => CF g (int -> int)
303 g_sign =
304 (negate <$ char '-') <+>
305 (id <$ char '+')
306
307 -- * Class 'Gram_Date'
308 class
309 ( G.Gram_State Year g
310 , G.Gram_Terminal g
311 , G.Gram_Rule g
312 , G.Gram_Alt g
313 , G.Gram_Try g
314 , G.Gram_App g
315 , G.Gram_AltApp g
316 , Gram_Char g
317 , Gram_Count g
318 ) => Gram_Date g where
319 g_date ::
320 G.Gram_Source src g =>
321 CF g (S.Either (At src Error_Date) Date)
322 g_date = rule "Date" $
323 liftA2 (\day (tod, tz) ->
324 Time.localTimeToUTC tz $
325 Time.LocalTime day tod)
326 <$> g_ymd
327 <*> option
328 (S.Right (Time.midnight, Time.utc))
329 (liftA2 (,)
330 <$ char '_'
331 <*> g_tod
332 <*> option (S.Right Time.utc) g_timezone)
333 g_ymd ::
334 G.Gram_Source src g =>
335 CF g (S.Either (At src Error_Date) Time.Day)
336 g_ymd = rule "YMD" $
337 G.source $
338 try (mk_ymd
339 <$> g_year
340 <* char char_ymd_sep
341 <*> g_month
342 <* char char_ymd_sep
343 <*> g_dom)
344 <+>
345 mk_ymd
346 <$> G.getAfter (pure $ \(Year y) -> y)
347 <*> g_month
348 <* char char_ymd_sep
349 <*> g_dom
350 where
351 mk_ymd y m d src =
352 case Time.fromGregorianValid y m d of
353 Nothing -> S.Left $ At src $ Error_Date_Day_invalid (y, m, d)
354 Just day -> S.Right day
355 g_tod ::
356 G.Gram_Source src g =>
357 CF g (S.Either (At src Error_Date) Time.TimeOfDay)
358 g_tod = rule "TimeOfDay" $
359 G.source $
360 (\hr (mn, sc) src ->
361 case Time.makeTimeOfDayValid hr mn (fromInteger $ toInteger sc) of
362 Nothing -> S.Left $ At src $ Error_Date_TimeOfDay_invalid (hr, mn, sc)
363 Just tod -> S.Right $ tod)
364 <$> g_hour
365 <*> option (0, 0)
366 ((,)
367 <$> (char char_tod_sep *> g_minute)
368 <*> option 0 (char char_tod_sep *> g_second))
369 g_year :: CF g Integer
370 g_year = rule "Year" $
371 (\sg y -> sg $ integer_of_digits 10 y)
372 <$> option id (negate <$ char '-')
373 <*> some g_09
374 g_month :: CF g Int
375 g_month = rule "Month" $ int_of_digits 10 <$> count' 1 2 g_09
376 g_dom :: CF g Int
377 g_dom = rule "DayOfMonth" $ int_of_digits 10 <$> count' 1 2 g_09
378 g_hour :: CF g Int
379 g_hour = rule "Hour" $ int_of_digits 10 <$> count' 1 2 g_09
380 g_minute :: CF g Int
381 g_minute = rule "Minute" $ int_of_digits 10 <$> count' 1 2 g_09
382 g_second :: CF g Int
383 g_second = rule "Second" $ int_of_digits 10 <$> count' 1 2 g_09
384
385 g_timezone ::
386 G.Gram_Source src g =>
387 CF g (S.Either (At src Error_Date) TimeZone)
388 g_timezone = rule "TimeZone" $
389 -- DOC: http://www.timeanddate.com/time/zones/
390 -- TODO: only a few time zones are suported below.
391 -- TODO: check the timeZoneSummerOnly values
392 (S.Right <$> g_timezone_digits) <+>
393 (G.source $ read_tz <$ char '_' <*> some (range ('A', 'Z')))
394 where
395 read_tz n src = case n of
396 "AST" -> S.Right $ TimeZone (- 4 * 60) False n
397 "ADT" -> S.Right $ TimeZone (- 3 * 60) True n
398 "A" -> S.Right $ TimeZone (- 1 * 60) False n
399 "BST" -> S.Right $ TimeZone (-11 * 60) False n
400 "BDT" -> S.Right $ TimeZone (-10 * 60) True n
401 "CET" -> S.Right $ TimeZone ( 1 * 60) True n
402 "CEST" -> S.Right $ TimeZone ( 2 * 60) False n
403 "CST" -> S.Right $ TimeZone (- 6 * 60) False n
404 "CDT" -> S.Right $ TimeZone (- 5 * 60) True n
405 "EST" -> S.Right $ TimeZone (- 5 * 60) False n
406 "EDT" -> S.Right $ TimeZone (- 4 * 60) True n
407 "GMT" -> S.Right $ TimeZone 0 False n
408 "HST" -> S.Right $ TimeZone (-10 * 60) False n
409 "HDT" -> S.Right $ TimeZone (- 9 * 60) True n
410 "MST" -> S.Right $ TimeZone (- 7 * 60) False n
411 "MDT" -> S.Right $ TimeZone (- 6 * 60) True n
412 "M" -> S.Right $ TimeZone (-12 * 60) False n
413 "NST" -> S.Right $ TimeZone (- 3 * 60 - 30) False n
414 "N" -> S.Right $ TimeZone ( 1 * 60) False n
415 "PST" -> S.Right $ TimeZone (- 8 * 60) False n
416 "PDT" -> S.Right $ TimeZone (- 7 * 60) True n
417 "YST" -> S.Right $ TimeZone (- 9 * 60) False n
418 "YDT" -> S.Right $ TimeZone (- 8 * 60) True n
419 "Y" -> S.Right $ TimeZone ( 12 * 60) False n
420 "Z" -> S.Right $ TimeZone 0 False n
421 _ -> S.Left $ At src $ Error_Date_TimeZone_unknown (Text.pack n)
422 g_timezone_digits :: CF g TimeZone
423 g_timezone_digits =
424 (\sg hr mn ->
425 let tz =
426 TimeZone
427 { timeZoneMinutes = sg $ hr * 60 + mn
428 , timeZoneSummerOnly = False
429 , timeZoneName = Time.timeZoneOffsetString tz
430 }
431 in tz)
432 <$> g_sign
433 <*> g_hour
434 <*> option 0 (optional (char char_tod_sep) *> g_minute)
435
436 -- * Class 'Gram_Tag'
437 class
438 ( Gram_Char g
439 , G.Gram_Terminal g
440 , G.Gram_Try g
441 , G.Gram_CF g
442 ) => Gram_Tag g where
443 g_tag :: CF g Tag
444 g_tag = Tag
445 <$ char char_tag_prefix
446 <*> g_tag_path
447 <*> option (Tag_Data "")
448 ( try $ g_spaces
449 *> char char_tag_data_prefix
450 *> g_spaces
451 *> g_tag_value )
452 g_tag_path :: CF g Tag_Path
453 g_tag_path =
454 (\x xs -> Tag_Path $ NonNull.ncons x xs)
455 <$> g_tag_section
456 <*> many (try $ char char_tag_sep *> g_tag_section)
457 g_tag_section :: CF g Tag_Path_Section
458 g_tag_section =
459 Name . Text.pack
460 <$> some (g_char `minus` g_char_attribute)
461 g_tag_value :: CF g Tag_Data
462 g_tag_value = Tag_Data <$> g_words
463
464 -- * Class 'Gram_Comment'
465 class
466 ( G.Gram_Terminal g
467 , Gram_Char g
468 ) => Gram_Comment g where
469 g_comment :: CF g Comment
470 g_comment = rule "Comment" $
471 Comment <$ char ';' <* g_spaces <*> g_words
472
473 -- * Class 'Gram_Account'
474 class
475 ( G.Gram_Try g
476 , Gram_Char g
477 , Gram_Comment g
478 , Gram_Tag g
479 ) => Gram_Account g where
480 g_account_section :: CF g NameAccount
481 g_account_section =
482 Name . Text.pack
483 <$> some (g_char `minus` g_char_attribute)
484 g_account :: CF g Account
485 g_account = rule "Account" $
486 Account . NonNull.impureNonNull
487 <$> some (try $ char '/' *> g_account_section)
488 g_account_tag :: CF g Account_Tag
489 g_account_tag =
490 (Account_Tag <$>) $
491 Tag
492 <$ char char_account_tag_prefix
493 <*> g_tag_path
494 <*> option (Tag_Data "")
495 (try $ g_spaces
496 *> char char_tag_data_prefix
497 *> g_spaces
498 *> g_tag_value )
499 g_account_tag_path :: CF g Tag_Path
500 g_account_tag_path = rule "Tag_Path" $
501 char char_account_tag_prefix
502 *> g_tag_path
503 {-
504 g_anchor_section :: CF g Anchor_Section
505 g_anchor_section = rule "Anchor_Section" $
506 Name . Text.pack
507 <$> some (g_char `minus` g_char_attribute)
508 -}
509
510 -- * Class 'Gram_Amount'
511 class
512 ( Gram_Char g
513 , G.Gram_Terminal g
514 , G.Gram_CF g
515 ) => Gram_Amount g where
516 g_unit :: CF g Unit
517 g_unit = rule "Unit" $
518 Unit . Text.singleton
519 <$> G.unicat (G.Unicat Char.CurrencySymbol)
520 g_quantity :: CF g (Quantity, Style_Amount)
521 g_quantity = rule "Quantity" $
522 (\(i, f, fr, gi, gf) ->
523 let int = concat i in
524 let frac = concat f in
525 let precision = length frac in
526 -- guard (precision <= 255)
527 let mantissa = integer_of_digits 10 $ int <> frac in
528 ( Decimal
529 (fromIntegral precision)
530 mantissa
531 , mempty
532 { style_amount_fractioning=fr
533 , style_amount_grouping_integral=gi
534 , style_amount_grouping_fractional=gf
535 }
536 ))
537 <$> choice (try <$>
538 [ g_qty '_' ',' '_' <* (pure () `minus` choice (char <$> ",._"))
539 , g_qty '_' '.' '_' <* (pure () `minus` choice (char <$> ",._"))
540 , g_qty ',' '.' '_' <* (pure () `minus` choice (char <$> ",._"))
541 , g_qty '.' ',' '_' <* (pure () `minus` choice (char <$> ",._"))
542 ])
543 g_qty
544 :: Char -- ^ Integral grouping separator.
545 -> Char -- ^ Fractioning separator.
546 -> Char -- ^ Fractional grouping separator.
547 -> CF g
548 ( [String] -- integral
549 , [String] -- fractional
550 , S.Maybe Style_Amount_Fractioning -- fractioning
551 , S.Maybe Style_Amount_Grouping -- grouping_integral
552 , S.Maybe Style_Amount_Grouping -- grouping_fractional
553 )
554 g_qty int_group_sep frac_sep frac_group_sep =
555 (\int mf ->
556 case mf of
557 Nothing ->
558 ( int
559 , []
560 , S.Nothing
561 , grouping_of_digits int_group_sep int
562 , S.Nothing
563 )
564 Just (fractioning, frac) ->
565 ( int
566 , frac
567 , S.Just fractioning
568 , grouping_of_digits int_group_sep int
569 , grouping_of_digits frac_group_sep $ L.reverse frac
570 ))
571 <$> ((:)
572 <$> some g_09
573 <*> option [] (many $ try $ char int_group_sep *> some g_09))
574 <*> option Nothing (Just <$> ((,)
575 <$> char frac_sep
576 <*> ((:)
577 <$> many g_09
578 <*> option [] (many $ try $ char frac_group_sep *> some g_09))))
579 where
580 grouping_of_digits :: Char -> [String] -> S.Maybe Style_Amount_Grouping
581 grouping_of_digits group_sep digits =
582 case digits of
583 [] -> S.Nothing
584 [_] -> S.Nothing
585 _ -> S.Just $
586 Style_Amount_Grouping group_sep $
587 canonicalize_grouping $
588 length <$> digits
589 canonicalize_grouping :: [Int] -> [Int]
590 canonicalize_grouping groups =
591 foldl' -- NOTE: remove duplicates at beginning and reverse.
592 (\acc l0 -> case acc of
593 l1:_ -> if l0 == l1 then acc else l0:acc
594 _ -> l0:acc) [] $
595 case groups of -- NOTE: keep only longer at beginning.
596 l0:l1:t -> if l0 > l1 then groups else l1:t
597 _ -> groups
598
599 g_amount :: CF g (Styled_Amount Amount)
600 g_amount = rule "Amount" $ g_amount_minus <+> g_amount_plus
601 g_amount_minus :: CF g (Styled_Amount Amount)
602 g_amount_minus =
603 char '-' *> (
604 mk_amount L
605 <$> ((,) <$> g_unit <*> g_spaces)
606 <*> g_quantity
607 <+>
608 flip (mk_amount R)
609 <$> g_quantity
610 <*> option ("", "")
611 (try $ flip (,) <$> g_spaces <*> g_unit) )
612 <+>
613 try (mk_amount L
614 <$> ((,) <$> g_unit <*> g_spaces)
615 <* char '-'
616 <*> g_quantity)
617 where
618 mk_amount :: LR -> (Unit, Text) -> (Quantity, Style_Amount) -> (Style_Amount, Amount)
619 mk_amount side (unit, sp) (qty, sty) =
620 ( case unit of
621 Unit "" -> sty
622 _ -> sty
623 { style_amount_unit_side = S.Just side
624 , style_amount_unit_spaced = S.Just $ not $ Text.null sp
625 }
626 , Amount
627 { amount_quantity = negate qty
628 , amount_unit = unit
629 }
630 )
631 g_amount_plus :: CF g (Styled_Amount Amount)
632 g_amount_plus =
633 char '+' *> (
634 mk_amount L
635 <$> ((,) <$> g_unit <*> g_spaces)
636 <*> g_quantity
637 <+>
638 flip (mk_amount R)
639 <$> g_quantity
640 <*> option ("", "")
641 (try $ flip (,) <$> g_spaces <*> g_unit) )
642 <+>
643 mk_amount L
644 <$> ((,) <$> g_unit <*> g_spaces)
645 <* optional (char '+')
646 <*> g_quantity
647 <+>
648 flip (mk_amount R)
649 <$> g_quantity
650 <*> option ("", "")
651 (try $ flip (,) <$> g_spaces <*> g_unit)
652 where
653 mk_amount :: LR -> (Unit, Text) -> (Quantity, Style_Amount) -> (Style_Amount, Amount)
654 mk_amount side (unit, sp) (qty, sty) =
655 ( case unit of
656 Unit "" -> sty
657 _ -> sty
658 { style_amount_unit_side = S.Just side
659 , style_amount_unit_spaced = S.Just $ not $ Text.null sp
660 }
661 , Amount
662 { amount_quantity = qty
663 , amount_unit = unit
664 }
665 )
666
667 -- * Class 'Gram_Posting'
668 class
669 ( Gram_Account g
670 , Gram_Amount g
671 , Gram_Char g
672 , Gram_Comment g
673 , G.Gram_Reader SourcePos g
674 , G.Gram_State (S.Maybe Unit) g
675 , G.Gram_State Chart g
676 , G.Gram_State Style_Amounts g
677 , G.Gram_Terminal g
678 ) => Gram_Posting g where
679 g_postings ::
680 G.Gram_Source src g =>
681 CF g (S.Either (At src Error_Posting) [Posting])
682 g_postings =
683 fmap sequenceA $
684 many $ try $
685 many (try $ g_spaces *> g_eol) *>
686 g_spaces1 *> g_posting
687 g_posting ::
688 G.Gram_Source src g =>
689 CF g (S.Either (At src Error_Posting) Posting)
690 g_posting = rule "Posting" $
691 G.stateAfter $ G.getAfter $ G.askBefore $
692 (\lr_acct
693 may_amt attrs
694 posting_sourcepos ctx_unit
695 (Style_Amounts ctx_stys) -> do
696 let (posting_tags, posting_comments) = attrs
697 let (stys, posting_amounts) =
698 case may_amt of
699 Nothing -> (Style_Amounts ctx_stys, mempty)
700 Just (sty, amt) ->
701 let ctx =
702 Style_Amounts $
703 Map.insertWith (flip (<>))
704 (amount_unit amt)
705 sty ctx_stys in
706 let unit =
707 case amount_unit amt of
708 u | u == "" -> S.fromMaybe u ctx_unit
709 u -> u in
710 (ctx,) $
711 Amounts $
712 Map.singleton unit $
713 amount_quantity amt
714 (stys,) $ do
715 (posting_account, posting_account_ref) <- lr_acct
716 S.Right $
717 Posting
718 { posting_account
719 , posting_account_ref
720 , posting_amounts
721 , posting_tags
722 , posting_comments
723 , posting_dates = []
724 , posting_sourcepos
725 })
726 <$> g_posting_account
727 <*> optional (try $ g_spaces1 *> g_amount)
728 <*> g_posting_attrs
729 g_posting_account ::
730 G.Gram_Source src g =>
731 CF g (S.Either (At src Error_Posting)
732 (Account, S.Maybe (S.Pair Tag_Path (S.Maybe Account))))
733 g_posting_account = rule "Posting_Account" $
734 (S.Right . (, S.Nothing) <$> g_account) <+>
735 (mk_posting_account
736 <$> (G.source $ G.getAfter $ expand_tag_path <$> g_account_tag_path)
737 <*> option S.Nothing (S.Just <$> g_account))
738 where
739 mk_posting_account path acct =
740 (\(p, a) ->
741 (,)
742 (S.maybe a (a <>) acct)
743 (S.Just (p S.:!: acct)) )
744 <$> path
745 expand_tag_path tag chart src =
746 case Map.lookup tag $ chart_tags chart of
747 Just accts | Map.size accts > 0 ->
748 if Map.size accts == 1
749 then
750 let acct = fst $ Map.elemAt 0 accts in
751 S.Right (tag, acct)
752 else S.Left $ At src $ Error_Posting_Account_Ref_multiple tag accts
753 _ -> S.Left $ At src $ Error_Posting_Account_Ref_unknown tag
754 g_posting_tag :: CF g Posting_Tag
755 g_posting_tag = rule "Posting_Tag" $ Posting_Tag <$> g_tag
756 g_posting_attrs :: CF g (Posting_Tags, [Comment])
757 g_posting_attrs =
758 foldr ($) mempty . Compose
759 <$> (many $ try $
760 many (try $ g_spaces *> g_eol *> g_spaces1) *>
761 some (try $
762 g_spaces *>
763 choice
764 [ add_tag <$> g_posting_tag
765 , add_comment <$> g_comment
766 ]))
767 where
768 add_tag (Posting_Tag (Tag (Tag_Path p) v)) =
769 \(Posting_Tags (Tags tags), cmts) ->
770 ( Posting_Tags (Tags (TreeMap.insert (<>) p [v] tags))
771 , cmts )
772 add_comment c =
773 \(tags, cmts) ->
774 (tags, c:cmts)
775
776 -- * Class 'Gram_Transaction'
777 class
778 ( Gram_Account g
779 , Gram_Amount g
780 , Gram_Char g
781 , Gram_Comment g
782 , Gram_Date g
783 , Gram_Posting g
784 , G.Gram_Terminal g
785 , G.Gram_State Section g
786 ) => Gram_Transaction g where
787 g_transaction ::
788 G.Gram_Source src g =>
789 CF g (S.Either (At src Error_Transaction) Transaction)
790 g_transaction = rule "Transaction" $
791 G.stateAfter $ (update_year <$>) $
792 G.source $ G.askBefore $
793 (\lr_date
794 transaction_wording
795 ( transaction_tags
796 , transaction_comments )
797 lr_posts
798 transaction_sourcepos src -> do
799 date <- fmap Error_Transaction_Date `S.left` lr_date
800 posts <- fmap Error_Transaction_Posting `S.left` lr_posts
801 let postsByAcct = postings_by_account posts
802 let txn =
803 Transaction
804 { transaction_tags
805 , transaction_comments
806 , transaction_dates = NonNull.ncons date []
807 , transaction_wording
808 , transaction_postings = Postings postsByAcct
809 , transaction_sourcepos
810 }
811 case H.equilibrium postsByAcct of
812 (_, Left ko) -> S.Left $ At src $ Error_Transaction_not_equilibrated txn ko
813 (_bal, Right ok) -> S.Right txn{transaction_postings = Postings ok}
814 )
815 <$> g_date
816 <* g_spaces1
817 <*> g_wording
818 <*> g_transaction_attrs
819 <*> g_postings
820 where
821 update_year lr_txn y =
822 (,lr_txn) $
823 case lr_txn of
824 S.Right txn -> Year $ H.yearOf $ NonNull.head $ transaction_dates txn
825 _ -> y
826 g_wording :: CF g Wording
827 g_wording = rule "Wording" $
828 Wording . Text.concat
829 <$> many (try $
830 (<>)
831 <$> g_spaces
832 <*> (Text.pack
833 <$> some (g_char `minus` char char_tag_prefix)))
834 g_transaction_tag :: CF g Transaction_Tag
835 g_transaction_tag = rule "Transaction_Tag" $ Transaction_Tag <$> g_tag
836 g_transaction_attrs :: CF g (Transaction_Tags, [Comment])
837 g_transaction_attrs =
838 foldr ($) mempty
839 <$> many (
840 choice (try <$>
841 [ add_tag <$ many (try $ g_spaces *> g_eol *> g_spaces1) <*> g_transaction_tag
842 , add_comment <$ many (try $ g_spaces *> g_eol *> g_spaces) <*> g_comment
843 ]))
844 where
845 add_tag (Transaction_Tag (Tag (Tag_Path p) v)) =
846 \(Transaction_Tags (Tags tags), cmts) ->
847 ( Transaction_Tags (Tags (TreeMap.insert (<>) p [v] tags))
848 , cmts )
849 add_comment c =
850 \(tags, cmts) ->
851 (tags, c:cmts)
852
853 -- * Class 'Gram_File'
854 class
855 ( Gram_Char g
856 , G.Gram_Rule g
857 , G.Gram_Terminal g
858 , G.Gram_Try g
859 , G.Gram_CF g
860 ) => Gram_File g where
861 g_pathfile :: CF g PathFile
862 g_pathfile = rule "PathFile" $
863 PathFile . concat
864 <$> some (try $ (:) <$> char '/' <*> some (g_char `minus` char '/'))
865
866 -- * Class 'Gram_Chart'
867 class
868 ( Gram_Account g
869 , Gram_Comment g
870 , G.Gram_Try g
871 ) => Gram_Chart g where
872 g_chart_entry ::
873 G.Gram_Source src g =>
874 CF g (S.Either (At src (Error_Compta src)) Chart)
875 g_chart_entry = rule "Chart" $
876 (\acct attrs ->
877 let (tags, tags2, _comments) = attrs in
878 S.Right $
879 Chart
880 { chart_accounts = TreeMap.singleton (H.to acct) tags
881 , chart_tags = Map.singleton acct () <$ tags2
882 }
883 )
884 <$> g_account
885 <*> g_chart_attrs
886 g_chart_attrs :: CF g (Account_Tags, Map Tag_Path (), [Comment])
887 g_chart_attrs =
888 foldr ($) mempty
889 <$> (many $ try $
890 many (try $ g_spaces *> g_eol) *>
891 choice
892 [ add_tag <$ g_spaces1 <*> g_account_tag
893 , add_comment <$ g_spaces <*> g_comment
894 ])
895 where
896 add_tag (Account_Tag (Tag (Tag_Path p) v)) =
897 \(Account_Tags (Tags tags), tags2, cmts) ->
898 ( Account_Tags (Tags (TreeMap.insert (<>) p [v] tags))
899 , Map.insert (Tag_Path p) () tags2
900 , cmts )
901 add_comment c =
902 \(tags, tags2, cmts) ->
903 (tags, tags2, c:cmts)
904
905 -- * Class 'Gram_Input'
906 class Gram_Input g where
907 g_input :: g (Text -> a) -> g a
908 deriving instance Gram_Input g => Gram_Input (CF g)
909
910 -- * Class 'Gram_Term_Def'
911 class
912 ( G.Gram_Source src g
913 , Sym.Gram_Term src ss g
914 , G.SourceInj (Sym.TypeVT src) src
915 , G.SourceInj (Sym.KindK src) src
916 , G.SourceInj (Sym.AST_Type src) src
917 ) => Gram_Term_Def src ss g where
918 g_term_def :: CF g (S.Either (At src (Sym.NameTe, Sym.Error_Term src)) (Sym.NameTe, Sym.TermVT src ss '[]))
919 g_term_def = rule "TermDef" $
920 G.source $
921 (\n args v src ->
922 let lr_t =
923 Sym.readTerm Sym.CtxTyZ $
924 foldr (\(x, ty_x) -> G.BinTree0 . Sym.Token_Term_Abst src x ty_x) v args in
925 case lr_t of
926 Right t -> S.Right (n, t)
927 Left err -> S.Left $ At src (n, err)
928 )
929 <$> Sym.g_NameTe
930 <*> many Sym.g_term_abst_decl
931 <* Sym.symbol "="
932 <*> Sym.g_term
933
934 -- * Class 'Gram_Compta'
935 class
936 ( G.Gram_Source src g
937 , G.Gram_Try g
938 , Gram_Account g
939 , Gram_Chart g
940 , Gram_File g
941 , Gram_Path g
942 , Gram_IO src g
943 , Gram_Comment g
944 , Gram_Transaction g
945 , Gram_Term_Def src ss g
946 , G.Gram_Reader (S.Either Exn.IOException CanonFile) g
947 , G.Gram_State (Context_Read src) g
948 , G.Gram_State (Sym.Imports Sym.NameTe, Sym.Modules src ss) g
949 -- , G.Gram_State (Journal j) g
950 -- , G.Gram_State (Journals j) g
951 , G.Gram_State Terms g
952 , Gram_Input g
953 -- , H.Zeroable j
954 -- , Show src
955 ) => Gram_Compta ss src g where
956 g_compta :: CF g (S.Either [At src (Error_Compta src)] CanonFile)
957 g_compta = rule "Journal" $
958 G.stateAfter $ G.askBefore $
959 mk_journal
960 <$> (G.stateAfter $ G.source $ G.askBefore $ G.askBefore $ pure init_journal)
961 <*> many (choice
962 [ G.stateAfter $ mk_include <$> g_include @ss
963 -- NOTE: g_include must be the first choice
964 -- in order to have Megaparsec reporting the errors
965 -- of the included journal.
966 , G.stateAfter $ mk_transaction
967 <$> g_compta_section Section_Transactions g_transaction
968 , G.stateAfter $ mk_chart
969 <$> g_compta_section Section_Chart g_chart_entry
970 , G.stateBefore $ G.stateBefore $ g_input $ G.source $ mk_term
971 <$> g_compta_section Section_Terms g_term_def
972 , ([], []) <$ try (g_spaces <* g_eol)
973 ])
974 where
975 init_journal
976 (SourcePos jf _ _) lr_cf src
977 (ctx@Context_Read
978 { context_read_journals = Journals js
979 , context_read_journal = jnls
980 , context_read_canonfiles = cfs
981 , ..
982 }::Context_Read src) =
983 case lr_cf of
984 S.Left e -> (ctx, S.Left $ At src $ Error_Compta_Read (PathFile jf) e)
985 S.Right cf ->
986 let jnl = (journal H.zero){journal_file=PathFile jf} in
987 (,S.Right ())
988 Context_Read
989 { context_read_journals = Journals $ Map.insert cf jnl js
990 , context_read_journal = jnl <| jnls
991 , context_read_canonfiles = cf <| cfs
992 , ..
993 }
994 mk_journal err errs_warns
995 (SourcePos jf _ _)
996 (ctx@Context_Read
997 { context_read_journals = Journals js
998 , context_read_journal = jnl :| jnls
999 , context_read_canonfiles = cf :| cfs
1000 , context_read_warnings = warnings
1001 , ..
1002 }::Context_Read src) =
1003 let (errs, warns) = L.unzip errs_warns in
1004 case S.either pure (const []) err <> L.concat errs of
1005 [] ->
1006 let jnl' = jnl{journal_file=PathFile jf} in
1007 (,S.Right cf)
1008 Context_Read
1009 { context_read_journals = Journals $ Map.insert cf jnl' js
1010 , context_read_journal = NonEmpty.fromList jnls
1011 , context_read_canonfiles = NonEmpty.fromList cfs
1012 , context_read_warnings = warnings <> L.concat warns
1013 , ..
1014 }
1015 es -> (ctx, S.Left es)
1016 mk_transaction lr_txn
1017 (ctx@Context_Read
1018 { context_read_journal = j :| js
1019 , context_read_consTxn
1020 , ..
1021 }::Context_Read src) =
1022 case lr_txn of
1023 S.Left err -> (ctx, ([err], []))
1024 S.Right txn -> (, ([], [])) Context_Read
1025 { context_read_journal = j{journal_content = txn `context_read_consTxn` journal_content j} :| js
1026 , ..
1027 }
1028
1029 mk_include lr_inc
1030 (ctx@Context_Read
1031 { context_read_journal = j :| js
1032 , context_read_consTxn
1033 , ..
1034 }::Context_Read src) =
1035 case lr_inc of
1036 S.Left errs -> (ctx, (errs, []))
1037 S.Right cf -> (, ([], [])) Context_Read
1038 { context_read_journal = j{journal_includes = journal_includes j <> [cf]} :| js
1039 , ..
1040 }
1041 mk_chart lr_ch chart =
1042 case lr_ch of
1043 S.Left err -> (chart, ([err], []))
1044 S.Right ch -> (chart <> ch, ([], []))
1045 mk_term lr_te src body (imps::Sym.Imports Sym.NameTe, mods) =
1046 case lr_te of
1047 S.Left err -> ((imps, mods), (, ([err], [])))
1048 S.Right (n, te) -> ((imps, ins_term n te mods), \ts -> (ins_body n body ts, ([], warn_redef n ts)))
1049 where
1050 ins_term :: Sym.NameTe -> Sym.TermVT src ss '[] -> Sym.Modules src ss -> Sym.Modules src ss
1051 ins_term n t = Sym.insertTermVT ([] `Sym.Mod` t) n (Sym.Fixity2 Sym.infixN5)
1052 ins_body :: Sym.NameTe -> Text -> Terms -> Terms
1053 ins_body n = Map.insert ([] `Sym.Mod` n)
1054 warn_redef :: Sym.NameTe -> Terms -> [At src Warning_Compta]
1055 warn_redef n ts =
1056 case Map.lookup ([] `Sym.Mod` n) ts of
1057 Just{} -> [At src $ Warning_Compta_Term_redefined n]
1058 Nothing -> []
1059 g_include :: CF g (S.Either [At src (Error_Compta src)] CanonFile)
1060 g_include = rule "Include" $
1061 g_read g_path (g_compta @ss <* G.eoi)
1062 where
1063 g_path =
1064 G.stateAfter $ G.source $ check_path
1065 <$> (g_canonfile $ G.askBefore $ fmap mk_path $
1066 (\d (PathFile p) -> PathFile $ d:p)
1067 <$> char '.' <*> g_pathfile)
1068 mk_path (PathFile fp) (SourcePos fp_old _ _) =
1069 PathFile $
1070 FilePath.normalise $
1071 FilePath.takeDirectory fp_old </> fp
1072 check_path (fp, lr_cf) src
1073 (ctx@Context_Read
1074 { context_read_journals = Journals js
1075 , context_read_canonfiles = cfs
1076 , context_read_warnings = warns
1077 }::Context_Read src) =
1078 case lr_cf of
1079 Left e -> (ctx, S.Left $ Error_Compta_Read fp e)
1080 Right cf ->
1081 if cf `Map.member` js
1082 then
1083 if cf `elem` cfs
1084 then (ctx, S.Left $ Error_Compta_Include_loop cf)
1085 else
1086 (,S.Right fp) $
1087 if isJust $ (`L.find` warns) $ \case
1088 At{unAt=Warning_Compta_Include_multiple cf'} -> cf' `elem` cf<|cfs
1089 _ -> False
1090 then ctx
1091 else ctx
1092 { context_read_warnings =
1093 At src (Warning_Compta_Include_multiple cf) : warns }
1094 else (ctx, S.Right fp)
1095
1096 -- * Integers
1097
1098 -- | Return the 'Integer' obtained by multiplying the given digits
1099 -- with the power of the given base respective to their rank.
1100 integer_of_digits
1101 :: Integer -- ^ Base.
1102 -> String -- ^ Digits (MUST be recognised by 'Char.digitToInt').
1103 -> Integer
1104 integer_of_digits base =
1105 foldl' (\x d -> base*x + toInteger (Char.digitToInt d)) 0
1106
1107 -- | Return the 'Int' obtained by multiplying the given digits
1108 -- with the power of the given base respective to their rank.
1109 int_of_digits
1110 :: Int -- ^ Base.
1111 -> String -- ^ Digits (MUST be recognised by 'Char.digitToInt').
1112 -> Int
1113 int_of_digits base =
1114 foldl' (\x d -> base*x + Char.digitToInt d) 0
1115
1116 -- * Chars
1117 char_account_sep :: Char
1118 char_account_sep = '/'
1119 char_account_tag_prefix :: Char
1120 char_account_tag_prefix = '~'
1121 char_ymd_sep :: Char
1122 char_ymd_sep = '-'
1123 char_tod_sep :: Char
1124 char_tod_sep = ':'
1125 char_comment_prefix :: Char
1126 char_comment_prefix = ';'
1127 char_tag_prefix :: Char
1128 char_tag_prefix = '#'
1129 char_tag_sep :: Char
1130 char_tag_sep = ':'
1131 char_tag_data_prefix :: Char
1132 char_tag_data_prefix = '='
1133 char_transaction_date_sep :: Char
1134 char_transaction_date_sep = '='
1135
1136 -- * Type 'Env'
1137 type Env src ss = Map Sym.NameTe (Sym.TermVT src ss '[])
1138
1139 -- * Type 'Section'
1140 data Section
1141 = Section_Terms
1142 | Section_Chart
1143 | Section_Transactions
1144 deriving (Eq, Ord, Show)
1145
1146 g_compta_section ::
1147 forall src err a g.
1148 Sym.ErrorInj err (Error_Compta src) =>
1149 G.Gram_State Section g =>
1150 G.Gram_Source src g =>
1151 Functor g =>
1152 Section ->
1153 g (S.Either (At src err) a) ->
1154 g (S.Either (At src (Error_Compta src)) a)
1155 g_compta_section sec g =
1156 G.stateBefore $ G.source $
1157 (\a src sec_curr ->
1158 (sec,) $
1159 if sec_curr <= sec
1160 then fmap Sym.errorInj `S.left` a
1161 else S.Left $ At src $ Error_Compta_Section sec_curr sec
1162 ) <$> g
1163
1164 -- * Type 'Year'
1165 newtype Year = Year (H.Date_Year Date)
1166 deriving (Eq, Show)
1167
1168
1169 -- * Type 'Error_Date'
1170 data Error_Date
1171 = Error_Date_Day_invalid (Integer, Int, Int)
1172 | Error_Date_TimeOfDay_invalid (Int, Int, Int)
1173 | Error_Date_TimeZone_unknown Text
1174 deriving (Eq, Show)
1175
1176 -- * Type 'Error_Posting'
1177 data Error_Posting
1178 = Error_Posting_Account_Ref_unknown Tag_Path
1179 | Error_Posting_Account_Ref_multiple Tag_Path (Map Account ())
1180 | Error_Postings_not_equilibrated Postings
1181 deriving (Eq, Show)
1182
1183 -- * Type 'Error_Transaction'
1184 data Error_Transaction
1185 = Error_Transaction_Date Error_Date
1186 | Error_Transaction_Posting Error_Posting
1187 | Error_Transaction_not_equilibrated
1188 Transaction
1189 [( Unit
1190 , H.SumByUnit (NonNull [NameAccount]) (H.Polarized Quantity)
1191 )]
1192 deriving (Eq, Show)
1193
1194 -- * Type 'Error_Chart'
1195 data Error_Chart
1196 = Error_Chart
1197 deriving (Eq, Show)
1198
1199 -- * Type 'Error_Compta'
1200 data Error_Compta src
1201 = Error_Compta_Transaction Error_Transaction
1202 | Error_Compta_Read PathFile Exn.IOException
1203 | Error_Compta_Include_loop CanonFile
1204 | Error_Compta_Chart Error_Chart
1205 | Error_Compta_Section Section Section
1206 | Error_Compta_Term Sym.NameTe (Sym.Error_Term src)
1207 deriving (Eq, Show)
1208
1209 instance Sym.ErrorInj (Sym.NameTe, Sym.Error_Term src) (Error_Compta src) where
1210 errorInj (n, t) = Error_Compta_Term n t
1211 instance Sym.ErrorInj Error_Transaction (Error_Compta src) where
1212 errorInj = Error_Compta_Transaction
1213 instance Sym.ErrorInj (Error_Compta src) (Error_Compta src) where
1214 errorInj = id
1215
1216 -- * Type 'Warning_Compta'
1217 data Warning_Compta
1218 = Warning_Compta_Include_multiple CanonFile
1219 | Warning_Compta_Term_redefined Sym.NameTe
1220 deriving (Eq, Show)
1221
1222 {-
1223 nonEmpty :: NonNull [a] -> NonEmpty a
1224 nonEmpty n = x :| xs where (x, xs) = NonNull.splitFirst n
1225 nonNull :: NonEmpty a -> NonNull [a]
1226 nonNull n = NonNull.ncons x xs where x :| xs = n
1227 -}