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