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