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