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