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