lcc/Hcompta/LCC/Grammar.hs

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