{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
module Hcompta.Format.Ledger.Read where
-import Control.Applicative ((<*))
-import qualified Control.Exception as Exn
-import Control.Monad
--- import Control.Monad.Error
-import Data.Data
-import Data.List
--- import Data.List.Split (wordsBy)
-import qualified Data.Map
-import Data.Maybe
-import Data.Typeable ()
-import Safe (headDef, lastDef)
-import Text.Printf
-import qualified Data.Time.Clock as Time
+import Control.Applicative ((<$>), (<*>), (<*))
+import qualified Control.Exception as Exception
+import Control.Arrow ((***))
+import Control.Monad (guard, join, liftM)
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Trans.Except (ExceptT(..), throwE)
+import Control.Monad.Trans.Class (lift)
+import qualified Data.Char
+import qualified Data.Either
+import qualified Data.List
+import Data.List.NonEmpty (NonEmpty(..))
+import qualified Data.Map.Strict as Data.Map
+import Data.Maybe (fromMaybe)
+import Data.String (fromString)
import qualified Data.Time.Calendar as Time
+import qualified Data.Time.Clock as Time
import qualified Data.Time.LocalTime as Time
-import Text.Parsec hiding (parse)
-
-import qualified Hcompta.Model as Model
-import qualified Hcompta.Model.Account as Account
-import Hcompta.Model.Account (Account)
-import qualified Hcompta.Model.Amount as Amount
-import Hcompta.Model.Amount (Amount)
-import qualified Hcompta.Model.Date as Date
-import Hcompta.Format.Ledger.Journal as Journal
+import Data.Typeable ()
+import qualified Text.Parsec as R hiding
+ ( char
+ , anyChar
+ , crlf
+ , newline
+ , noneOf
+ , oneOf
+ , satisfy
+ , space
+ , spaces
+ , string
+ )
+import Text.Parsec (Stream, ParsecT, (<|>), (<?>))
+import qualified Text.Parsec.Pos as R
+import qualified Data.Text.IO as Text.IO (readFile)
+import qualified Data.Text as Text
+import qualified System.FilePath.Posix as Path
+
+import qualified Hcompta.Balance as Balance
+import qualified Hcompta.Account as Account
+import Hcompta.Account (Account)
+import qualified Hcompta.Amount as Amount
+import qualified Hcompta.Amount.Style as Style
+import qualified Hcompta.Amount.Read as Amount.Read
+import qualified Hcompta.Amount.Unit as Unit
+import qualified Hcompta.Date as Date
+import Hcompta.Date (Date)
+import qualified Hcompta.Date.Read as Date.Read
+import qualified Hcompta.Format.Ledger as Ledger
+import Hcompta.Format.Ledger
+ ( Comment
+ , Journal(..)
+ , Posting(..), Posting_Type(..)
+ , Tag, Tag_Name, Tag_Value, Tag_by_Name
+ , Transaction(..)
+ )
+import qualified Hcompta.Lib.Regex as Regex
+import Hcompta.Lib.Regex (Regex)
+import qualified Hcompta.Lib.Parsec as R
+import qualified Hcompta.Lib.Path as Path
data Context
= Context
- { account_prefix :: !Account
- --, context_aliases :: ![AccountAlias]
- , unit_and_style :: !(Maybe (Amount.Unit, Amount.Style))
- , journal :: !Journal
- , year :: !Date.Year
- } deriving (Data, Eq, Read, Show, Typeable)
-
-nil :: Context
-nil =
+ { context_account_prefix :: !(Maybe Account)
+ , context_aliases_exact :: !(Data.Map.Map Account Account)
+ , context_aliases_joker :: ![(Account.Joker, Account)]
+ , context_aliases_regex :: ![(Regex, Account)]
+ , context_date :: !Date
+ , context_unit_and_style :: !(Maybe (Amount.Unit, Amount.Style))
+ , context_journal :: !Journal
+ , context_year :: !Date.Year
+ } deriving (Show)
+
+nil_Context :: Context
+nil_Context =
Context
- { account_prefix = []
- , unit_and_style = Nothing
- , journal = Journal.nil
- , year = (\(year, _ , _) -> year) $
+ { context_account_prefix = Nothing
+ , context_aliases_exact = Data.Map.empty
+ , context_aliases_joker = []
+ , context_aliases_regex = []
+ , context_date = Date.nil
+ , context_unit_and_style = Nothing
+ , context_journal = Ledger.journal
+ , context_year = (\(year, _ , _) -> year) $
Time.toGregorian $ Time.utctDay $
- Journal.last_read_time Journal.nil
+ journal_last_read_time Ledger.journal
}
-
-{-
-reader :: Reader
-reader = Reader format detect parse
-
-format :: String
-format = "ledger"
-
-detect :: FilePath -> String -> Bool
-detect file s
- | file /= "-" = takeExtension file `elem` ['.':format, ".j"] -- from a file: yes if the extension is .journal or .j
- -- from stdin: yes if we can see something that looks like a journal entry (digits in column 0 with the next line indented)
- | otherwise = regexMatches "^[0-9]+.*\n[ \t]+" s
-
-parse :: Maybe FilePath -> Bool -> FilePath -> String -> ErrorT String IO Journal
-parse _ = parseJournal journal
-
-parseJournal
- :: ParsecT [Char] Context (ErrorT String IO) Context
- -> Bool -> FilePath -> String -> ErrorT String IO Journal
-parseJournal parser filePath fileData = do
- currentUTC <- liftIO Time.getCurrentTime
- currentTimeZone <- liftIO Time.getCurrentTimeZone
- let currentLocalTime = Time.utcToLocalTime currentTimeZone currentUTC
- let (currentLocalYear, _, _) = Time.toGregorian $ Time.localDay currentLocalTime
- parserResult <- runParserT parser
- contextNull{context_year=Just currentLocalYear}
- filePath fileData
- case parserResult of
- Left error -> throwError $ show error
- Right context -> do
- let journal = context_journal context
- journalBalanceTransactions $
- journal
- { journal_unit_styles=
- , journal_file=filePath
- , journal_includes=reverse $ journal_includes journal
- -- , journal_historical_prices=reverse $ journal_historical_prices journal
- , journal_last_read_time=currentUTC
- , journal_transactions=reverse $ journal_transactions journal
- -- , journal_transaction_modifiers=reverse $ journal_transaction_modifiers journal
- -- , journal_transaction_periodics=reverse $ journal_transaction_periodics journal
- }
-
--- | Fill in any missing amounts and check that all journal transactions
--- balance, or return an error message. This is done after parsing all
--- amounts and working out the canonical commodities, since balancing
--- depends on display precision. Reports only the first error encountered.
-journalBalanceTransactions :: Journal -> Either String Journal
-journalBalanceTransactions journal =
- let transactions = journal_transactions journal
- let unit_and_style = journal_unit_styles journal
- case sequence $ map balance transactions of
- Right ts' -> Right journal{journal_transactions=map txnTieKnot ts'}
- Left e -> Left e
- where balance = balanceTransaction (Just unit_and_style)
-
--- | Convert all the journal's posting amounts (not price amounts) to
--- their canonical display settings. Ie, all amounts in a given
--- unit will use (a) the display settings of the first, and (b)
--- the greatest precision, of the posting amounts in that unit.
-journalCanonicaliseAmounts :: Journal -> Journal
-journalCanonicaliseAmounts j@Journal{journal_transactions=ts} =
- j''
- where
- j'' = j'{journal_transactions=map fixtransaction ts}
- j' = j{context_unit_and_style = canonicalStyles $ dbgAt 8 "journalAmounts" $ journalAmounts j}
- fixtransaction t@Transaction{tpostings=ps} = t{tpostings=map fixposting ps}
- fixposting p@Posting{pamount=a} = p{pamount=fixmixedamount a}
- fixmixedamount (Mixed as) = Mixed $ map fixamount as
- fixamount a@Amount{aunit=c} = a{astyle=journalCommodityStyle j' c}
-
--- | Given a list of amounts in parse order, build a map from commodities
--- to canonical display styles for amounts in that unit.
-canonicalStyles :: [Amount] -> M.Map Amount.Unit Amount.Style
-canonicalStyles amts =
- M.fromList commstyles
+data Error
+ = Error_date Date.Read.Error
+ | Error_transaction_not_equilibrated Transaction [Balance.Unit_Sum (Balance.Posting_Amount Ledger.Posting)]
+ | Error_virtual_transaction_not_equilibrated Transaction [Balance.Unit_Sum (Balance.Posting_Amount Ledger.Posting)]
+ | Error_reading_file FilePath Exception.IOException
+ | Error_including_file FilePath [R.Error Error]
+ deriving (Show)
+
+-- * Read 'Account'
+
+account_name_sep :: Char
+account_name_sep = ':'
+
+-- | Read an 'Account'.
+account :: Stream s m Char => ParsecT s u m Account
+account = do
+ R.notFollowedBy $ R.space_horizontal
+ Account.from_List <$> do
+ R.many1_separated account_name $ R.char account_name_sep
+
+-- | Read an Account.'Account.Name'.
+account_name :: Stream s m Char => ParsecT s u m Account.Name
+account_name = do
+ fromString <$> do
+ R.many1 $ R.try account_name_char
where
- samecomm = \a1 a2 -> aunit a1 == aunit a2
- commamts = [(aunit $ head as, as) | as <- groupBy samecomm $ sortBy (comparing aunit) amts]
- commstyles = [(c, canonicalStyleFrom $ map astyle as) | (c,as) <- commamts]
-
--- | Get all this journal's component amounts, roughly in the order parsed.
-journalAmounts :: Journal -> [Amount]
-journalAmounts =
- concatMap flatten . journalMixedAmounts
- where flatten (Mixed as) = as
-
-amountStyleFromCommodity :: Context -> Amount.Unit -> Amount.Style
-amountStyleFromCommodity context unit =
- Data.Map.findWithDefault
- (context_unit_and_style context)
- unit $
- journal_unit_styles $
- context_journal context
-
-
-
-
-setYear :: Stream [Char] m Char => Integer -> ParsecT [Char] Context m ()
-setYear y = modifyState (\ctx -> ctx{context_year=Just y})
-
-getYear :: Stream [Char] m Char => ParsecT s Context m (Maybe Integer)
-getYear = liftM context_year getState
-
-setCoA :: Stream [Char] m Char => CoA -> ParsecT [Char] Context m ()
-setCoA coa = modifyState (\ctx -> ctx{ctxCoA=coa})
-
-getCoA :: Stream [Char] m Char => ParsecT [Char] Context m CoA
-getCoA = liftM ctxCoA getState
-
-setDefaultCommodityAndStyle :: Stream [Char] m Char => (Amount.Unit,Amount.Style) -> ParsecT [Char] Context m ()
-setDefaultCommodityAndStyle cs = modifyState (\ctx -> ctx{context_unit_and_style=Just cs})
-
-getDefaultCommodityAndStyle :: Stream [Char] m Char => ParsecT [Char] Context m (Maybe (Amount.Unit,Amount.Style))
-getDefaultCommodityAndStyle = context_unit_and_style `fmap` getState
-
-pushParentAccount :: Stream [Char] m Char => String -> ParsecT [Char] Context m ()
-pushParentAccount parent = modifyState addParentAccount
- where addParentAccount ctx0 = ctx0 { context_account_prefix = parent : context_account_prefix ctx0 }
-
-popParentAccount :: Stream [Char] m Char => ParsecT [Char] Context m ()
-popParentAccount = do
- ctx0 <- getState
- case context_account_prefix ctx0 of
- [] -> unexpected "End of account block with no beginning"
- (_:rest) -> setState $ ctx0 { context_account_prefix = rest }
-
-getParentAccount :: Stream [Char] m Char => ParsecT [Char] Context m String
-getParentAccount = liftM (concatAccountNames . reverse . context_account_prefix) getState
-
-addAccountAlias :: Stream [Char] m Char => AccountAlias -> ParsecT [Char] Context m ()
-addAccountAlias a = modifyState (\(ctx@Ctx{..}) -> ctx{context_aliases=a:context_aliases})
-
-getAccountAliases :: Stream [Char] m Char => ParsecT [Char] Context m [AccountAlias]
-getAccountAliases = liftM context_aliases getState
-
-clearAccountAliases :: Stream [Char] m Char => ParsecT [Char] Context m ()
-clearAccountAliases = modifyState (\(ctx@Ctx{..}) -> ctx{context_aliases=[]})
-
--- parsers
-
-parseJournal :: ParsecT [Char] Context (ErrorT String IO) (JournalUpdate, Context)
-parseJournal = do
- journalUpdates <- many journalItem
- eof
- finalContext <- getState
- return $ (combineJournalUpdates journalUpdates, finalContext)
- where
- -- As all journal line types can be distinguished by the first
- -- character, excepting transactions versus empty (blank or
- -- comment-only) lines, can use choice w/o try
- journalItem =
- choice
- [ directive
- , liftM (return . addTransaction) parseTransaction
- , liftM (return . addModifierTransaction) parseTransactionModifier
- , liftM (return . addPeriodicTransaction) periodictransaction
- , liftM (return . addHistoricalPrice) historicalpricedirective
- , emptyorcommentlinep >> return (return id)
- , multilinecommentp >> return (return id)
- ] <?> "journal transaction or directive"
-
-parseDirective :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
-parseDirective = do
- optional $ char '!'
- choice'
- [ parseDirectiveInclude
- , parseDirectiveAlias
- , parseDirectiveEndAlias
- , parseDirectiveAccount
- , parseDirectiveEnd
- , parseDirectiveTag
- , parseDirectiveEndTag
- , parseDirectiveYear
- , parseDirectiveCommodity
- , parseDirectiveCommodityConversion
- , parseDirectiveIgnoredPriceCommodity
+ account_name_char :: Stream s m Char => ParsecT s u m Char
+ account_name_char = do
+ c <- R.anyChar
+ case c of
+ _ | c == comment_begin -> R.parserZero
+ _ | c == account_name_sep -> R.parserZero
+ _ | R.is_space_horizontal c -> do
+ _ <- R.notFollowedBy $ R.space_horizontal
+ return c <* (R.lookAhead $ R.try $
+ ( R.try (R.char account_name_sep)
+ <|> account_name_char
+ ))
+ _ | not (Data.Char.isSpace c) -> return c
+ _ -> R.parserZero
+
+-- | Read an Account.'Account.Joker_Name'.
+account_joker_name :: Stream s m Char => ParsecT s u m Account.Joker_Name
+account_joker_name = do
+ n <- R.option Nothing $ (Just <$> account_name)
+ case n of
+ Nothing -> R.char account_name_sep >> (return $ Account.Joker_Any)
+ Just n' -> return $ Account.Joker_Name n'
+
+-- | Read an Account.'Account.Joker'.
+account_joker :: Stream s m Char => ParsecT s u m Account.Joker
+account_joker = do
+ R.notFollowedBy $ R.space_horizontal
+ R.many1_separated account_joker_name $ R.char account_name_sep
+
+-- | Read a 'Regex'.
+account_regex :: Stream s m Char => ParsecT s u m Regex
+account_regex = do
+ re <- R.many1 $ R.satisfy (not . R.is_space_horizontal)
+ Regex.of_StringM re
+
+-- | Read an Account.'Account.Filter'.
+account_pattern :: Stream s m Char => ParsecT s u m Account.Pattern
+account_pattern = do
+ R.choice_try
+ [ Account.Pattern_Exact <$> (R.char '=' >> account)
+ , Account.Pattern_Joker <$> (R.char '*' >> account_joker)
+ , Account.Pattern_Regex <$> (R.option '~' (R.char '~') >> account_regex)
]
- <?> "directive"
-
-parseDirectiveInclude :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
-parseDirectiveInclude = do
- string "include"
- many1 spacenonewline
- filename <- restofline
- outerState <- getState
- outerPos <- getPosition
- let curdir = takeDirectory (sourceName outerPos)
- let (u::ErrorT String IO (Journal -> Journal, Context)) = do
- filepath <- expandPath curdir filename
- txt <- readFileOrError outerPos filepath
- let inIncluded = show outerPos ++ " in included file " ++ show filename ++ ":\n"
- r <- runParserT parseJournal outerState filepath txt
- case r of
- Right (ju, ctx) -> do
- u <- combineJournalUpdates [ return $ journalAddFile (filepath,txt)
- , ju
- ] `catchError` (throwError . (inIncluded ++))
- return (u, ctx)
- Left err -> throwError $ inIncluded ++ show err
- where readFileOrError pos fp =
- ErrorT $ liftM Right (readFile' fp) `Exn.catch`
- \e -> return $ Left $ printf "%s reading %s:\n%s" (show pos) fp (show (e::Exn.IOException))
- r <- liftIO $ runErrorT u
- case r of
- Left err -> return $ throwError err
- Right (ju, ctx) -> do
- setCoA (ctxCoA ctx)
- return $ ErrorT $ return $ Right ju
-
-journalAddFile :: (FilePath,String) -> Journal -> Journal
-journalAddFile f j@Journal{journal_files=fs} = j{journal_files=fs++[f]}
- -- NOTE: first encountered file to left, to avoid a reverse
-
-parseDirectiveAccount :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
-parseDirectiveAccount = do
- string "account"
- many1 spacenonewline
- parent <- parseAccountName
- newline
- pushParentAccount parent
- -- return $ return id
- return $ ErrorT $ return $ Right id
-
-parseDirectiveEnd :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
-parseDirectiveEnd = do
- string "end"
- popParentAccount
- -- return (return id)
- return $ ErrorT $ return $ Right id
-
-parseDirectiveAlias :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
-parseDirectiveAlias = do
- string "alias"
- many1 spacenonewline
- orig <- many1 $ noneOf "="
- char '='
- alias <- restofline
- addAccountAlias (accountNameWithoutPostingType $ strip orig
- ,accountNameWithoutPostingType $ strip alias)
- return $ return id
-
-parseDirectiveEndAlias :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
-parseDirectiveEndAlias = do
- string "end aliases"
- clearAccountAliases
- return (return id)
-
-parseDirectiveTag :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
-parseDirectiveTag = do
- string "tag" <?> "tag directive"
- many1 spacenonewline
- _ <- many1 nonspace
- restofline
- return $ return id
-
-parseDirectiveEndTag :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
-parseDirectiveEndTag = do
- (string "end tag" <|> string "pop") <?> "end tag or pop directive"
- restofline
- return $ return id
-
-parseDirectiveYear :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
-parseDirectiveYear = do
- char 'Y' <?> "default year"
- many spacenonewline
- y <- many1 digit
- let y' = read y
- failIfInvalidYear y
- setYear y'
- return $ return id
-
-parseDirectiveCommodity :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
-parseDirectiveCommodity = do
- char 'D' <?> "default unit"
- many1 spacenonewline
- Amount{..} <- getDefaultCommodityAndStyle >>= parseAmount
- setDefaultCommodityAndStyle (aunit, astyle)
- restofline
- return $ return id
-
-parseDirectiveHistoricalPrice :: ParsecT [Char] Context (ErrorT String IO) HistoricalPrice
-parseDirectiveHistoricalPrice = do
- char 'P' <?> "historical price"
- many spacenonewline
- date <- try (do {LocalTime d _ <- parseDateTime; return d}) <|> parseDate -- a time is ignored
- many1 spacenonewline
- symbol <- parseCommodity
- many spacenonewline
- price <- getDefaultCommodityAndStyle >>= parseAmount
- restofline
- return $ HistoricalPrice date symbol price
-
-parseDirectiveIgnoredPriceCommodity :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
-parseDirectiveIgnoredPriceCommodity = do
- char 'N' <?> "ignored-price unit"
- many1 spacenonewline
- parseCommodity
- restofline
- return $ return id
-
-parseDirectiveCommodityConversion :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
-parseDirectiveCommodityConversion = do
- char 'C' <?> "unit conversion"
- many1 spacenonewline
- default_cs <- getDefaultCommodityAndStyle
- parseAmount default_cs
- many spacenonewline
- char '='
- many spacenonewline
- parseAmount default_cs
- restofline
- return $ return id
-
-parseTransactionModifier :: ParsecT [Char] Context (ErrorT String IO) ModifierTransaction
-parseTransactionModifier = do
- char '=' <?> "modifier transaction"
- many spacenonewline
- valueexpr <- restofline
- parsePostings <- parsePostings
- return $ ModifierTransaction valueexpr parsePostings
-
-parseTransactionPeriodic :: ParsecT [Char] Context (ErrorT String IO) PeriodicTransaction
-parseTransactionPeriodic = do
- char '~' <?> "periodic transaction"
- many spacenonewline
- periodexpr <- restofline
- parsePostings <- parsePostings
- return $ PeriodicTransaction periodexpr parsePostings
-
--- | Parse a (possibly unbalanced) transaction.
-parseTransaction :: ParsecT [Char] Context (ErrorT String IO) Transaction
-parseTransaction = do
- -- ptrace "transaction"
- sourcepos <- getPosition
- date <- parseDate <?> "transaction"
- edate <- optionMaybe (parseDate2 date) <?> "secondary date"
- lookAhead (spacenonewline <|> newline) <?> "whitespace or newline"
- status <- parseStatus <?> "cleared flag"
- code <- parseCode <?> "transaction code"
- description <- descriptionp >>= return . strip
- comment <- try followingcommentp <|> (newline >> return "")
- let tags = tagsInComment comment
- parsePostings <- parsePostings
- return $ txnTieKnot $ Transaction sourcepos date edate status code description comment tags parsePostings ""
-
-descriptionp = many (noneOf ";\n")
-
--- | Parse a date in YYYY/MM/DD format. Fewer digits are allowed. The year
--- may be omitted if a default year has already been set.
-parseDate :: Stream [Char] m t => ParsecT [Char] Context m Day
-parseDate = do
- -- hacky: try to ensure precise errors for invalid dates
- -- XXX reported error position is not too good
- -- pos <- getPosition
- datestr <- many1 $ choice' [digit, datesepchar]
- let sepchars = nub $ sort $ filter (`elem` datesepchars) datestr
- when (length sepchars /= 1) $ fail $ "bad date, different separators used: " ++ datestr
- let dateparts = wordsBy (`elem` datesepchars) datestr
- currentyear <- getYear
- [y, m, d] <-
- case (dateparts,currentyear) of
- ([m,d],Just y) -> return [show y,m,d]
- ([_,_],Nothing) -> fail $ "partial date "++datestr++" found, but the current year is unknown"
- ([y,m,d],_) -> return [y,m,d]
- _ -> fail $ "bad date: " ++ datestr
- let maybedate = fromGregorianValid (read y) (read m) (read d)
- case maybedate of
- Nothing -> fail $ "bad date: " ++ datestr
- Just date -> return date
- <?> "full or partial date"
-
--- | Parse a date and time in YYYY/MM/DD HH:MM[:SS][+-ZZZZ] format. Any
--- timezone will be ignored; the time is treated as local time. Fewer
--- digits are allowed, except in the timezone. The year may be omitted if
--- a default year has already been set.
-parseDateTime :: Stream [Char] m Char => ParsecT [Char] Context m LocalTime
-parseDateTime = do
- day <- parseDate
- many1 spacenonewline
- h <- many1 digit
- let h' = read h
- guard $ h' >= 0 && h' <= 23
- char ':'
- m <- many1 digit
- let m' = read m
- guard $ m' >= 0 && m' <= 59
- s <- optionMaybe $ char ':' >> many1 digit
- let s' = case s of Just sstr -> read sstr
- Nothing -> 0
- guard $ s' >= 0 && s' <= 59
- {- tz <- -}
- optionMaybe $ do
- plusminus <- oneOf "-+"
- d1 <- digit
- d2 <- digit
- d3 <- digit
- d4 <- digit
- return $ plusminus:d1:d2:d3:d4:""
- -- ltz <- liftIO $ getCurrentTimeZone
- -- let tz' = maybe ltz (fromMaybe ltz . parseTime defaultTimeLocale "%z") tz
- -- return $ localTimeToUTC tz' $ LocalTime day $ TimeOfDay h' m' (fromIntegral s')
- return $ LocalTime day $ TimeOfDay h' m' (fromIntegral s')
-
-parseDate2 :: Stream [Char] m Char => Day -> ParsecT [Char] Context m Day
-parseDate2 primarydate = do
- char '='
- -- kludgy way to use primary date for default year
- let withDefaultYear d p = do
- y <- getYear
- let (y',_,_) = toGregorian d in setYear y'
- r <- p
- when (isJust y) $ setYear $ fromJust y
- return r
- edate <- withDefaultYear primarydate parseDate
- return edate
-
-parseStatus :: Stream [Char] m Char => ParsecT [Char] Context m Bool
-parseStatus = try (do { many spacenonewline; (char '*' <|> char '!') <?> "status"; return True } ) <|> return False
-
-parseCode :: Stream [Char] m Char => ParsecT [Char] Context m String
-parseCode = try (do { many1 spacenonewline; char '(' <?> "parseCode"; code <- anyChar `manyTill` char ')'; return code } ) <|> return ""
-
--- Parse the following whitespace-beginning lines as parsePostings, posting tags, and/or comments.
-parsePostings :: Stream [Char] m Char => ParsecT [Char] Context m [Posting]
-parsePostings = many1 (try parsePosting) <?> "parsePostings"
-
-parsePosting :: Stream [Char] m Char => ParsecT [Char] Context m Posting
-parsePosting = do
- many1 spacenonewline
- status <- parseStatus
- many spacenonewline
- account <- modifiedaccountname
- let (ptype, account') = (accountNamePostingType account, unbracket account)
- amount <- spaceandamountormissing
- massertion <- partialbalanceassertion
- _ <- fixedlotprice
- many spacenonewline
- ctx <- getState
- comment <- try followingcommentp <|> (newline >> return "")
- let tags = tagsInComment comment
- coa <- getCoA
- pcoa <-
- if isZeroMixedAmount amount
- then do
- let coa_ = coaAdd coa (accountNameComponents account) tags
- setCoA coa_
- return coa_
- else return coa
- date <-
- case dateValueFromTags tags of
- Nothing -> return Nothing
- Just v ->
- case runParser (parseDate <* eof) ctx "" v of
- Right d -> return $ Just d
- Left err -> parserFail $ show err
- date2 <-
- case date2ValueFromTags tags of
- Nothing -> return Nothing
- Just v ->
- case runParser (parseDate <* eof) ctx "" v of
- Right d -> return $ Just d
- Left err -> parserFail $ show err
- return posting
- { Posting.date=date
- , Posting.date2=date2
- , Posting.status=status
- , Posting.account=account'
- , Posting.amount=amount
- , Posting.comment=comment
- , Posting.type=ptype
- , Posting.tags=tags
- , Posting.coa=pcoa
- , Posting.balanceassertion=massertion
- }
-
--- | Parse an account name, then apply any parent account prefix and/or account aliases currently in effect.
-modifiedaccountname :: Stream [Char] m Char => ParsecT [Char] Context m AccountName
-modifiedaccountname = do
- a <- parseAccountName
- prefix <- getParentAccount
- let prefixed = prefix `joinAccountNames` a
- aliases <- getAccountAliases
- return $ accountNameApplyAliases aliases prefixed
-
--- accountnamechar = notFollowedBy (oneOf "()[]") >> nonspace
--- <?> "account name character (non-bracket, non-parenthesis, non-whitespace)"
-
--- | Parse whitespace then an amount, with an optional left or right
--- currency symbol and optional price, or return the special
--- "missing" marker amount.
-spaceandamountormissing :: Stream [Char] m Char => ParsecT [Char] Context m MixedAmount
-spaceandamountormissing = do
- default_cs <- getDefaultCommodityAndStyle
- try (do
- many1 spacenonewline
- (Mixed . (:[])) `fmap` parseAmount default_cs <|> return missingmixedamt
- ) <|> return missingmixedamt
-
-partialbalanceassertion :: Stream [Char] m t => ParsecT [Char] Context m (Maybe MixedAmount)
-partialbalanceassertion = do
- default_cs <- getDefaultCommodityAndStyle
- try (do
- many spacenonewline
- char '='
- many spacenonewline
- a <- parseAmount default_cs -- XXX should restrict to a simple amount
- return $ Just $ Mixed [a])
- <|> return Nothing
-
--- balanceassertion :: Stream [Char] m Char => ParsecT [Char] Context m (Maybe MixedAmount)
--- balanceassertion =
--- default_cs <- getDefaultCommodityAndStyle
--- try (do
--- many spacenonewline
--- string "=="
--- many spacenonewline
--- a <- parseAmount default_cs -- XXX should restrict to a simple amount
--- return $ Just $ Mixed [a])
--- <|> return Nothing
-
--- http://ledger-cli.org/3.0/doc/ledger3.html#Fixing-Lot-Prices
-fixedlotprice :: Stream [Char] m Char => ParsecT [Char] Context m (Maybe Amount)
-fixedlotprice = do
- default_cs <- getDefaultCommodityAndStyle
- try (do
- many spacenonewline
- char '{'
- many spacenonewline
- char '='
- many spacenonewline
- a <- parseAmount default_cs -- XXX should restrict to a simple amount
- many spacenonewline
- char '}'
- return $ Just a)
- <|> return Nothing
-
--- comment parsers
-
-multilinecommentp :: Stream [Char] m Char => ParsecT [Char] Context m ()
-multilinecommentp = do
- string "comment" >> newline
- go
- where
- go = try (string "end comment" >> newline >> return ())
- <|> (anyLine >> go)
- anyLine = anyChar `manyTill` newline
-
-emptyorcommentlinep :: Stream [Char] m Char => ParsecT [Char] Context m ()
-emptyorcommentlinep = do
- many spacenonewline >> (parseComment <|> (many spacenonewline >> newline >> return ""))
- return ()
-
-followingcommentp :: Stream [Char] m Char => ParsecT [Char] Context m String
-followingcommentp =
- -- ptrace "followingcommentp"
- do samelinecomment <- many spacenonewline >> (try semicoloncomment <|> (newline >> return ""))
- newlinecomments <- many (try (many1 spacenonewline >> semicoloncomment))
- return $ unlines $ samelinecomment:newlinecomments
-
-parseComment :: Stream [Char] m Char => ParsecT [Char] Context m String
-parseComment = commentStartingWith commentchars
-
-commentchars :: [Char]
-commentchars = "#;*"
-
-semicoloncomment :: Stream [Char] m Char => ParsecT [Char] Context m String
-semicoloncomment = commentStartingWith ";"
-
-commentStartingWith :: Stream [Char] m Char => String -> ParsecT [Char] Context m String
-commentStartingWith cs = do
- -- ptrace "commentStartingWith"
- oneOf cs
- many spacenonewline
- l <- anyChar `manyTill` eolof
- optional newline
- return l
-
-tagsInComment :: String -> [Tag]
-tagsInComment c = concatMap tagsInCommentLine $ lines c'
- where
- c' = ledgerDateSyntaxToTags c
-
-tagsInCommentLine :: String -> [Tag]
-tagsInCommentLine = catMaybes . map maybetag . map strip . splitAtElement ','
- where
- maybetag s = case runParser (parseTag <* eof) contextNull "" s of
- Right t -> Just t
- Left _ -> Nothing
-
-parseTag = do
- -- ptrace "parseTag"
- n <- parseTagName
- v <- parseTagValue
- return (n,v)
-
-parseTagName = do
- -- ptrace "parseTagName"
- n <- many1 $ noneOf ": \t"
- char ':'
- return n
-
-parseTagValue = do
- -- ptrace "parseTagValue"
- v <- anyChar `manyTill` ((char ',' >> return ()) <|> eolof)
- return $ strip $ reverse $ dropWhile (==',') $ reverse $ strip v
-
-ledgerDateSyntaxToTags :: String -> String
-ledgerDateSyntaxToTags =
- regexReplaceBy "\\[[-.\\/0-9=]+\\]" replace
+-- * Directives
+
+directive_alias :: Stream s m Char => ParsecT s Context m ()
+directive_alias = do
+ _ <- R.string "alias"
+ R.skipMany1 $ R.space_horizontal
+ pattern <- account_pattern
+ R.skipMany $ R.space_horizontal
+ _ <- R.char '='
+ R.skipMany $ R.space_horizontal
+ repl <- account
+ R.skipMany $ R.space_horizontal
+ case pattern of
+ Account.Pattern_Exact acct -> R.modifyState $ \ctx -> ctx{context_aliases_exact=
+ Data.Map.insert acct repl $ context_aliases_exact ctx}
+ Account.Pattern_Joker jokr -> R.modifyState $ \ctx -> ctx{context_aliases_joker=
+ (jokr, repl):context_aliases_joker ctx}
+ Account.Pattern_Regex regx -> R.modifyState $ \ctx -> ctx{context_aliases_regex=
+ (regx, repl):context_aliases_regex ctx}
+ return ()
+
+
+-- * Read 'Comment'
+
+comment_begin :: Char
+comment_begin = ';'
+
+comment :: Stream s m Char => ParsecT s u m Comment
+comment = (do
+ _ <- R.char comment_begin
+ fromString <$> do
+ R.manyTill R.anyChar (R.lookAhead R.new_line <|> R.eof)
+ ) <?> "comment"
+
+comments :: Stream s m Char => ParsecT s u m [Comment]
+comments = (do
+ R.try $ do
+ _ <- R.spaces
+ R.many1_separated comment (R.new_line >> R.skipMany R.space_horizontal)
+ <|> return []
+ ) <?> "comments"
+
+-- * Read 'Tag'
+
+tag_value_sep :: Char
+tag_value_sep = ':'
+
+tag_sep :: Char
+tag_sep = ','
+
+-- | Read a 'Tag'.
+tag :: Stream s m Char => ParsecT s u m Tag
+tag = (do
+ n <- tag_name
+ _ <- R.char tag_value_sep
+ v <- tag_value
+ return (n, v)
+ ) <?> "tag"
+
+tag_name :: Stream s m Char => ParsecT s u m Tag_Name
+tag_name = do
+ fromString <$> do
+ R.many1 $ R.satisfy (\c -> c /= tag_value_sep && not (Data.Char.isSpace c))
+
+tag_value :: Stream s m Char => ParsecT s u m Tag_Value
+tag_value = do
+ fromString <$> do
+ R.manyTill R.anyChar $ do
+ R.lookAhead $ do
+ R.try (R.char tag_sep >> R.many R.space_horizontal >> tag_name >> R.char tag_value_sep >> return ())
+ <|> R.try R.new_line
+ <|> R.eof
+
+tags :: Stream s m Char => ParsecT s u m Tag_by_Name
+tags = do
+ Ledger.tag_by_Name <$> do
+ R.many_separated tag $ do
+ _ <- R.char tag_sep
+ R.skipMany $ R.space_horizontal
+ return ()
+
+not_tag :: Stream s m Char => ParsecT s u m ()
+not_tag = do
+ R.skipMany $ R.try $ do
+ R.skipMany $ R.satisfy
+ (\c -> c /= tag_value_sep
+ && not (Data.Char.isSpace c))
+ R.space_horizontal
+
+-- * Read 'Posting'
+
+posting
+ :: (Stream s (R.Error_State Error m) Char, Monad m)
+ => ParsecT s Context (R.Error_State Error m) (Posting, Posting_Type)
+posting = (do
+ ctx <- R.getState
+ sourcepos <- R.getPosition
+ R.skipMany1 $ R.space_horizontal
+ status_ <- status
+ R.skipMany $ R.space_horizontal
+ acct <- account
+ let (type_, account_) = posting_type acct
+ amounts_ <-
+ R.choice_try
+ [ do
+ _ <- R.count 2 R.space_horizontal
+ R.skipMany $ R.space_horizontal
+ maybe id (\(u, s) ->
+ if u == Unit.nil then id
+ else
+ Data.Map.adjust (\a ->
+ a{ Amount.style = s{Style.precision = Style.precision $ Amount.style a}
+ , Amount.unit = u })
+ Unit.nil)
+ (context_unit_and_style ctx) .
+ Amount.from_List <$> do
+ R.many_separated Amount.Read.amount $ do
+ R.skipMany $ R.space_horizontal
+ _ <- R.char amount_sep
+ R.skipMany $ R.space_horizontal
+ return ()
+ , return Data.Map.empty
+ ] <?> "amounts"
+ R.skipMany $ R.space_horizontal
+ -- TODO: balance assertion
+ -- TODO: conversion
+ comments_ <- comments
+ let tags_ = tags_of_comments comments_
+ dates_ <-
+ case Data.Map.lookup "date" tags_ of
+ Nothing -> return []
+ Just dates -> do
+ let date2s = Data.Map.lookup "date2" tags_ -- NOTE: support hledger's date2
+ do
+ (flip mapM) (dates ++ fromMaybe [] date2s) $ \s ->
+ R.runParserT_with_Error_fail "tag date" id
+ (Date.Read.date Error_date (Just $ context_year ctx) <* R.eof) ()
+ (Text.unpack s) s
+ >>= \dates_ -> case (dates, date2s) of -- NOTE: put hledger's date2 at least in second position
+ ([], Just (_:_)) ->
+ return $ context_date ctx:dates_
+ _ -> return $ dates_
+ return (Posting
+ { posting_account=account_
+ , posting_amounts=amounts_
+ , posting_comments=comments_
+ , posting_dates=dates_
+ , posting_sourcepos=sourcepos
+ , posting_status=status_
+ , posting_tags=tags_
+ }, type_)
+ ) <?> "posting"
+
+amount_sep :: Char
+amount_sep = '+'
+
+tags_of_comments :: [Comment] -> Tag_by_Name
+tags_of_comments =
+ Data.Map.unionsWith (++)
+ . Data.List.map
+ ( Data.Either.either (const Data.Map.empty) id
+ . R.runParser (not_tag >> tags <* R.eof) () "" )
+
+status :: Stream s m Char => ParsecT s u m Ledger.Status
+status = (do
+ ( R.try $ do
+ R.skipMany $ R.space_horizontal
+ _ <- (R.char '*' <|> R.char '!')
+ return True )
+ <|> return False
+ ) <?> "status"
+
+-- | Return the 'Posting_Type' and stripped 'Account' of the given 'Account'.
+posting_type :: Account -> (Posting_Type, Account)
+posting_type acct =
+ fromMaybe (Posting_Type_Regular, acct) $ do
+ case acct of
+ name:|[] ->
+ case Text.stripPrefix virtual_begin name of
+ Just name' -> do
+ name'' <-
+ Text.stripSuffix virtual_end name'
+ >>= return . Text.strip
+ guard $ not $ Text.null name''
+ Just (Posting_Type_Virtual, name'':|[])
+ Nothing -> do
+ name' <-
+ Text.stripPrefix virtual_balanced_begin name
+ >>= Text.stripSuffix virtual_balanced_end
+ >>= return . Text.strip
+ guard $ not $ Text.null name'
+ Just (Posting_Type_Virtual_Balanced, name':|[])
+ first_name:|acct' -> do
+ let rev_acct' = Data.List.reverse acct'
+ let last_name = Data.List.head rev_acct'
+ case Text.stripPrefix virtual_begin first_name
+ >>= return . Text.stripStart of
+ Just first_name' -> do
+ last_name' <-
+ Text.stripSuffix virtual_end last_name
+ >>= return . Text.stripEnd
+ guard $ not $ Text.null first_name'
+ guard $ not $ Text.null last_name'
+ Just $
+ ( Posting_Type_Virtual
+ , first_name':|
+ Data.List.reverse (last_name':Data.List.tail rev_acct')
+ )
+ Nothing -> do
+ first_name' <-
+ Text.stripPrefix virtual_balanced_begin first_name
+ >>= return . Text.stripStart
+ last_name' <-
+ Text.stripSuffix virtual_balanced_end last_name
+ >>= return . Text.stripEnd
+ guard $ not $ Text.null first_name'
+ guard $ not $ Text.null last_name'
+ Just $
+ ( Posting_Type_Virtual_Balanced
+ , first_name':|
+ Data.List.reverse (last_name':Data.List.tail rev_acct')
+ )
+ where
+ virtual_begin = Text.singleton posting_type_virtual_begin
+ virtual_end = Text.singleton posting_type_virtual_end
+ virtual_balanced_begin = Text.singleton posting_type_virtual_balanced_begin
+ virtual_balanced_end = Text.singleton posting_type_virtual_balanced_end
+
+posting_type_virtual_begin :: Char
+posting_type_virtual_begin = '('
+posting_type_virtual_balanced_begin :: Char
+posting_type_virtual_balanced_begin = '['
+posting_type_virtual_end :: Char
+posting_type_virtual_end = ')'
+posting_type_virtual_balanced_end :: Char
+posting_type_virtual_balanced_end = ']'
+
+-- * Read 'Transaction'
+
+transaction
+ :: (Stream s (R.Error_State Error m) Char, Monad m)
+ => ParsecT s Context (R.Error_State Error m) Transaction
+transaction = (do
+ ctx <- R.getState
+ transaction_sourcepos <- R.getPosition
+ transaction_comments_before <-
+ comments
+ >>= \x -> case x of
+ [] -> return []
+ _ -> return x <* R.new_line
+ date_ <- Date.Read.date Error_date (Just $ context_year ctx)
+ dates_ <-
+ R.option [] $ R.try $ do
+ R.skipMany $ R.space_horizontal
+ _ <- R.char date_sep
+ R.skipMany $ R.space_horizontal
+ R.many_separated
+ (Date.Read.date Error_date (Just $ context_year ctx)) $
+ R.try $ do
+ R.many $ R.space_horizontal
+ >> R.char date_sep
+ >> (R.many $ R.space_horizontal)
+ let transaction_dates = (date_, dates_)
+ R.skipMany $ R.space_horizontal
+ transaction_status <- status
+ transaction_code <- R.option "" $ R.try code
+ R.skipMany $ R.space_horizontal
+ transaction_description <- description
+ R.skipMany $ R.space_horizontal
+ transaction_comments_after <- comments
+ let transaction_tags =
+ Data.Map.unionWith (++)
+ (tags_of_comments transaction_comments_before)
+ (tags_of_comments transaction_comments_after)
+ R.new_line
+ (postings_unchecked, postings_not_regular) <-
+ ((Ledger.posting_by_Account . Data.List.map fst) *** id) .
+ Data.List.partition ((Posting_Type_Regular ==) . snd) <$>
+ R.many1_separated posting R.new_line
+ let (transaction_virtual_postings, balanced_virtual_postings_unchecked) =
+ join (***) (Ledger.posting_by_Account . Data.List.map fst) $
+ Data.List.partition ((Posting_Type_Virtual ==) . snd)
+ postings_not_regular
+ let tr_unchecked =
+ Transaction
+ { transaction_code
+ , transaction_comments_before
+ , transaction_comments_after
+ , transaction_dates
+ , transaction_description
+ , transaction_postings=postings_unchecked
+ , transaction_virtual_postings
+ , transaction_balanced_virtual_postings=balanced_virtual_postings_unchecked
+ , transaction_sourcepos
+ , transaction_status
+ , transaction_tags
+ }
+ transaction_postings <-
+ case Balance.infer_equilibrium postings_unchecked of
+ (_, Left ko) -> R.fail_with "transaction infer_equilibrium"
+ (Error_transaction_not_equilibrated tr_unchecked ko)
+ (_bal, Right ok) -> return ok
+ transaction_balanced_virtual_postings <-
+ case Balance.infer_equilibrium balanced_virtual_postings_unchecked of
+ (_, Left ko) -> R.fail_with "transaction infer_equilibrium"
+ (Error_virtual_transaction_not_equilibrated tr_unchecked ko)
+ (_bal, Right ok) -> return ok
+ return $
+ tr_unchecked
+ { transaction_postings
+ , transaction_balanced_virtual_postings
+ }
+ ) <?> "transaction"
+
+date_sep :: Char
+date_sep = '='
+
+code :: Stream s m Char => ParsecT s Context m Ledger.Code
+code = (do
+ fromString <$> do
+ R.skipMany $ R.space_horizontal
+ R.between (R.char '(') (R.char ')') $
+ R.many $ R.satisfy (\c -> c /= ')' && not (R.is_space_horizontal c))
+ ) <?> "code"
+
+description :: Stream s m Char => ParsecT s u m Ledger.Description
+description = (do
+ fromString <$> do
+ R.many $ R.try description_char
+ ) <?> "description"
where
- replace ('[':s) | lastDef ' ' s == ']' = replace' $ init s
- replace s = s
-
- replace' s | isdate s = datetag s
- replace' ('=':s) | isdate s = date2tag s
- replace' s | last s =='=' && isdate (init s) = datetag (init s)
- replace' s | length ds == 2 && isdate d1 && isdate d1 = datetag d1 ++ date2tag d2
- where
- ds = splitAtElement '=' s
- d1 = headDef "" ds
- d2 = lastDef "" ds
- replace' s = s
-
- isdate = isJust . parsedateM
- datetag s = "date:"++s++", "
- date2tag s = "date2:"++s++", "
-
-dateValueFromTags, date2ValueFromTags :: [Tag] -> Maybe String
-dateValueFromTags ts = maybe Nothing (Just . snd) $ find ((=="date") . fst) ts
-date2ValueFromTags ts = maybe Nothing (Just . snd) $ find ((=="date2") . fst) ts
--}
+ description_char :: Stream s m Char => ParsecT s u m Char
+ description_char = do
+ c <- R.anyChar
+ case c of
+ _ | c == comment_begin -> R.parserZero
+ _ | R.is_space_horizontal c -> return c <* (R.lookAhead $ R.try $ description_char)
+ _ | not (Data.Char.isSpace c) -> return c
+ _ -> R.parserZero
+
+-- * Read directives
+
+default_year :: Stream s m Char => ParsecT s Context m ()
+default_year = (do
+ year <- R.integer_of_digits 10 <$> R.many1 R.digit
+ R.skipMany R.space_horizontal >> R.new_line
+ context_ <- R.getState
+ R.setState context_{context_year=year}
+ ) <?> "default year"
+
+default_unit_and_style :: Stream s m Char => ParsecT s Context m ()
+default_unit_and_style = (do
+ amount_ <- Amount.Read.amount
+ R.skipMany R.space_horizontal >> R.new_line
+ context_ <- R.getState
+ R.setState context_{context_unit_and_style =
+ Just $
+ ( Amount.unit amount_
+ , Amount.style amount_ )}
+ ) <?> "default unit and style"
+
+include
+ :: Stream s (R.Error_State Error IO) Char
+ => ParsecT s Context (R.Error_State Error IO) ()
+include = (do
+ sourcepos <- R.getPosition
+ filename <- R.manyTill R.anyChar (R.lookAhead R.new_line <|> R.eof)
+ context_ <- R.getState
+ let journal_ = context_journal context_
+ let cwd = Path.takeDirectory (R.sourceName sourcepos)
+ file_path <- liftIO $ Path.abs cwd filename
+ content <- do
+ join $ liftIO $ Exception.catch
+ (liftM return $ readFile file_path)
+ (return . R.fail_with "include reading" . Error_reading_file file_path)
+ (journal_included, context_included) <- do
+ liftIO $
+ R.runParserT_with_Error (R.and_state $ journal_rec file_path)
+ context_{context_journal = Ledger.journal}
+ file_path content
+ >>= \x -> case x of
+ Right ok -> return ok
+ Left ko -> R.fail_with "include parsing" (Error_including_file file_path ko)
+ R.setState $
+ context_included{context_journal=
+ journal_{journal_includes=
+ journal_included{journal_file=file_path}
+ : journal_includes journal_}}
+ ) <?> "include"
+
+-- * Read 'Journal'
+
+journal
+ :: Stream s (R.Error_State Error IO) Char
+ => FilePath
+ -> ParsecT s Context (R.Error_State Error IO) Journal
+journal file_ = (do
+ currentLocalTime <- liftIO $
+ Time.utcToLocalTime
+ <$> Time.getCurrentTimeZone
+ <*> Time.getCurrentTime
+ let (currentLocalYear, _, _) = Time.toGregorian $ Time.localDay currentLocalTime
+ context_ <- R.getState
+ R.setState $ context_{context_year=currentLocalYear}
+ journal_rec file_
+ ) <?> "journal"
+
+journal_rec
+ :: Stream s (R.Error_State Error IO) Char
+ => FilePath
+ -> ParsecT s Context (R.Error_State Error IO) Journal
+journal_rec file_ = do
+ last_read_time <- lift $ liftIO Time.getCurrentTime
+ R.skipMany $ do
+ R.choice_try
+ [ R.skipMany1 R.space
+ , (do (R.choice_try
+ [ R.string "Y" >> return default_year
+ , R.string "D" >> return default_unit_and_style
+ , R.string "!include" >> return include
+ ] <?> "directive")
+ >>= \r -> R.skipMany1 R.space_horizontal >> r)
+ , ((do
+ t <- transaction
+ context_' <- R.getState
+ let j = context_journal context_'
+ R.setState $ context_'{context_journal=
+ j{journal_transactions=
+ Data.Map.insertWith (flip (++))
+ -- NOTE: flip-ing preserves order but slows down
+ -- when many transactions have the very same date.
+ (fst $ transaction_dates t) [t]
+ (journal_transactions j)}}
+ R.new_line <|> R.eof))
+ , R.try (comment >> return ())
+ ]
+ R.eof
+ journal_ <- context_journal <$> R.getState
+ return $
+ journal_
+ { journal_file = file_
+ , journal_last_read_time=last_read_time
+ , journal_includes = reverse $ journal_includes journal_
+ }
+
+-- ** Read 'Journal' from a file
+
+file :: FilePath -> ExceptT [R.Error Error] IO Journal
+file path = do
+ ExceptT $
+ Exception.catch
+ (liftM Right $ Text.IO.readFile path) $
+ \ko -> return $ Left $
+ [ R.Error_Custom (R.initialPos path) $ Error_reading_file path ko ]
+ >>= liftIO . R.runParserT_with_Error (journal path) nil_Context path
+ >>= \x -> case x of
+ Left ko -> throwE $ ko
+ Right ok -> ExceptT $ return $ Right ok
sourcephile / git / comptalang.git / blobdiff