lcc/Hcompta/LCC/Grammar.hs

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