{-# LANGUAGE DeriveDataTypeable #-} 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 qualified Data.Time.Calendar as Time import qualified Data.Time.LocalTime as Time import Text.Parsec hiding (parse) import Hcompta.Model as Model import Hcompta.Model.Account as Model.Account import Hcompta.Model.Amount as Model.Amount import Hcompta.Model.Date as Model.Date import Hcompta.Format.Ledger.Journal as Journal data Context = Context { account_prefix :: !Model.Account --, context_aliases :: ![AccountAlias] , unit_and_style :: !(Maybe (Model.Amount.Unit, Model.Amount.Style)) , journal :: !Journal , year :: !Model.Date.Year } deriving (Data, Eq, Read, Show, Typeable) null :: Context null = Context { account_prefix = [] , unit_and_style = Nothing , journal = Journal.null , year = (\(year, _ , _) -> year) $ Time.toGregorian $ Time.utctDay $ Journal.last_read_time Journal.null } {- 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 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 ] "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 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 -}