lib/Hcompta/Format/Ledger/Read.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE NamedFieldPuns #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 {-# LANGUAGE ScopedTypeVariables #-}
   5 {-# LANGUAGE TupleSections #-}
   6 {-# LANGUAGE TypeFamilies #-}
   7 module Hcompta.Format.Ledger.Read where
   8
   9 -- import           Control.Applicative ((<$>), (<*>), (<*))
  10 import           Control.Arrow ((***), first)
  11 import qualified Control.Exception as Exception
  12 import           Control.Monad (guard, liftM, join, forM, void)
  13 import           Control.Monad.IO.Class (liftIO)
  14 import           Control.Monad.Trans.Except (ExceptT(..), throwE)
  15 import qualified Data.Char
  16 import qualified Data.Either
  17 import qualified Data.List
  18 import           Data.List.NonEmpty (NonEmpty(..))
  19 import qualified Data.Map.Strict as Data.Map
  20 import           Data.Maybe (fromMaybe)
  21 import           Data.String (fromString)
  22 import qualified Data.Text as Text
  23 import qualified Data.Time.Calendar  as Time
  24 import qualified Data.Time.Clock     as Time
  25 import qualified Data.Time.LocalTime as Time
  26 import           Data.Typeable ()
  27 import qualified Text.Parsec as R hiding
  28                   ( char
  29                   , anyChar
  30                   , crlf
  31                   , newline
  32                   , noneOf
  33                   , oneOf
  34                   , satisfy
  35                   , space
  36                   , spaces
  37                   , string
  38                   , tab
  39                   )
  40 import           Text.Parsec (Stream, ParsecT, (<|>), (<?>))
  41 import qualified Text.Parsec.Pos as R
  42 import qualified Data.Text.IO as Text.IO (readFile)
  43 import qualified System.FilePath.Posix as Path
  44
  45 import qualified Hcompta.Account as Account
  46 import           Hcompta.Account (Account)
  47 import qualified Hcompta.Account.Read as Account.Read
  48 import qualified Hcompta.Balance as Balance
  49 import qualified Hcompta.Amount as Amount
  50 import qualified Hcompta.Amount.Style as Style
  51 import qualified Hcompta.Amount.Read as Amount.Read
  52 import qualified Hcompta.Amount.Unit as Unit
  53 import qualified Hcompta.Date as Date
  54 import           Hcompta.Date (Date)
  55 import qualified Hcompta.Date.Read as Date.Read
  56 import qualified Hcompta.Format.Ledger as Ledger
  57 import           Hcompta.Posting as Posting
  58 import           Hcompta.Format.Ledger
  59                   ( Comment
  60                   , Journal(..)
  61                   , Posting(..)
  62                   , Tag, Tag_Name, Tag_Value, Tag_by_Name
  63                   , Transaction(..)
  64                   )
  65 import           Hcompta.Lib.Consable (Consable(..))
  66 import           Hcompta.Lib.Regex (Regex)
  67 import qualified Hcompta.Lib.Parsec as R
  68 import qualified Hcompta.Lib.Path as Path
  69
  70 data Context f ts t
  71  =   Context
  72  { context_account_prefix :: !(Maybe Account)
  73  , context_aliases_exact :: !(Data.Map.Map Account Account)
  74  , context_aliases_joker :: ![(Account.Joker, Account)]
  75  , context_aliases_regex :: ![(Regex, Account)]
  76  , context_date :: !Date
  77  , context_filter :: !f
  78  , context_journal :: !(Journal (ts t))
  79  , context_unit_and_style :: !(Maybe (Amount.Unit, Amount.Style))
  80  , context_year :: !Date.Year
  81  } deriving (Show)
  82
  83 context
  84  :: (Show f, Consable f ts t)
  85  => f -> Journal (ts t) -> Context f ts t
  86 context flt context_journal =
  87         Context
  88          { context_account_prefix = Nothing
  89          , context_aliases_exact = Data.Map.empty
  90          , context_aliases_joker = []
  91          , context_aliases_regex = []
  92          , context_date = Date.nil
  93          , context_filter = flt
  94          , context_journal
  95          , context_unit_and_style = Nothing
  96          , context_year = Date.year Date.nil
  97          }
  98
  99 data Error
 100  =   Error_date Date.Read.Error
 101  |   Error_transaction_not_equilibrated Transaction [Balance.Unit_Sum (Balance.Posting_Amount Ledger.Posting)]
 102  |   Error_virtual_transaction_not_equilibrated Transaction [Balance.Unit_Sum (Balance.Posting_Amount Ledger.Posting)]
 103  |   Error_reading_file FilePath Exception.IOException
 104  |   Error_including_file FilePath [R.Error Error]
 105  deriving (Show)
 106
 107 -- * Directives
 108
 109 directive_alias
 110  :: (Consable f ts t, Stream s m Char)
 111  => ParsecT s (Context f ts t) m ()
 112 directive_alias = do
 113         _ <- R.string "alias"
 114         R.skipMany1 $ R.space_horizontal
 115         pattern <- Account.Read.pattern
 116         R.skipMany $ R.space_horizontal
 117         _ <- R.char '='
 118         R.skipMany $ R.space_horizontal
 119         repl <- Account.Read.account
 120         R.skipMany $ R.space_horizontal
 121         case pattern of
 122          Account.Pattern_Exact acct -> R.modifyState $ \ctx -> ctx{context_aliases_exact=
 123                 Data.Map.insert acct repl $ context_aliases_exact ctx}
 124          Account.Pattern_Joker jokr -> R.modifyState $ \ctx -> ctx{context_aliases_joker=
 125                 (jokr, repl):context_aliases_joker ctx}
 126          Account.Pattern_Regex regx -> R.modifyState $ \ctx -> ctx{context_aliases_regex=
 127                 (regx, repl):context_aliases_regex ctx}
 128         return ()
 129
 130 -- * Read 'Comment'
 131
 132 comment_begin :: Char
 133 comment_begin = ';'
 134
 135 comment :: Stream s m Char => ParsecT s u m Comment
 136 comment = (do
 137         _ <- R.char comment_begin
 138         fromString <$> do
 139         R.manyTill R.anyChar (R.lookAhead R.new_line <|> R.eof)
 140         ) <?> "comment"
 141
 142 comments :: Stream s m Char => ParsecT s u m [Comment]
 143 comments = (do
 144         R.try $ do
 145                 _ <- R.spaces
 146                 R.many1_separated comment (R.new_line >> R.skipMany R.space_horizontal)
 147         <|> return []
 148         ) <?> "comments"
 149
 150 -- * Read 'Tag'
 151
 152 tag_value_sep :: Char
 153 tag_value_sep = ':'
 154
 155 tag_sep :: Char
 156 tag_sep = ','
 157
 158 -- | Read a 'Tag'.
 159 tag :: Stream s m Char => ParsecT s u m Tag
 160 tag = (do
 161         n <- tag_name
 162         _ <- R.char tag_value_sep
 163         v <- tag_value
 164         return (n, v)
 165         ) <?> "tag"
 166
 167 tag_name :: Stream s m Char => ParsecT s u m Tag_Name
 168 tag_name = do
 169         fromString <$> do
 170         R.many1 $ R.satisfy (\c -> c /= tag_value_sep && not (Data.Char.isSpace c))
 171
 172 tag_value :: Stream s m Char => ParsecT s u m Tag_Value
 173 tag_value = do
 174         fromString <$> do
 175         R.manyTill R.anyChar $ do
 176                 R.lookAhead $ do
 177                         R.try (R.char tag_sep >> R.many R.space_horizontal >> tag_name >> void (R.char tag_value_sep))
 178                         <|> R.try R.new_line
 179                         <|> R.eof
 180
 181 tags :: Stream s m Char => ParsecT s u m Tag_by_Name
 182 tags = do
 183         Ledger.tag_by_Name <$> do
 184                 R.many_separated tag $ do
 185                         _ <- R.char tag_sep
 186                         R.skipMany $ R.space_horizontal
 187                         return ()
 188
 189 not_tag :: Stream s m Char => ParsecT s u m ()
 190 not_tag = do
 191         R.skipMany $ R.try $ do
 192                 R.skipMany $ R.satisfy
 193                  (\c -> c /= tag_value_sep
 194                          && not (Data.Char.isSpace c))
 195                 R.space_horizontal
 196
 197 -- * Read 'Posting'
 198
 199 posting
 200  :: (Consable f ts t, Stream s (R.Error_State Error m) Char, Monad m)
 201  => ParsecT s (Context f ts t) (R.Error_State Error m) (Posting, Posting.Posting_Type)
 202 posting = (do
 203         ctx <- R.getState
 204         sourcepos <- R.getPosition
 205         R.skipMany1 $ R.space_horizontal
 206         status_ <- status
 207         R.skipMany $ R.space_horizontal
 208         acct <- Account.Read.account
 209         let (type_, account_) = posting_type acct
 210         amounts_ <-
 211                 R.choice_try
 212                  [ do
 213                         (void R.tab <|> void (R.count 2 R.space_horizontal))
 214                         R.skipMany $ R.space_horizontal
 215                         maybe id (\(u, s) ->
 216                                 if u == Unit.nil then id
 217                                 else
 218                                         Data.Map.adjust (\a ->
 219                                                 a{ Amount.style = s{Style.precision = Style.precision $ Amount.style a}
 220                                                  , Amount.unit  = u })
 221                                          Unit.nil)
 222                          (context_unit_and_style ctx) .
 223                          Amount.from_List <$> do
 224                                 R.many_separated Amount.Read.amount $ do
 225                                         R.skipMany $ R.space_horizontal
 226                                         _ <- R.char amount_sep
 227                                         R.skipMany $ R.space_horizontal
 228                                         return ()
 229                  , return Data.Map.empty
 230                  ] <?> "amounts"
 231         R.skipMany $ R.space_horizontal
 232         -- TODO: balance assertion
 233         -- TODO: conversion
 234         comments_ <- comments
 235         let tags_ = tags_of_comments comments_
 236         dates_ <-
 237                 case Data.Map.lookup "date" tags_ of
 238                  Nothing -> return []
 239                  Just dates -> do
 240                         let date2s = Data.Map.lookup "date2" tags_ -- NOTE: support hledger's date2
 241                         do
 242                         forM (dates ++ fromMaybe [] date2s) $ \s ->
 243                                 R.runParserT_with_Error_fail "tag date" id
 244                                  (Date.Read.date Error_date (Just $ context_year ctx) <* R.eof) ()
 245                                  (Text.unpack s) s
 246                         >>= \dates_ -> case (dates, date2s) of -- NOTE: put hledger's date2 at least in second position
 247                          ([], Just (_:_)) ->
 248                                 return $ context_date ctx:dates_
 249                          _ -> return $ dates_
 250         return (Posting
 251          { posting_account=account_
 252          , posting_amounts=amounts_
 253          , posting_comments=comments_
 254          , posting_dates=dates_
 255          , posting_sourcepos=sourcepos
 256          , posting_status=status_
 257          , posting_tags=tags_
 258          }, type_)
 259         ) <?> "posting"
 260
 261 amount_sep :: Char
 262 amount_sep = '+'
 263
 264 tags_of_comments :: [Comment] -> Tag_by_Name
 265 tags_of_comments =
 266         Data.Map.unionsWith (++)
 267         . Data.List.map
 268          ( Data.Either.either (const Data.Map.empty) id
 269          . R.runParser (not_tag >> tags <* R.eof) () "" )
 270
 271 status :: Stream s m Char => ParsecT s u m Ledger.Status
 272 status = (do
 273         ( R.try $ do
 274                 R.skipMany $ R.space_horizontal
 275                 _ <- (R.char '*' <|> R.char '!')
 276                 return True )
 277         <|> return False
 278         ) <?> "status"
 279
 280 -- | Return the 'Posting_Type' and stripped 'Account' of the given 'Account'.
 281 posting_type :: Account -> (Posting_Type, Account)
 282 posting_type acct =
 283         fromMaybe (Posting_Type_Regular, acct) $ do
 284                 case acct of
 285                  name:|[] ->
 286                         case Text.stripPrefix virtual_begin name of
 287                          Just name' -> do
 288                                 name'' <- liftM Text.strip $ Text.stripSuffix virtual_end name'
 289                                 guard $ not $ Text.null name''
 290                                 Just (Posting_Type_Virtual, name'':|[])
 291                          Nothing -> do
 292                                 name' <- liftM Text.strip $
 293                                             Text.stripPrefix virtual_balanced_begin name
 294                                         >>= Text.stripSuffix virtual_balanced_end
 295                                 guard $ not $ Text.null name'
 296                                 Just (Posting_Type_Virtual_Balanced, name':|[])
 297                  first_name:|acct' -> do
 298                         let rev_acct' = Data.List.reverse acct'
 299                         let last_name = Data.List.head rev_acct'
 300                         case liftM Text.stripStart $
 301                                 Text.stripPrefix virtual_begin first_name of
 302                          Just first_name' -> do
 303                                 last_name' <- liftM Text.stripEnd $
 304                                         Text.stripSuffix virtual_end last_name
 305                                 guard $ not $ Text.null first_name'
 306                                 guard $ not $ Text.null last_name'
 307                                 Just $
 308                                         ( Posting_Type_Virtual
 309                                         , first_name':|
 310                                                 Data.List.reverse (last_name':Data.List.tail rev_acct')
 311                                         )
 312                          Nothing -> do
 313                                 first_name' <- liftM Text.stripStart $
 314                                         Text.stripPrefix virtual_balanced_begin first_name
 315                                 last_name'  <- liftM Text.stripEnd $
 316                                         Text.stripSuffix virtual_balanced_end last_name
 317                                 guard $ not $ Text.null first_name'
 318                                 guard $ not $ Text.null last_name'
 319                                 Just $
 320                                         ( Posting_Type_Virtual_Balanced
 321                                         , first_name':|
 322                                                 Data.List.reverse (last_name':Data.List.tail rev_acct')
 323                                         )
 324         where
 325                 virtual_begin          = Text.singleton posting_type_virtual_begin
 326                 virtual_end            = Text.singleton posting_type_virtual_end
 327                 virtual_balanced_begin = Text.singleton posting_type_virtual_balanced_begin
 328                 virtual_balanced_end   = Text.singleton posting_type_virtual_balanced_end
 329
 330 posting_type_virtual_begin :: Char
 331 posting_type_virtual_begin = '('
 332 posting_type_virtual_balanced_begin :: Char
 333 posting_type_virtual_balanced_begin = '['
 334 posting_type_virtual_end :: Char
 335 posting_type_virtual_end = ')'
 336 posting_type_virtual_balanced_end :: Char
 337 posting_type_virtual_balanced_end = ']'
 338
 339 -- * Read 'Transaction'
 340
 341 transaction
 342  :: (Consable f ts t, Stream s (R.Error_State Error m) Char, Monad m)
 343  => ParsecT s (Context f ts t) (R.Error_State Error m) Transaction
 344 transaction = (do
 345         ctx <- R.getState
 346         transaction_sourcepos <- R.getPosition
 347         transaction_comments_before <-
 348                 comments
 349                 >>= \x -> case x of
 350                  [] -> return []
 351                  _  -> return x <* R.new_line
 352         date_ <- Date.Read.date Error_date (Just $ context_year ctx)
 353         dates_ <-
 354                 R.option [] $ R.try $ do
 355                         R.skipMany $ R.space_horizontal
 356                         _ <- R.char date_sep
 357                         R.skipMany $ R.space_horizontal
 358                         R.many_separated
 359                          (Date.Read.date Error_date (Just $ context_year ctx)) $
 360                                 R.try $ do
 361                                         R.many $ R.space_horizontal
 362                                         >> R.char date_sep
 363                                         >> (R.many $ R.space_horizontal)
 364         let transaction_dates = (date_, dates_)
 365         R.skipMany $ R.space_horizontal
 366         transaction_status <- status
 367         transaction_code <- R.option "" $ R.try code
 368         R.skipMany $ R.space_horizontal
 369         transaction_description <- description
 370         R.skipMany $ R.space_horizontal
 371         transaction_comments_after <- comments
 372         let transaction_tags =
 373                 Data.Map.unionWith (++)
 374                  (tags_of_comments transaction_comments_before)
 375                  (tags_of_comments transaction_comments_after)
 376         R.new_line
 377         (postings_unchecked, postings_not_regular) <-
 378                 first (Ledger.posting_by_Account . Data.List.map fst) .
 379                 Data.List.partition ((Posting.Posting_Type_Regular ==) . snd) <$>
 380                 R.many1_separated posting R.new_line
 381         let (transaction_virtual_postings, balanced_virtual_postings_unchecked) =
 382                 join (***) (Ledger.posting_by_Account . Data.List.map fst) $
 383                 Data.List.partition ((Posting.Posting_Type_Virtual ==) . snd)
 384                  postings_not_regular
 385         let tr_unchecked =
 386                 Transaction
 387                  { transaction_code
 388                  , transaction_comments_before
 389                  , transaction_comments_after
 390                  , transaction_dates
 391                  , transaction_description
 392                  , transaction_postings=postings_unchecked
 393                  , transaction_virtual_postings
 394                  , transaction_balanced_virtual_postings=balanced_virtual_postings_unchecked
 395                  , transaction_sourcepos
 396                  , transaction_status
 397                  , transaction_tags
 398                  }
 399         transaction_postings <-
 400                 case Balance.infer_equilibrium postings_unchecked of
 401                  (_, Left ko) -> R.fail_with "transaction infer_equilibrium"
 402                                              (Error_transaction_not_equilibrated tr_unchecked ko)
 403                  (_bal, Right ok) -> return ok
 404         transaction_balanced_virtual_postings <-
 405                 case Balance.infer_equilibrium balanced_virtual_postings_unchecked of
 406                  (_, Left ko) -> R.fail_with "transaction infer_equilibrium"
 407                                              (Error_virtual_transaction_not_equilibrated tr_unchecked ko)
 408                  (_bal, Right ok) -> return ok
 409         return $
 410                 tr_unchecked
 411                  { transaction_postings
 412                  , transaction_balanced_virtual_postings
 413                  }
 414         ) <?> "transaction"
 415
 416 date_sep :: Char
 417 date_sep = '='
 418
 419 code :: (Consable f ts t, Stream s m Char)
 420  => ParsecT s (Context f ts t) m Ledger.Code
 421 code = (do
 422         fromString <$> do
 423         R.skipMany $ R.space_horizontal
 424         R.between (R.char '(') (R.char ')') $
 425                 R.many $ R.satisfy (\c -> c /= ')' && not (R.is_space_horizontal c))
 426         ) <?> "code"
 427
 428 description :: Stream s m Char => ParsecT s u m Ledger.Description
 429 description = (do
 430         fromString <$> do
 431         R.many $ R.try description_char
 432         ) <?> "description"
 433         where
 434                 description_char :: Stream s m Char => ParsecT s u m Char
 435                 description_char = do
 436                         c <- R.anyChar
 437                         case c of
 438                          _ | c == comment_begin -> R.parserZero
 439                          _ | R.is_space_horizontal c -> return c <* (R.lookAhead $ R.try $ description_char)
 440                          _ | not (Data.Char.isSpace c) -> return c
 441                          _ -> R.parserZero
 442
 443 -- * Read directives
 444
 445 default_year
 446  :: (Consable f ts t, Stream s m Char)
 447  => ParsecT s (Context f ts t) m ()
 448 default_year = (do
 449         year <- R.integer_of_digits 10 <$> R.many1 R.digit
 450         R.skipMany R.space_horizontal >> R.new_line
 451         context_ <- R.getState
 452         R.setState context_{context_year=year}
 453         ) <?> "default year"
 454
 455 default_unit_and_style
 456  :: (Consable f ts t, Stream s m Char)
 457  => ParsecT s (Context f ts t) m ()
 458 default_unit_and_style = (do
 459         amount_ <- Amount.Read.amount
 460         R.skipMany R.space_horizontal >> R.new_line
 461         context_ <- R.getState
 462         R.setState context_{context_unit_and_style =
 463                 Just $
 464                  ( Amount.unit  amount_
 465                  , Amount.style amount_ )}
 466         ) <?> "default unit and style"
 467
 468 include ::
 469  ( Consable f ts Transaction
 470  , Show f
 471  , Show (ts Transaction)
 472  , Stream s (R.Error_State Error IO) Char
 473  )
 474  => ParsecT s (Context f ts Transaction) (R.Error_State Error IO) ()
 475 include = (do
 476         sourcepos <- R.getPosition
 477         filename <- R.manyTill R.anyChar (R.lookAhead R.new_line <|> R.eof)
 478         context_ <- R.getState
 479         let journal_ = context_journal context_
 480         let cwd = Path.takeDirectory (R.sourceName sourcepos)
 481         file_path <- liftIO $ Path.abs cwd filename
 482         content <- do
 483                 join $ liftIO $ Exception.catch
 484                  (liftM return $ readFile file_path)
 485                  (return . R.fail_with "include reading" . Error_reading_file file_path)
 486         (journal_included, context_included) <- do
 487                 liftIO $
 488                         R.runParserT_with_Error (R.and_state $ journal_rec file_path)
 489                          context_{context_journal = Ledger.journal}
 490                          file_path content
 491                 >>= \x -> case x of
 492                  Right ok -> return ok
 493                  Left  ko -> R.fail_with "include parsing" (Error_including_file file_path ko)
 494         R.setState $
 495                 context_included{context_journal=
 496                         journal_{journal_includes=
 497                                 journal_included{journal_file=file_path}
 498                                 : journal_includes journal_}}
 499         ) <?> "include"
 500
 501 -- * Read 'Journal'
 502
 503 journal ::
 504  ( Consable f ts Transaction
 505  , Show f
 506  , Show (ts Transaction)
 507  , Stream s (R.Error_State Error IO) Char
 508  )
 509  => FilePath
 510  -> ParsecT s (Context f ts Transaction) (R.Error_State Error IO) (Journal (ts Transaction))
 511 journal file_ = (do
 512         currentLocalTime <- liftIO $
 513                 Time.utcToLocalTime
 514                 <$> Time.getCurrentTimeZone
 515                 <*> Time.getCurrentTime
 516         let (currentLocalYear, _, _) = Time.toGregorian $ Time.localDay currentLocalTime
 517         ctx <- R.getState
 518         R.setState $ ctx{context_year=currentLocalYear}
 519         journal_rec file_
 520         ) <?> "journal"
 521
 522 journal_rec ::
 523  ( Consable f ts Transaction
 524  , Show f
 525  , Show (ts Transaction)
 526  , Stream s (R.Error_State Error IO) Char
 527  )
 528  => FilePath
 529  -> ParsecT s (Context f ts Transaction) (R.Error_State Error IO) (Journal (ts Transaction))
 530 journal_rec file_ = do
 531         last_read_time <- liftIO Date.now
 532         R.skipMany $ do
 533                 R.choice_try
 534                  [ R.skipMany1 R.space
 535                  , (do (R.choice_try
 536                          [ R.string "Y"        >> return default_year
 537                          , R.string "D"        >> return default_unit_and_style
 538                          , R.string "!include" >> return include
 539                          ] <?> "directive")
 540                                 >>= \r -> R.skipMany1 R.space_horizontal >> r)
 541                  , ((do
 542                                 t <- transaction
 543                                 ctx <- R.getState
 544                                 let j = context_journal ctx
 545                                 R.setState $
 546                                         ctx{context_journal=
 547                                                 j{journal_transactions=
 548                                                         mcons (context_filter ctx) t $
 549                                                                 journal_transactions j}}
 550                                 R.new_line <|> R.eof))
 551                  , R.try (void $ comment)
 552                  ]
 553         R.eof
 554         journal_ <- context_journal <$> R.getState
 555         return $
 556                 journal_
 557                  { journal_file = file_
 558                  , journal_last_read_time = last_read_time
 559                  , journal_includes = reverse $ journal_includes journal_
 560                  }
 561
 562 -- ** Read 'Journal' from a file
 563
 564 file
 565  ::
 566  ( Consable f ts Transaction
 567  , Show f
 568  , Show (ts Transaction)
 569  )
 570  => Context f ts Transaction
 571  -> FilePath
 572  -> ExceptT [R.Error Error] IO (Journal (ts Transaction))
 573 file ctx path = do
 574         ExceptT $
 575                 Exception.catch
 576                  (liftM Right $ Text.IO.readFile path) $
 577                  \ko -> return $ Left $
 578                          [ R.Error_Custom (R.initialPos path) $ Error_reading_file path ko ]
 579         >>= liftIO . R.runParserT_with_Error (journal path) ctx path
 580         >>= \x -> case x of
 581          Left  ko -> throwE $ ko
 582          Right ok -> ExceptT $ return $ Right ok