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