lcc/Hcompta/LCC/Read.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE NamedFieldPuns #-}
   4 {-# LANGUAGE OverloadedStrings #-}
   5 {-# LANGUAGE ScopedTypeVariables #-}
   6 {-# LANGUAGE TupleSections #-}
   7 {-# LANGUAGE TypeFamilies #-}
   8 module Hcompta.LCC.Read where
   9
  10 import           Prelude (Int, Integer, Num(..), fromIntegral)
  11 import           Control.Applicative ((<$>), (<*>), (<*))
  12 import           Data.Bool
  13 import           Data.Char (Char)
  14 import qualified Data.Char as Char
  15 import           Data.Decimal
  16 import           Data.Either (Either(..))
  17 import           Data.Eq (Eq(..))
  18 import qualified Control.Exception.Safe as Exn
  19 import qualified System.FilePath.Posix as FilePath
  20 import           Data.Function (($), (.), id, const, flip)
  21 import           System.IO (IO, FilePath)
  22 import qualified Data.List as List
  23 import           Data.List.NonEmpty (NonEmpty(..))
  24 import           Data.Map.Strict (Map)
  25 import qualified Data.Map.Strict as Map
  26 import           Data.Maybe (Maybe(..), fromMaybe, maybe)
  27 import           Data.NonNull (NonNull)
  28 import qualified Data.NonNull as NonNull
  29 import           Control.Monad (Monad(..), guard, join, void)
  30 import           Control.Monad.IO.Class (liftIO)
  31 import           Control.Monad.Trans.Except (ExceptT(..), throwE)
  32 import           Data.Monoid (Monoid(..))
  33 import           Data.Ord (Ord(..))
  34 import           Data.Semigroup (Semigroup(..))
  35 import           Text.Parsec (Stream, ParsecT, (<|>), (<?>))
  36 import qualified Text.Parsec as R hiding
  37                   ( char
  38                   , anyChar
  39                   , crlf
  40                   , newline
  41                   , noneOf
  42                   , oneOf
  43                   , satisfy
  44                   , space
  45                   , spaces
  46                   , string
  47                   , tab
  48                   )
  49 import qualified Text.Parsec.Combinator.CorrectSourcePosWithTab as R
  50 import qualified Text.Parsec.Error.Custom as R
  51 import qualified Text.Parsec.Pos as R
  52 import           Text.Show (Show)
  53 import           Data.String (String, fromString)
  54 import           Data.Text (Text)
  55 import qualified Data.Text.IO as Text.IO (readFile)
  56 import qualified Data.Time.Calendar  as Time
  57 import qualified Data.Time.Clock     as Time
  58 import           Data.Time.LocalTime (TimeZone(..))
  59 import qualified Data.Time.LocalTime as Time
  60 import qualified Data.TreeMap.Strict as TreeMap
  61 import           Data.Typeable ()
  62
  63 import qualified Hcompta as H
  64 import qualified Hcompta.LCC.Lib.FilePath as FilePath
  65 import qualified Hcompta.LCC.Lib.Parsec as R
  66 import           Hcompta.Lib.Consable (Consable(..))
  67
  68 import Hcompta.LCC.Account
  69 import Hcompta.LCC.Name
  70 import Hcompta.LCC.Tag
  71 import Hcompta.LCC.Anchor
  72 import Hcompta.LCC.Amount
  73 import Hcompta.LCC.Chart
  74 import Hcompta.LCC.Posting
  75 import Hcompta.LCC.Transaction
  76 import Hcompta.LCC.Journal
  77
  78 -- * Type 'Context_Read'
  79 data Context_Read c j
  80  =   Context_Read
  81  {   context_read_account_prefix :: !(Maybe Account)
  82  ,   context_read_aliases_exact  :: !(Map Account Account)
  83  -- ,   context_read_aliases_joker  :: ![(Account_Joker, Account)]
  84  -- ,   context_read_aliases_regex  :: ![(Regex, Account)]
  85  ,   context_read_cons           :: Charted Transaction -> c
  86  ,   context_read_date           :: !Date
  87  ,   context_read_journal        :: !(Journal j)
  88  ,   context_read_unit           :: !(Maybe Unit)
  89  ,   context_read_year           :: !(H.Date_Year Date)
  90  }
  91
  92 context_read
  93  :: (Charted Transaction -> c)
  94  -> Journal j
  95  -> Context_Read c j
  96 context_read context_read_cons context_read_journal =
  97         Context_Read
  98          { context_read_account_prefix = Nothing
  99          , context_read_aliases_exact  = mempty
 100          -- , context_read_aliases_joker  = []
 101          -- , context_read_aliases_regex  = []
 102          , context_read_cons
 103          , context_read_date           = H.date_epoch
 104          , context_read_journal
 105          , context_read_unit           = Nothing
 106          , context_read_year           = H.date_year (H.date_epoch::Date)
 107          }
 108
 109 -- * Type 'Error_Read'
 110 data Error_Read
 111  =   Error_Read_account_anchor_unknown R.SourcePos Account_Anchor
 112  |   Error_Read_account_anchor_not_unique R.SourcePos Account_Anchor
 113  |   Error_Read_date Error_Read_Date
 114  |   Error_Read_transaction_not_equilibrated
 115       Amount_Styles
 116       Transaction
 117       [( Unit
 118        , H.SumByUnit (NonEmpty Account_Section) (H.Polarized Quantity)
 119        )]
 120  |   Error_Read_virtual_transaction_not_equilibrated
 121       Amount_Styles
 122       Transaction
 123       [( Unit
 124        , H.SumByUnit (NonEmpty Account_Section) (H.Polarized Quantity)
 125        )]
 126  |   Error_Read_reading_file FilePath Exn.IOException
 127  |   Error_Read_including_file FilePath [R.Error Error_Read]
 128  deriving (Show)
 129
 130 -- * Read common patterns
 131 is_space :: Char -> Bool
 132 is_space = (== ' ')
 133 read_space :: Stream s m Char => ParsecT s u m Char
 134 read_space = R.satisfy is_space
 135 read_spaces :: Stream s m Char => ParsecT s u m [Char]
 136 read_spaces = R.many read_space
 137 read_spaces1 :: Stream s m Char => ParsecT s u m (NonNull [Char])
 138 read_spaces1 = NonNull.impureNonNull <$> R.many1 read_space
 139
 140 is_uspace :: Char -> Bool
 141 is_uspace c =
 142         case Char.generalCategory c of
 143          Char.Space -> True
 144          _ -> False
 145 read_uspace :: Stream s m Char => ParsecT s u m Char
 146 read_uspace = R.satisfy is_uspace
 147
 148 is_char :: Char -> Bool
 149 is_char c =
 150         case Char.generalCategory c of
 151          Char.UppercaseLetter      -> True
 152          Char.LowercaseLetter      -> True
 153          Char.TitlecaseLetter      -> True
 154          Char.ModifierLetter       -> True
 155          Char.OtherLetter          -> True
 156
 157          Char.NonSpacingMark       -> True
 158          Char.SpacingCombiningMark -> True
 159          Char.EnclosingMark        -> True
 160
 161          Char.DecimalNumber        -> True
 162          Char.LetterNumber         -> True
 163          Char.OtherNumber          -> True
 164
 165          Char.ConnectorPunctuation -> True
 166          Char.DashPunctuation      -> True
 167          Char.OpenPunctuation      -> True
 168          Char.ClosePunctuation     -> True
 169          Char.InitialQuote         -> True
 170          Char.FinalQuote           -> True
 171          Char.OtherPunctuation     -> True
 172
 173          Char.MathSymbol           -> True
 174          Char.CurrencySymbol       -> True
 175          Char.ModifierSymbol       -> True
 176          Char.OtherSymbol          -> True
 177
 178          Char.Space                -> False
 179          Char.LineSeparator        -> False
 180          Char.ParagraphSeparator   -> False
 181          Char.Control              -> False
 182          Char.Format               -> False
 183          Char.Surrogate            -> False
 184          Char.PrivateUse           -> False
 185          Char.NotAssigned          -> False
 186 read_char :: Stream s m Char => ParsecT s u m Char
 187 read_char = R.satisfy is_char
 188
 189 is_char_active :: Char -> Bool
 190 is_char_active c =
 191         case Char.generalCategory c of
 192          Char.UppercaseLetter      -> False
 193          Char.LowercaseLetter      -> False
 194          Char.TitlecaseLetter      -> False
 195          Char.ModifierLetter       -> False
 196          Char.OtherLetter          -> False
 197
 198          Char.NonSpacingMark       -> False
 199          Char.SpacingCombiningMark -> False
 200          Char.EnclosingMark        -> False
 201
 202          Char.DecimalNumber        -> False
 203          Char.LetterNumber         -> False
 204          Char.OtherNumber          -> False
 205
 206          Char.ConnectorPunctuation -> True
 207          Char.DashPunctuation      -> True
 208          Char.OpenPunctuation      -> True
 209          Char.ClosePunctuation     -> True
 210          Char.InitialQuote         -> True
 211          Char.FinalQuote           -> True
 212          Char.OtherPunctuation     -> True
 213
 214          Char.MathSymbol           -> True
 215          Char.CurrencySymbol       -> True
 216          Char.ModifierSymbol       -> True
 217          Char.OtherSymbol          -> True
 218
 219          Char.Space                -> False
 220          Char.LineSeparator        -> False
 221          Char.ParagraphSeparator   -> False
 222          Char.Control              -> False
 223          Char.Format               -> False
 224          Char.Surrogate            -> False
 225          Char.PrivateUse           -> False
 226          Char.NotAssigned          -> False
 227         {-
 228         case c of
 229          '/' -> True
 230          '\\' -> True
 231          '!' -> True
 232          '?' -> True
 233          '\'' -> True
 234          '"' -> True
 235          '&' -> True
 236          '|' -> True
 237          '-' -> True
 238          '+' -> True
 239          '.' -> True
 240          ':' -> True
 241          '=' -> True
 242          '<' -> True
 243          '>' -> True
 244          '@' -> True
 245          '#' -> True
 246          '(' -> True
 247          ')' -> True
 248          '[' -> True
 249          ']' -> True
 250          '{' -> True
 251          '}' -> True
 252          '~' -> True
 253          '*' -> True
 254          '^' -> True
 255          ';' -> True
 256          ',' -> True
 257          _  ->
 258                 case Char.generalCategory c of
 259                  Char.CurrencySymbol -> True
 260                  _ -> False
 261         -}
 262 read_char_active :: Stream s m Char => ParsecT s u m Char
 263 read_char_active = R.satisfy is_char_active
 264
 265 is_char_passive :: Char -> Bool
 266 is_char_passive c =
 267         case Char.generalCategory c of
 268          Char.UppercaseLetter      -> True
 269          Char.LowercaseLetter      -> True
 270          Char.TitlecaseLetter      -> True
 271          Char.ModifierLetter       -> True
 272          Char.OtherLetter          -> True
 273
 274          Char.NonSpacingMark       -> True
 275          Char.SpacingCombiningMark -> True
 276          Char.EnclosingMark        -> True
 277
 278          Char.DecimalNumber        -> True
 279          Char.LetterNumber         -> True
 280          Char.OtherNumber          -> True
 281
 282          Char.ConnectorPunctuation -> False
 283          Char.DashPunctuation      -> False
 284          Char.OpenPunctuation      -> False
 285          Char.ClosePunctuation     -> False
 286          Char.InitialQuote         -> False
 287          Char.FinalQuote           -> False
 288          Char.OtherPunctuation     -> False
 289
 290          Char.MathSymbol           -> False
 291          Char.CurrencySymbol       -> False
 292          Char.ModifierSymbol       -> False
 293          Char.OtherSymbol          -> False
 294
 295          Char.Space                -> False
 296          Char.LineSeparator        -> False
 297          Char.ParagraphSeparator   -> False
 298          Char.Control              -> False
 299          Char.Format               -> False
 300          Char.Surrogate            -> False
 301          Char.PrivateUse           -> False
 302          Char.NotAssigned          -> False
 303 read_char_passive :: Stream s m Char => ParsecT s u m Char
 304 read_char_passive = R.satisfy is_char_passive
 305
 306 is_char_attribut :: Char -> Bool
 307 is_char_attribut c =
 308         case c of
 309          '/' -> True
 310          '#' -> True
 311          ':' -> True
 312          '@' -> True
 313          '~' -> True
 314          '=' -> True
 315          _ -> False
 316
 317 read_word :: Stream s m Char => ParsecT s u m Text
 318 read_word = fromString <$> R.many1 read_char
 319
 320 read_name :: Stream s m Char => ParsecT s u m Name
 321 read_name =
 322         Name . fromString
 323          <$> R.many1 (R.satisfy $ \c ->
 324                 Char.isLetter c ||
 325                 Char.isMark   c ||
 326                 Char.isNumber c)
 327
 328 read_tabulation :: Stream s m Char => ParsecT s u m Char
 329 read_tabulation = R.char '\t'
 330
 331 read_eol :: Stream s m Char => ParsecT s u m ()
 332 read_eol = (<?> "eol") $
 333         (<|>)
 334          (void $ R.char '\n')
 335          (void $ R.try $ R.string "\r\n")
 336
 337 read_words :: Stream s m Char => ParsecT s u m Text
 338 read_words =
 339         (fromString . List.concat <$>) $
 340         R.many $ R.try $
 341                 (<>)
 342                  <$> read_spaces
 343                  <*> R.many1 read_char
 344         --R.manyTill (R.satisfy $ \c -> is_char c || is_uspace c)
 345         -- (R.lookAhead read_eol <|> R.eof)
 346         -- R.many (R.notFollowedBy eol >> char)
 347
 348 -- * Read 'Account'
 349 char_account_sep :: Char
 350 char_account_sep = '/'
 351
 352 read_account :: Stream s m Char => ParsecT s u m Account
 353 read_account =
 354         (Account . NonNull.impureNonNull <$>) $
 355         R.many1 $ do
 356                 void $ R.char char_account_sep
 357                 read_account_section
 358
 359 read_account_section :: Stream s m Char => ParsecT s u m Name
 360 read_account_section =
 361         Name . fromString
 362          <$> R.many1 (R.satisfy $ \c ->
 363                 not (is_char_attribut c) &&
 364                 is_char c)
 365
 366 {-
 367 read_account_section_joker :: Stream s m Char => ParsecT s u m Account_Joker_Section
 368 read_account_section_joker = do
 369         n <- R.option Nothing $ (Just <$> read_account_section)
 370         case n of
 371          Nothing -> R.char char_account_sep >> return Account_Joker_Any
 372          Just n' -> return $ Account_Joker_Section n'
 373
 374 read_account_joker :: Stream s m Char => ParsecT s u m Account_Joker
 375 read_account_joker = do
 376         R.notFollowedBy $ R.spaceHorizontal
 377         R.many1_separated read_account_section_joker $ R.char char_account_sep
 378
 379 read_account_regex :: Stream s m Char => ParsecT s u m Regex
 380 read_account_regex = do
 381         re <- R.many1 $ R.satisfy (not . R.is_space_horizontal)
 382         Regex.of_StringM re
 383
 384 read_account_pattern :: Stream s m Char => ParsecT s u m Account_Pattern
 385 read_account_pattern =
 386         R.choice_try
 387          [ Account_Pattern_Exact <$> (R.char '=' >> read_account)
 388          , Account_Pattern_Joker <$> (R.char '*' >> read_account_joker)
 389          -- , Account_Pattern_Regex <$> (R.option '~' (R.char '~') >> read_account_regex)
 390          ]
 391 -}
 392
 393 -- ** Read 'Account_Tag'
 394 char_account_tag_prefix :: Char
 395 char_account_tag_prefix = '#'
 396
 397 read_account_tag :: Stream s m Char => ParsecT s u m Account_Tag
 398 read_account_tag =
 399         (<?> "account_tag") $ Account_Tag
 400          <$> read_tag char_account_tag_prefix
 401
 402 -- ** Read 'Account_Anchor'
 403 char_account_anchor_prefix :: Char
 404 char_account_anchor_prefix = '~'
 405 char_account_anchor_sep :: Char
 406 char_account_anchor_sep = ':'
 407
 408 read_account_anchor :: Stream s m Char => ParsecT s u m Account_Anchor
 409 read_account_anchor =
 410         (<?> "account_anchor") $ Account_Anchor
 411          <$> read_anchor char_account_anchor_prefix
 412
 413 -- * Read 'Amount'
 414 read_amount
 415  :: Stream s m Char
 416  => ParsecT s u m (Amount_Styled Amount)
 417 read_amount = (<?> "amount") $ do
 418         left_signing <- read_sign
 419         left_unit <-
 420                 R.option Nothing $ do
 421                         u <- read_unit
 422                         s <- R.many $ R.spaceHorizontal
 423                         return $ Just $ (u, not $ List.null s)
 424         (qty, style) <- do
 425                 signing <- read_sign
 426                 (  amount_style_integral
 427                  , amount_style_fractional
 428                  , amount_style_fractioning
 429                  , amount_style_grouping_integral
 430                  , amount_style_grouping_fractional
 431                  ) <- (<?> "quantity") $
 432                         R.choice_try
 433                          [ read_quantity '_' ',' '_' <* R.notFollowedBy (R.oneOf ",._")
 434                          , read_quantity '_' '.' '_' <* R.notFollowedBy (R.oneOf ",._")
 435                          , read_quantity ',' '.' '_' <* R.notFollowedBy (R.oneOf ",._")
 436                          , read_quantity '.' ',' '_' <* R.notFollowedBy (R.oneOf ",._")
 437                          ]
 438                 let int  = List.concat amount_style_integral
 439                 let frac = List.concat amount_style_fractional
 440                 let precision = List.length frac
 441                 guard (precision <= 255)
 442                 let mantissa = R.integer_of_digits 10 $ int `mappend` frac
 443                 return $
 444                  ( Data.Decimal.Decimal
 445                          (fromIntegral precision)
 446                          (signing mantissa)
 447                  , mempty
 448                          { amount_style_fractioning
 449                          , amount_style_grouping_integral
 450                          , amount_style_grouping_fractional
 451                          }
 452                  )
 453         (  amount_unit
 454          , amount_style_unit_side
 455          , amount_style_unit_spaced ) <-
 456                 case left_unit of
 457                  Just (u, s) ->
 458                         return (u, Just Amount_Style_Side_Left, Just s)
 459                  Nothing ->
 460                         R.option (H.unit_empty, Nothing, Nothing) $ R.try $ do
 461                                 s <- R.many R.spaceHorizontal
 462                                 u <- read_unit
 463                                 return $
 464                                  ( u
 465                                  , Just Amount_Style_Side_Right
 466                                  , Just $ not $ List.null s )
 467         return
 468          ( style
 469                  { amount_style_unit_side
 470                  , amount_style_unit_spaced
 471                  }
 472          , Amount
 473                  { amount_quantity = left_signing qty
 474                  , amount_unit
 475                  }
 476          )
 477
 478 -- ** Read 'Quantity'
 479 read_quantity
 480  :: Stream s m Char
 481  => Char -- ^ Integral grouping separator.
 482  -> Char -- ^ Fractioning separator.
 483  -> Char -- ^ Fractional grouping separator.
 484  -> ParsecT s u m
 485  ( [String] -- integral
 486  , [String] -- fractional
 487  , Maybe Amount_Style_Fractioning -- fractioning
 488  , Maybe Amount_Style_Grouping -- grouping_integral
 489  , Maybe Amount_Style_Grouping -- grouping_fractional
 490  )
 491 read_quantity int_group_sep frac_sep frac_group_sep = do
 492         (integral, grouping_integral) <- do
 493                 h <- R.many R.digit
 494                 case h of
 495                  [] -> return ([], Nothing)
 496                  _ -> do
 497                         t <- R.many $ R.char int_group_sep >> R.many1 R.digit
 498                         let digits = h:t
 499                         return (digits, grouping_of_digits int_group_sep digits)
 500         (fractional, fractioning, grouping_fractional) <-
 501                 (case integral of
 502                  [] -> id
 503                  _ -> R.option ([], Nothing, Nothing)) $ do
 504                         fractioning <- R.char frac_sep
 505                         h <- R.many R.digit
 506                         t <- R.many $ R.char frac_group_sep >> R.many1 R.digit
 507                         let digits = h:t
 508                         return (digits, Just fractioning
 509                          , grouping_of_digits frac_group_sep $ List.reverse digits)
 510         return $
 511          ( integral
 512          , fractional
 513          , fractioning
 514          , grouping_integral
 515          , grouping_fractional
 516          )
 517         where
 518                 grouping_of_digits :: Char -> [String] -> Maybe Amount_Style_Grouping
 519                 grouping_of_digits group_sep digits =
 520                         case digits of
 521                          []  -> Nothing
 522                          [_] -> Nothing
 523                          _   -> Just $
 524                                 Amount_Style_Grouping group_sep $
 525                                 canonicalize_grouping $
 526                                 List.map List.length $ digits
 527                 canonicalize_grouping :: [Int] -> [Int]
 528                 canonicalize_grouping groups =
 529                         List.foldl' -- NOTE: remove duplicates at beginning and reverse.
 530                          (\acc l0 -> case acc of
 531                                  l1:_ -> if l0 == l1 then acc else l0:acc
 532                                  _ -> l0:acc) [] $
 533                         case groups of -- NOTE: keep only longer at beginning.
 534                          l0:l1:t -> if l0 > l1 then groups else l1:t
 535                          _ -> groups
 536
 537 -- ** Read 'Unit'
 538 read_unit :: Stream s m Char => ParsecT s u m Unit
 539 read_unit = (<?> "unit") $
 540         quoted <|> unquoted
 541         where
 542                 unquoted :: Stream s m Char => ParsecT s u m Unit
 543                 unquoted =
 544                         (fromString <$>) $
 545                         R.many1 $
 546                                 R.satisfy $ \c ->
 547                                         case Char.generalCategory c of
 548                                          Char.CurrencySymbol  -> True
 549                                          Char.LowercaseLetter -> True
 550                                          Char.ModifierLetter  -> True
 551                                          Char.OtherLetter     -> True
 552                                          Char.TitlecaseLetter -> True
 553                                          Char.UppercaseLetter -> True
 554                                          _ -> False
 555                 quoted :: Stream s m Char => ParsecT s u m Unit
 556                 quoted =
 557                         (fromString <$>) $
 558                         R.between (R.char '"') (R.char '"') $
 559                                 R.many1 $
 560                                         R.noneOf ";\n\""
 561
 562 -- | Parse either "-" into 'negate', or "+" or "" into 'id'.
 563 read_sign :: (Stream s m Char, Num i) => ParsecT s u m (i -> i)
 564 read_sign =
 565         (R.char '-' >> return negate) <|>
 566         (R.char '+' >> return id) <|>
 567         return id
 568
 569 -- * Read 'Date'
 570 data Error_Read_Date
 571  =   Error_Read_Date_year_or_day_is_missing
 572  |   Error_Read_Date_invalid_date (Integer, Int, Int)
 573  |   Error_Read_Date_invalid_time_of_day (Int, Int, Integer)
 574  deriving (Eq, Show)
 575
 576 -- | Read a 'Date' in @[YYYY[/-]]MM[/-]DD[_HH:MM[:SS][TZ]]@ format.
 577 read_date
 578  :: (Stream s (R.State_Error e m) Char, Monad m)
 579  => (Error_Read_Date -> e) -> Maybe Integer
 580  -> ParsecT s u (R.State_Error e m) Date
 581 read_date err def_year = (<?> "date") $ do
 582         let read_2_or_1_digits = R.try (R.count 2 R.digit) <|> R.count 1 R.digit
 583         n0 <- R.many1 R.digit
 584         day_sep <- R.char char_date_ymd_sep
 585         n1 <- read_2_or_1_digits
 586         n2 <- R.option Nothing $ R.try $ do
 587                 void $ R.char day_sep
 588                 Just <$> read_2_or_1_digits
 589         (year, m, d) <-
 590                 case (n2, def_year) of
 591                  (Nothing, Nothing) -> R.parserFailWith "date" (err $ Error_Read_Date_year_or_day_is_missing)
 592                  (Nothing, Just year) -> return (year, n0, n1)
 593                  (Just d, _)  -> return (R.integer_of_digits 10 n0, n1, d)
 594         let month = fromInteger $ R.integer_of_digits 10 m
 595         let dom   = fromInteger $ R.integer_of_digits 10 d
 596         day <- case Time.fromGregorianValid year month dom of
 597          Nothing  -> R.parserFailWith "date" (err $ Error_Read_Date_invalid_date (year, month, dom))
 598          Just day -> return day
 599         (hour, minu, sec, tz) <-
 600                 R.option (0, 0, 0, Time.utc) $ R.try $ do
 601                         void $ R.char '_'
 602                         hour <- read_2_or_1_digits
 603                         sep <- R.char char_date_hour_sep
 604                         minu <- read_2_or_1_digits
 605                         sec <- R.option Nothing $ R.try $ do
 606                                 void $ R.char sep
 607                                 Just <$> read_2_or_1_digits
 608                         tz <- R.option Time.utc $ R.try $
 609                                 read_time_zone
 610                         return
 611                          ( fromInteger $ R.integer_of_digits 10 hour
 612                          , fromInteger $ R.integer_of_digits 10 minu
 613                          , maybe 0      (R.integer_of_digits 10) sec
 614                          , tz )
 615         tod <- case Time.makeTimeOfDayValid hour minu (fromInteger sec) of
 616          Nothing  -> R.parserFailWith "date" $ err $
 617                 Error_Read_Date_invalid_time_of_day (hour, minu, sec)
 618          Just tod -> return tod
 619         return $ Time.localTimeToUTC tz (Time.LocalTime day tod)
 620
 621 -- | Separator for year, month and day: "-".
 622 char_date_ymd_sep :: Char
 623 char_date_ymd_sep = '-'
 624
 625 -- | Separator for hour, minute and second: ":".
 626 char_date_hour_sep :: Char
 627 char_date_hour_sep = ':'
 628
 629 read_time_zone :: Stream s m Char => ParsecT s u m TimeZone
 630 read_time_zone =
 631         -- DOC: http://www.timeanddate.com/time/zones/
 632         -- TODO: only a few time zones are suported below.
 633         -- TODO: check the timeZoneSummerOnly values
 634         R.choice
 635          [ R.char '_' >>
 636                 R.choice
 637                  [ R.char 'A' >> R.choice
 638                          [ R.string "ST" >> return (TimeZone ((-4) * 60) False "AST")
 639                          , R.string "DT" >> return (TimeZone ((-3) * 60) True  "ADT")
 640                          , return (TimeZone ((-1) * 60) False "A")
 641                          ]
 642                  , R.char 'B' >> R.choice
 643                          [ R.string "ST" >> return (TimeZone ((-11) * 60) False "BST")
 644                          , R.string "DT" >> return (TimeZone ((-10) * 60) True  "BDT")
 645                          ]
 646                  , R.char 'C' >> R.choice
 647                          [ R.char 'E' >> R.choice
 648                                  [ R.string "T"  >> return (TimeZone ((1) * 60) True  "CET")
 649                                  , R.string "ST" >> return (TimeZone ((2) * 60) False "CEST")
 650                                  ]
 651                          , R.string "ST" >> return (TimeZone ((-6) * 60) False "CST")
 652                          , R.string "DT" >> return (TimeZone ((-5) * 60) True  "CDT")
 653                          ]
 654                  , R.char 'E' >> R.choice
 655                          [ R.string "ST" >> return (TimeZone ((-5) * 60) False "EST")
 656                          , R.string "DT" >> return (TimeZone ((-4) * 60) True  "EDT")
 657                          ]
 658                  , R.string "GMT" >> return (TimeZone 0 False "GMT")
 659                  , R.char 'H' >> R.choice
 660                          [ R.string "ST" >> return (TimeZone ((-10) * 60) False "HST")
 661                          , R.string "DT" >> return (TimeZone (( -9) * 60) True  "HDT")
 662                          ]
 663                  , R.char 'M' >> R.choice
 664                          [ R.string "ST" >> return (TimeZone ((-7) * 60) False "MST")
 665                          , R.string "DT" >> return (TimeZone ((-6) * 60) True  "MDT")
 666                          , return (TimeZone ((-12) * 60) False "M")
 667                          ]
 668                  , R.char 'N' >> R.choice
 669                          [ R.string "ST" >> return (TimeZone ((-3) * 60 - 30) False "NST")
 670                          , return (TimeZone (1 * 60) False "N")
 671                          ]
 672                  , R.char 'P' >> R.choice
 673                          [ R.string "ST" >> return (TimeZone ((-8) * 60) False "PST")
 674                          , R.string "DT" >> return (TimeZone ((-7) * 60) True  "PDT")
 675                          ]
 676                  , R.char 'Y' >> R.choice
 677                          [ R.string "ST" >> return (TimeZone ((-9) * 60) False "YST")
 678                          , R.string "DT" >> return (TimeZone ((-8) * 60) True  "YDT")
 679                          , return (TimeZone (12 * 60) False "Y")
 680                          ]
 681                  , R.char 'Z' >> return (TimeZone 0 False "Z")
 682                  ]
 683          , read_time_zone_digits
 684          ]
 685
 686 read_time_zone_digits :: Stream s m Char => ParsecT s u m TimeZone
 687 read_time_zone_digits = do
 688         sign_ <- read_sign
 689         hour <- R.integer_of_digits 10 <$> R.count 2 R.digit
 690         minute <-
 691                 R.option 0 $ do
 692                         void $ R.char ':'
 693                         R.integer_of_digits 10 <$> R.count 2 R.digit
 694         let tz = TimeZone
 695                  { timeZoneMinutes    = sign_ (fromInteger hour * 60 + fromInteger minute)
 696                  , timeZoneSummerOnly = False
 697                  , timeZoneName       = Time.timeZoneOffsetString tz
 698                  }
 699         return tz
 700
 701 -- * Read 'Comment'
 702 char_comment_prefix :: Char
 703 char_comment_prefix = ';'
 704
 705 read_comment :: Stream s m Char => ParsecT s u m Comment
 706 read_comment = (<?> "comment") $ do
 707         void $ R.char char_comment_prefix
 708         void $ read_spaces
 709         Comment <$> read_words
 710
 711 read_comments
 712  :: Stream s m Char
 713  => ParsecT s u m [Comment]
 714 read_comments = (<?> "comments") $
 715         R.try (
 716                 do
 717                         void R.spaces
 718                         R.many1_separated read_comment
 719                          (read_eol >> read_spaces)
 720          <|> return []
 721          )
 722
 723 -- * Read 'Tag'
 724 char_tag_section_sep :: Char
 725 char_tag_section_sep = ':'
 726 char_tag_value_prefix :: Char
 727 char_tag_value_prefix = '='
 728
 729 read_tag :: Stream s m Char => Char -> ParsecT s u m Tag
 730 read_tag char_prefix = (<?> "tag") $ do
 731         void $ R.char char_prefix
 732         p <- read_tag_section
 733         (\ps -> Tag (Tag_Path $ p :| ps))
 734          <$> R.many (R.char char_tag_section_sep >> read_tag_section)
 735          <*> R.option (Tag_Value "") (R.try $ do
 736                 void $ read_spaces
 737                 void $ R.char char_tag_value_prefix
 738                 void $ read_spaces
 739                 read_tag_value)
 740
 741 read_tag_section :: Stream s m Char => ParsecT s u m Name
 742 read_tag_section =
 743         Name . fromString
 744          <$> R.many1 (R.satisfy $ \c ->
 745                 not (is_char_attribut c) &&
 746                 is_char c)
 747
 748 read_tag_value :: Stream s m Char => ParsecT s u m Tag_Value
 749 read_tag_value = Tag_Value <$> read_words
 750
 751 -- * Read 'Anchor'
 752 char_anchor_section_sep :: Char
 753 char_anchor_section_sep = ':'
 754
 755 read_anchor :: Stream s m Char => Char -> ParsecT s u m Anchor
 756 read_anchor char_prefix = (<?> "transaction_anchor") $ do
 757         void $ R.char char_prefix
 758         p <- read_anchor_section
 759         Anchor . NonNull.ncons p <$>
 760                 R.many (R.char char_anchor_section_sep >> read_anchor_section)
 761
 762 read_anchor_section :: Stream s m Char => ParsecT s u m Name
 763 read_anchor_section =
 764         Name . fromString
 765          <$> R.many1 (R.satisfy $ \c ->
 766                 not (is_char_attribut c) &&
 767                 is_char c)
 768
 769 -- * Read 'Posting'
 770 read_posting ::
 771  ( Monad m
 772  , Stream s (R.State_Error Error_Read m) Char
 773  ) => ParsecT s (Context_Read c j)
 774               (R.State_Error Error_Read m)
 775               Posting
 776 read_posting = (<?> "posting") $ do
 777         posting_sourcepos <- R.getPosition
 778         (  posting_account
 779          , posting_account_anchor ) <-
 780                 (<?> "posting_account") $
 781                 R.choice_try
 782                  [ (,Nothing) <$> read_account
 783                  , do
 784                         anchor <- read_account_anchor
 785                         ctx <- R.getState
 786                         let anchors = chart_anchors $ journal_chart $ context_read_journal ctx
 787                         case Map.lookup anchor anchors of
 788                          Just pa -> do
 789                                 sa <- R.option Nothing $ Just <$> read_account
 790                                 return $ ( maybe pa (pa <>) sa
 791                                          , Just (anchor, sa) )
 792                          Nothing -> R.parserFailWith "account anchor" $
 793                                 Error_Read_account_anchor_unknown posting_sourcepos anchor
 794                  ]
 795         posting_amounts <-
 796                 R.option mempty $ R.try $ do
 797                         (style, amt) <- read_spaces1 >> read_amount
 798                         ctx <- (<$> R.getState) $ \ctx ->
 799                                 ctx
 800                                  { context_read_journal=
 801                                         let jnl = context_read_journal ctx in
 802                                         jnl
 803                                          { journal_amount_styles =
 804                                                 let Amount_Styles styles = journal_amount_styles jnl in
 805                                                 Amount_Styles $
 806                                                 Map.insertWith (flip mappend)
 807                                                  (amount_unit amt)
 808                                                  style styles
 809                                          }
 810                                  }
 811                         R.setState ctx
 812                         return $
 813                                 let unit =
 814                                         case amount_unit amt of
 815                                          u | u == H.unit_empty ->
 816                                                 fromMaybe u $ context_read_unit ctx
 817                                          u -> u in
 818                                 Amounts $
 819                                 Map.singleton unit $
 820                                 amount_quantity amt
 821         (  posting_tags
 822          , posting_anchors
 823          , posting_comments
 824          ) <- read_posting_attributes
 825         return Posting
 826          { posting_account
 827          , posting_account_anchor
 828          , posting_amounts
 829          , posting_anchors
 830          , posting_tags
 831          , posting_comments
 832          , posting_dates = []
 833          , posting_sourcepos
 834          }
 835
 836 read_posting_attributes
 837  :: Stream s (R.State_Error Error_Read m) Char
 838  => ParsecT s (Context_Read c j)
 839             (R.State_Error Error_Read m)
 840             (Posting_Tags, Posting_Anchors, [Comment])
 841 read_posting_attributes =
 842         R.option mempty $ R.try $ do
 843                 void $ R.many $ R.try (read_spaces >> read_eol)
 844                 R.choice_try
 845                  [ read_spaces1 >> read_posting_anchor >>= \(Posting_Anchor p) -> do
 846                         (tags, Posting_Anchors (Anchors anchors), cmts) <- read_posting_attributes
 847                         return (tags, Posting_Anchors (Anchors (Map.insert p () anchors)), cmts)
 848                  , read_spaces1 >> read_posting_tag >>= \(Posting_Tag (Tag (Tag_Path p) v)) -> do
 849                         (Posting_Tags (Tags tags), anchors, cmts) <- read_posting_attributes
 850                         return (Posting_Tags (Tags (TreeMap.insert mappend p [v] tags)), anchors, cmts)
 851                  , read_spaces >> read_comment >>= \c -> do
 852                         (tags, anchors, cmts) <- read_posting_attributes
 853                         return (tags, anchors, c:cmts)
 854                  ]
 855
 856 read_posting_comment :: Stream s m Char => ParsecT s u m Comment
 857 read_posting_comment = read_comment
 858
 859 -- ** Read 'Posting_Tag'
 860 char_posting_tag_prefix :: Char
 861 char_posting_tag_prefix = '#'
 862
 863 read_posting_tag :: Stream s m Char => ParsecT s u m Posting_Tag
 864 read_posting_tag =
 865         (<?> "posting_tag") $ Posting_Tag
 866          <$> read_tag char_posting_tag_prefix
 867
 868 -- ** Read 'Posting_Anchor'
 869 char_posting_anchor_prefix :: Char
 870 char_posting_anchor_prefix = '@'
 871
 872 read_posting_anchor :: Stream s m Char => ParsecT s u m Posting_Anchor
 873 read_posting_anchor =
 874         (<?> "posting_anchor") $ Posting_Anchor
 875          <$> read_anchor char_posting_anchor_prefix
 876
 877 -- * Read 'Transaction'
 878 read_transaction
 879  :: (Monad m, Stream s (R.State_Error Error_Read m) Char)
 880  => ParsecT s (Context_Read c j)
 881               (R.State_Error Error_Read m)
 882               Transaction
 883 read_transaction = (<?> "transaction") $ do
 884         transaction_sourcepos <- R.getPosition
 885         ctx <- R.getState
 886         date <- read_date Error_Read_date (Just $ context_read_year ctx)
 887         dates <-
 888                 R.option [] $ R.try $ do
 889                         void read_spaces
 890                         void $ R.char char_transaction_date_sep
 891                         void read_spaces
 892                         R.many_separated
 893                          (read_date Error_Read_date (Just $ context_read_year ctx)) $
 894                                 R.try $
 895                                         read_spaces
 896                                         >> R.char char_transaction_date_sep
 897                                         >> read_spaces
 898         let transaction_dates = NonNull.ncons date dates
 899         void $ read_spaces1
 900         transaction_wording <- read_wording
 901         (  transaction_tags
 902          , transaction_anchors
 903          , transaction_comments
 904          ) <- read_transaction_attributes
 905         transaction_postings_unchecked <-
 906                 postings_by_account <$> read_postings
 907         let transaction_unchecked =
 908                 Transaction
 909                  { transaction_anchors
 910                  , transaction_tags
 911                  , transaction_comments
 912                  , transaction_dates
 913                  , transaction_wording
 914                  , transaction_postings = Postings transaction_postings_unchecked
 915                  , transaction_sourcepos
 916                  }
 917         let styles = journal_amount_styles $ context_read_journal ctx
 918         transaction_postings <-
 919                 case H.equilibrium transaction_postings_unchecked of
 920                  (_, Left ko) -> R.parserFailWith "transaction infer_equilibrium" $
 921                         Error_Read_transaction_not_equilibrated styles transaction_unchecked ko
 922                  (_bal, Right ok) -> return $ Postings ok
 923         return
 924                 transaction_unchecked
 925                  { transaction_postings
 926                  }
 927
 928 read_transaction_attributes
 929  :: Stream s (R.State_Error Error_Read m) Char
 930  => ParsecT s (Context_Read c j)
 931             (R.State_Error Error_Read m)
 932             (Transaction_Tags, Transaction_Anchors, [Comment])
 933 read_transaction_attributes =
 934         R.option mempty $ R.try $ do
 935                 void $ R.many (R.try (read_spaces >> read_eol))
 936                 R.choice_try
 937                  [ read_spaces1 >> read_transaction_anchor >>= \(Transaction_Anchor p) -> do
 938                         (tags, Transaction_Anchors (Anchors anchors), cmts) <- read_transaction_attributes
 939                         return (tags, Transaction_Anchors (Anchors (Map.insert p () anchors)), cmts)
 940                  , read_spaces1 >> read_transaction_tag >>= \(Transaction_Tag (Tag (Tag_Path p) v)) -> do
 941                         (Transaction_Tags (Tags tags), anchors, cmts) <- read_transaction_attributes
 942                         return (Transaction_Tags (Tags (TreeMap.insert mappend p [v] tags)), anchors, cmts)
 943                  , read_spaces >> read_comment >>= \c -> do
 944                         (tags, anchors, cmts) <- read_transaction_attributes
 945                         return (tags, anchors, c:cmts)
 946                  ]
 947
 948 read_postings ::
 949  (Monad m, Stream s (R.State_Error Error_Read m) Char)
 950  => ParsecT s (Context_Read c j) (R.State_Error Error_Read m) [Posting]
 951 read_postings = R.many $ R.try (read_spaces >> read_eol >> read_spaces1 >> read_posting)
 952
 953 char_transaction_date_sep :: Char
 954 char_transaction_date_sep = '='
 955
 956 read_wording
 957  :: Stream s m Char
 958  => ParsecT s u m Wording
 959 read_wording =
 960         (<?> "wording") $
 961         (Wording . fromString <$>) $
 962         R.many $ R.try $ R.satisfy $ \c ->
 963                 c /= char_transaction_tag_prefix &&
 964                 c /= char_transaction_anchor_prefix &&
 965                 (is_space c || is_char c)
 966
 967 -- ** Read 'Transaction_Anchor'
 968 char_transaction_anchor_prefix :: Char
 969 char_transaction_anchor_prefix = '@'
 970
 971 read_transaction_anchor :: Stream s m Char => ParsecT s u m Transaction_Anchor
 972 read_transaction_anchor =
 973         (<?> "transaction_anchor") $ Transaction_Anchor
 974          <$> read_anchor char_transaction_anchor_prefix
 975
 976 -- ** Read 'Transaction_Tag'
 977 char_transaction_tag_prefix :: Char
 978 char_transaction_tag_prefix = '#'
 979
 980 read_transaction_tag :: Stream s m Char => ParsecT s u m Transaction_Tag
 981 read_transaction_tag =
 982         (<?> "transaction_tag") $ Transaction_Tag
 983          <$> read_tag char_transaction_tag_prefix
 984
 985 -- * Read directives
 986 {-
 987 read_directive_alias
 988  :: (Consable c j, Stream s m Char)
 989  => ParsecT s (Context_Read c j) m ()
 990 read_directive_alias = do
 991         void $ R.string "alias"
 992         R.skipMany1 R.spaceHorizontal
 993         pat <- read_account_pattern
 994         read_spaces
 995         void $ R.char '='
 996         read_spaces
 997         repl <- read_account
 998         read_spaces
 999         case pat of
1000          Account_Pattern_Exact acct ->
1001                 R.modifyState $ \ctx -> ctx{context_read_aliases_exact=
1002                         Map.insert acct repl $ context_read_aliases_exact ctx}
1003          Account_Pattern_Joker jokr ->
1004                 R.modifyState $ \ctx -> ctx{context_read_aliases_joker=
1005                         (jokr, repl):context_read_aliases_joker ctx}
1006         -- Account_Pattern_Regex regx ->
1007         --      R.modifyState $ \ctx -> ctx{context_read_aliases_regex=
1008         --              (regx, repl):context_read_aliases_regex ctx}
1009         return ()
1010 -}
1011
1012 read_default_year :: Stream s m Char => ParsecT s (Context_Read c j) m ()
1013 read_default_year = (<?> "default year") $ do
1014         year <- R.integer_of_digits 10 <$> R.many1 R.digit
1015         void $ read_spaces
1016         context_read_ <- R.getState
1017         R.setState context_read_{context_read_year=year}
1018
1019 read_default_unit_and_style :: Stream s m Char => ParsecT s (Context_Read c j) m ()
1020 read_default_unit_and_style = (<?> "default_unit_and_style") $ do
1021         (sty, amt) <- read_amount
1022         void $ read_spaces
1023         ctx <- R.getState
1024         let unit = amount_unit amt
1025         R.setState ctx
1026          { context_read_journal =
1027                 let jnl = context_read_journal ctx in
1028                 jnl
1029                  { journal_amount_styles =
1030                         let Amount_Styles styles =
1031                                 journal_amount_styles jnl in
1032                         Amount_Styles $
1033                         Map.insertWith const unit sty styles
1034                  }
1035          , context_read_unit = Just unit
1036          }
1037
1038 read_include ::
1039  ( Consable c j
1040  , Monoid j
1041  , Stream s (R.State_Error Error_Read IO) Char
1042  ) => ParsecT s (Context_Read c j) (R.State_Error Error_Read IO) ()
1043 read_include = (<?> "include") $ do
1044         sourcepos <- R.getPosition
1045         filename <- R.manyTill R.anyChar (R.lookAhead (R.try read_eol <|> R.eof))
1046         context_read_including <- R.getState
1047         let journal_including = context_read_journal context_read_including
1048         let cwd = FilePath.takeDirectory (R.sourceName sourcepos)
1049         journal_file <- liftIO $ FilePath.path_absolute cwd filename
1050         content <-
1051                 join $ liftIO $ Exn.catch
1052                  (return <$> Text.IO.readFile journal_file)
1053                  (return . R.parserFailWith "include reading" . Error_Read_reading_file journal_file)
1054         (journal_included, context_read_included) <- do
1055                 lr <- liftIO $
1056                         R.runParserTWithError
1057                          (R.and_state $ read_journal_rec journal_file)
1058                          context_read_including
1059                                  { context_read_journal =
1060                                         journal
1061                                          { journal_chart         = journal_chart         journal_including
1062                                          , journal_amount_styles = journal_amount_styles journal_including
1063                                          }
1064                                  }
1065                          journal_file content
1066                 case lr of
1067                  Right ok -> return ok
1068                  Left  ko -> R.parserFailWith "include parsing" $
1069                         Error_Read_including_file journal_file ko
1070         R.setState
1071                 context_read_included
1072                  { context_read_journal =
1073                         journal_including
1074                          { journal_includes =
1075                                 journal_included{ journal_files = [journal_file] } :
1076                                 journal_includes journal_including
1077                          , journal_chart =
1078                                 journal_chart journal_included
1079                          , journal_amount_styles =
1080                                 journal_amount_styles journal_included
1081                          }
1082                  }
1083
1084 -- * Read 'Chart'
1085 read_chart
1086  :: (Monad m, Stream s (R.State_Error Error_Read m) Char)
1087  => ParsecT s (Context_Read c j)
1088               (R.State_Error Error_Read m)
1089               ()
1090 read_chart = (<?> "chart") $
1091         -- sourcepos <- R.getPosition
1092         void $ R.many $ do
1093                 acct <- read_account
1094                 void read_eol
1095                 ( chart_tags
1096                  , chart_anchors
1097                  , _chart_comments ) <-
1098                         fields acct mempty mempty mempty
1099                 let chart_accounts =
1100                         TreeMap.singleton (H.get acct) $
1101                         Account_Tags chart_tags
1102                 ctx <- R.getState
1103                 let jnl = context_read_journal ctx
1104                 R.setState
1105                         ctx{context_read_journal=
1106                                 jnl{journal_chart = journal_chart jnl `mappend`
1107                                          Chart
1108                                                  { chart_accounts
1109                                                  , chart_anchors
1110                                                  }
1111                                  }
1112                          }
1113         where
1114                 fields acct tags@(Tags tagm) anchors cmts =
1115                         R.choice_try
1116                          [ read_spaces1 >> read_comment >>= \c ->
1117                                 fields acct tags anchors (c:cmts)
1118                          , read_spaces1 >> read_account_tag >>= \(Account_Tag (Tag (Tag_Path p) v)) ->
1119                                 fields acct (Tags $ TreeMap.insert (flip mappend) p [v] tagm) anchors cmts
1120                          , read_spaces1 >> read_account_anchor >>= \anchor ->
1121                                 case Map.insertLookupWithKey (\_k n _o -> n) anchor acct anchors of
1122                                  (Nothing, m) -> fields acct tags m cmts
1123                                  (Just _, _) -> do
1124                                         sourcepos <- R.getPosition
1125                                         R.parserFailWith "account anchor not unique"
1126                                          (Error_Read_account_anchor_not_unique sourcepos anchor)
1127                          , read_spaces >> read_eol >>
1128                                 fields acct tags anchors cmts
1129                          , return (tags, anchors, cmts)
1130                          ]
1131
1132 -- * Read 'Journal'
1133 read_journal
1134  :: ( Consable c j
1135     , Monoid j
1136     , Stream s (R.State_Error Error_Read IO) Char
1137     )
1138  => FilePath
1139  -> ParsecT s (Context_Read c j)
1140               (R.State_Error Error_Read IO)
1141               (Journal j)
1142 read_journal filepath = (<?> "journal") $ do
1143         currentLocalTime <- liftIO $
1144                 Time.utcToLocalTime
1145                 <$> Time.getCurrentTimeZone
1146                 <*> Time.getCurrentTime
1147         let (currentLocalYear, _, _) = Time.toGregorian $ Time.localDay currentLocalTime
1148         ctx <- R.getState
1149         R.setState $ ctx{context_read_year=currentLocalYear}
1150         read_journal_rec filepath
1151
1152 read_journal_rec
1153  :: ( Consable c j
1154     , Monoid j
1155     , Stream s (R.State_Error Error_Read IO) Char
1156     )
1157  => FilePath
1158  -> ParsecT s (Context_Read c j)
1159               (R.State_Error Error_Read IO)
1160               (Journal j)
1161 read_journal_rec journal_file = do
1162         last_read_time <- liftIO H.date_now
1163         loop $
1164                 R.choice_try
1165                  [ jump_comment
1166                  , jump_directive
1167                  , jump_transaction
1168                  , jump_chart
1169                  ]
1170         journal_ <- context_read_journal <$> R.getState
1171         return $
1172                 journal_
1173                  { journal_files          = [journal_file]
1174                  , journal_includes       = List.reverse $ journal_includes journal_
1175                  , journal_last_read_time = last_read_time
1176                  }
1177         where
1178                 loop
1179                  :: Stream s m Char
1180                  => ParsecT s u m (ParsecT s u m ())
1181                  -> ParsecT s u m ()
1182                 loop r = do
1183                         R.skipMany (read_spaces >> read_eol)
1184                         void $ join r
1185                         R.skipMany (read_spaces >> read_eol)
1186                         R.try (read_spaces >> R.eof) <|> loop r
1187                 jump_comment ::
1188                  ( Stream s m Char
1189                  , u ~ Context_Read c j
1190                  , m ~ R.State_Error Error_Read IO
1191                  )
1192                  => ParsecT s u m (ParsecT s u m ())
1193                 jump_comment = do
1194                         void R.spaces
1195                         void $ R.lookAhead (R.try $ R.char char_comment_prefix)
1196                         return $ do
1197                                 _cmts <- read_comments
1198                                 {-
1199                                 R.modifyState $ \ctx ->
1200                                         let j = context_read_journal ctx in
1201                                         ctx{context_read_journal=
1202                                                 j{journal_content=
1203                                                         mcons (context_read_filter ctx) cmts $
1204                                                                 journal_content j}}
1205                                 -}
1206                                 return ()
1207                 jump_directive ::
1208                  ( Consable c j
1209                  , Monoid j
1210                  , Stream s m Char
1211                  , u ~ Context_Read c j
1212                  , m ~ R.State_Error Error_Read IO
1213                  )
1214                  => ParsecT s u m (ParsecT s u m ())
1215                 jump_directive = (<?> "directive") $ do
1216                         let choice s = R.string s >> R.skipMany1 R.spaceHorizontal
1217                         R.choice_try
1218                          [ choice "Y"        >> return read_default_year
1219                          , choice "D"        >> return read_default_unit_and_style
1220                          , choice "!include" >> return read_include
1221                          ]
1222                 jump_transaction ::
1223                  ( Consable c j
1224                  , Stream s m Char
1225                  , u ~ Context_Read c j
1226                  , m ~ R.State_Error Error_Read IO
1227                  )
1228                  => ParsecT s u m (ParsecT s u m ())
1229                 jump_transaction = do
1230                         void $ R.lookAhead $ R.try (R.many1 R.digit >> R.char char_date_ymd_sep)
1231                         return $ do
1232                                 t <- read_transaction
1233                                 R.modifyState $ \ctx ->
1234                                         let j = context_read_journal ctx in
1235                                         ctx{context_read_journal=
1236                                                 j{journal_content=
1237                                                         mcons
1238                                                          (context_read_cons ctx $
1239                                                                 Charted (journal_chart j) t)
1240                                                          (journal_content j)}}
1241                 jump_chart ::
1242                  ( Stream s m Char
1243                  , u ~ Context_Read c j
1244                  , m ~ R.State_Error Error_Read IO
1245                  )
1246                  => ParsecT s u m (ParsecT s u m ())
1247                 jump_chart =
1248                         return read_chart
1249
1250 -- * Read
1251 read_file
1252  :: (Consable c j, Monoid j)
1253  => Context_Read c j
1254  -> FilePath
1255  -> ExceptT [R.Error Error_Read] IO (Journal j)
1256 read_file ctx path =
1257         ExceptT
1258          (Exn.catch
1259                  (Right <$> Text.IO.readFile path) $
1260                  \ko -> return $ Left $
1261                          [R.Error_Custom (R.initialPos path) $
1262                                 Error_Read_reading_file path ko])
1263         >>= liftIO . R.runParserTWithError
1264          (read_journal path) ctx path
1265         >>= \x -> case x of
1266          Left  ko -> throwE $ ko
1267          Right ok -> ExceptT $ return $ Right ok