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