lcc/Hcompta/LCC/Grammar.hs

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