module Hledger.Read.Common
where
import Prelude ()
import Prelude.Compat hiding (readFile)
import Control.Monad.Compat
import Control.Monad.Except (ExceptT(..), runExceptT, throwError)
import Control.Monad.State.Strict
import Data.Char
import Data.Data
import Data.Default
import Data.Functor.Identity
import Data.List.Compat
import Data.List.NonEmpty (NonEmpty(..))
import Data.List.Split (wordsBy)
import Data.Maybe
import qualified Data.Map as M
import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Calendar
import Data.Time.LocalTime
import Safe
import System.Time (getClockTime)
import Text.Megaparsec.Compat
import Hledger.Data
import Hledger.Utils
data InputOpts = InputOpts {
mformat_ :: Maybe StorageFormat
,mrules_file_ :: Maybe FilePath
,aliases_ :: [String]
,anon_ :: Bool
,ignore_assertions_ :: Bool
,new_ :: Bool
,new_save_ :: Bool
,pivot_ :: String
} deriving (Show, Data)
instance Default InputOpts where def = definputopts
definputopts :: InputOpts
definputopts = InputOpts def def def def def def True def
rawOptsToInputOpts :: RawOpts -> InputOpts
rawOptsToInputOpts rawopts = InputOpts{
mformat_ = Nothing
,mrules_file_ = maybestringopt "rules-file" rawopts
,aliases_ = map (T.unpack . stripquotes . T.pack) $ listofstringopt "alias" rawopts
,anon_ = boolopt "anon" rawopts
,ignore_assertions_ = boolopt "ignore-assertions" rawopts
,new_ = boolopt "new" rawopts
,new_save_ = True
,pivot_ = stringopt "pivot" rawopts
}
runTextParser, rtp :: TextParser Identity a -> Text -> Either (ParseError Char MPErr) a
runTextParser p t = runParser p "" t
rtp = runTextParser
runJournalParser, rjp :: Monad m => TextParser m a -> Text -> m (Either (ParseError Char MPErr) a)
runJournalParser p t = runParserT p "" t
rjp = runJournalParser
runErroringJournalParser, rejp :: Monad m => ErroringJournalParser m a -> Text -> m (Either String a)
runErroringJournalParser p t =
runExceptT $
runJournalParser (evalStateT p mempty)
t >>=
either (throwError . parseErrorPretty) return
rejp = runErroringJournalParser
genericSourcePos :: SourcePos -> GenericSourcePos
genericSourcePos p = GenericSourcePos (sourceName p) (fromIntegral . unPos $ sourceLine p) (fromIntegral . unPos $ sourceColumn p)
journalSourcePos :: SourcePos -> SourcePos -> GenericSourcePos
journalSourcePos p p' = JournalSourcePos (sourceName p) (fromIntegral . unPos $ sourceLine p, fromIntegral $ line')
where line'
| (unPos $ sourceColumn p') == 1 = unPos (sourceLine p') 1
| otherwise = unPos $ sourceLine p'
parseAndFinaliseJournal :: ErroringJournalParser IO ParsedJournal -> Bool
-> FilePath -> Text -> ExceptT String IO Journal
parseAndFinaliseJournal parser assrt f txt = do
t <- liftIO getClockTime
y <- liftIO getCurrentYear
ep <- runParserT (evalStateT parser nulljournal {jparsedefaultyear=Just y}) f txt
case ep of
Right pj -> case journalFinalise t f txt assrt pj of
Right j -> return j
Left e -> throwError e
Left e -> throwError $ parseErrorPretty e
parseAndFinaliseJournal' :: JournalParser Identity ParsedJournal -> Bool -> FilePath -> Text -> ExceptT String IO Journal
parseAndFinaliseJournal' parser assrt f txt = do
t <- liftIO getClockTime
y <- liftIO getCurrentYear
let ep = runParser (evalStateT parser nulljournal {jparsedefaultyear=Just y}) f txt
case ep of
Right pj -> case journalFinalise t f txt assrt pj of
Right j -> return j
Left e -> throwError e
Left e -> throwError $ parseErrorPretty e
setYear :: Year -> JournalParser m ()
setYear y = modify' (\j -> j{jparsedefaultyear=Just y})
getYear :: JournalParser m (Maybe Year)
getYear = fmap jparsedefaultyear get
setDefaultCommodityAndStyle :: (CommoditySymbol,AmountStyle) -> JournalParser m ()
setDefaultCommodityAndStyle cs = modify' (\j -> j{jparsedefaultcommodity=Just cs})
getDefaultCommodityAndStyle :: JournalParser m (Maybe (CommoditySymbol,AmountStyle))
getDefaultCommodityAndStyle = jparsedefaultcommodity `fmap` get
getDefaultAmountStyle :: JournalParser m (Maybe AmountStyle)
getDefaultAmountStyle = fmap snd <$> getDefaultCommodityAndStyle
getAmountStyle :: CommoditySymbol -> JournalParser m (Maybe AmountStyle)
getAmountStyle commodity = do
specificStyle <- maybe Nothing cformat . M.lookup commodity . jcommodities <$> get
defaultStyle <- fmap snd <$> getDefaultCommodityAndStyle
let effectiveStyle = listToMaybe $ catMaybes [specificStyle, defaultStyle]
return effectiveStyle
pushAccount :: AccountName -> JournalParser m ()
pushAccount acct = modify' (\j -> j{jaccounts = acct : jaccounts j})
pushParentAccount :: AccountName -> JournalParser m ()
pushParentAccount acct = modify' (\j -> j{jparseparentaccounts = acct : jparseparentaccounts j})
popParentAccount :: JournalParser m ()
popParentAccount = do
j <- get
case jparseparentaccounts j of
[] -> unexpected (Tokens ('E' :| "nd of apply account block with no beginning"))
(_:rest) -> put j{jparseparentaccounts=rest}
getParentAccount :: JournalParser m AccountName
getParentAccount = fmap (concatAccountNames . reverse . jparseparentaccounts) get
addAccountAlias :: MonadState Journal m => AccountAlias -> m ()
addAccountAlias a = modify' (\(j@Journal{..}) -> j{jparsealiases=a:jparsealiases})
getAccountAliases :: MonadState Journal m => m [AccountAlias]
getAccountAliases = fmap jparsealiases get
clearAccountAliases :: MonadState Journal m => m ()
clearAccountAliases = modify' (\(j@Journal{..}) -> j{jparsealiases=[]})
journalAddFile :: (FilePath,Text) -> Journal -> Journal
journalAddFile f j@Journal{jfiles=fs} = j{jfiles=fs++[f]}
parserErrorAt :: Monad m => SourcePos -> String -> ErroringJournalParser m a
parserErrorAt pos s = throwError $ sourcePosPretty pos ++ ":\n" ++ s
statusp :: TextParser m Status
statusp =
choice'
[ many spacenonewline >> char '*' >> return Cleared
, many spacenonewline >> char '!' >> return Pending
, return Unmarked
]
<?> "cleared status"
codep :: TextParser m String
codep = try (do { some spacenonewline; char '(' <?> "codep"; anyChar `manyTill` char ')' } ) <|> return ""
descriptionp :: JournalParser m String
descriptionp = many (noneOf (";\n" :: [Char]))
datep :: JournalParser m Day
datep = do
datestr <- do
c <- digitChar
cs <- lift $ many $ choice' [digitChar, datesepchar]
return $ c:cs
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"
datetimep :: JournalParser m LocalTime
datetimep = do
day <- datep
lift $ some spacenonewline
h <- some digitChar
let h' = read h
guard $ h' >= 0 && h' <= 23
char ':'
m <- some digitChar
let m' = read m
guard $ m' >= 0 && m' <= 59
s <- optional $ char ':' >> some digitChar
let s' = case s of Just sstr -> read sstr
Nothing -> 0
guard $ s' >= 0 && s' <= 59
optional $ do
plusminus <- oneOf ("-+" :: [Char])
d1 <- digitChar
d2 <- digitChar
d3 <- digitChar
d4 <- digitChar
return $ plusminus:d1:d2:d3:d4:""
return $ LocalTime day $ TimeOfDay h' m' (fromIntegral s')
secondarydatep :: Day -> JournalParser m Day
secondarydatep primarydate = do
char '='
let withDefaultYear d p = do
y <- getYear
let (y',_,_) = toGregorian d in setYear y'
r <- p
when (isJust y) $ setYear $ fromJust y
return r
withDefaultYear primarydate datep
modifiedaccountnamep :: JournalParser m AccountName
modifiedaccountnamep = do
parent <- getParentAccount
aliases <- getAccountAliases
a <- lift accountnamep
return $
accountNameApplyAliases aliases $
joinAccountNames parent
a
accountnamep :: TextParser m AccountName
accountnamep = do
astr <- do
c <- nonspace
cs <- striptrailingspace <$> many (nonspace <|> singlespace)
return $ c:cs
let a = T.pack astr
when (accountNameFromComponents (accountNameComponents a) /= a)
(fail $ "account name seems ill-formed: "++astr)
return a
where
singlespace = try (do {spacenonewline; do {notFollowedBy spacenonewline; return ' '}})
striptrailingspace "" = ""
striptrailingspace s = if last s == ' ' then init s else s
spaceandamountormissingp :: Monad m => JournalParser m MixedAmount
spaceandamountormissingp =
try (do
lift $ some spacenonewline
(Mixed . (:[])) `fmap` amountp <|> return missingmixedamt
) <|> return missingmixedamt
#ifdef TESTS
assertParseEqual' :: (Show a, Eq a) => (Either ParseError a) -> a -> Assertion
assertParseEqual' parse expected = either (assertFailure.show) (`is'` expected) parse
is' :: (Eq a, Show a) => a -> a -> Assertion
a `is'` e = assertEqual e a
test_spaceandamountormissingp = do
assertParseEqual' (parseWithState mempty spaceandamountormissingp " $47.18") (Mixed [usd 47.18])
assertParseEqual' (parseWithState mempty spaceandamountormissingp "$47.18") missingmixedamt
assertParseEqual' (parseWithState mempty spaceandamountormissingp " ") missingmixedamt
assertParseEqual' (parseWithState mempty spaceandamountormissingp "") missingmixedamt
#endif
amountp :: Monad m => JournalParser m Amount
amountp = try leftsymbolamountp <|> try rightsymbolamountp <|> nosymbolamountp
#ifdef TESTS
test_amountp = do
assertParseEqual' (parseWithState mempty amountp "$47.18") (usd 47.18)
assertParseEqual' (parseWithState mempty amountp "$1.") (usd 1 `withPrecision` 0)
assertParseEqual'
(parseWithState mempty amountp "$10 @ €0.5")
(usd 10 `withPrecision` 0 `at` (eur 0.5 `withPrecision` 1))
assertParseEqual'
(parseWithState mempty amountp "$10 @@ €5")
(usd 10 `withPrecision` 0 @@ (eur 5 `withPrecision` 0))
#endif
amountp' :: String -> Amount
amountp' s =
case runParser (evalStateT (amountp <* eof) mempty) "" (T.pack s) of
Right amt -> amt
Left err -> error' $ show err
mamountp' :: String -> MixedAmount
mamountp' = Mixed . (:[]) . amountp'
signp :: TextParser m String
signp = do
sign <- optional $ oneOf ("+-" :: [Char])
return $ case sign of Just '-' -> "-"
_ -> ""
multiplierp :: TextParser m Bool
multiplierp = do
multiplier <- optional $ oneOf ("*" :: [Char])
return $ case multiplier of Just '*' -> True
_ -> False
leftsymbolamountp :: Monad m => JournalParser m Amount
leftsymbolamountp = do
sign <- lift signp
m <- lift multiplierp
c <- lift commoditysymbolp
suggestedStyle <- getAmountStyle c
sp <- lift $ many spacenonewline
(q,prec,mdec,mgrps) <- lift $ numberp suggestedStyle
let s = amountstyle{ascommodityside=L, ascommodityspaced=not $ null sp, asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps}
p <- priceamountp
let applysign = if sign=="-" then negate else id
return $ applysign $ Amount c q p s m
<?> "left-symbol amount"
rightsymbolamountp :: Monad m => JournalParser m Amount
rightsymbolamountp = do
m <- lift multiplierp
sign <- lift signp
rawnum <- lift $ rawnumberp
sp <- lift $ many spacenonewline
c <- lift commoditysymbolp
suggestedStyle <- getAmountStyle c
let (q,prec,mdec,mgrps) = fromRawNumber suggestedStyle (sign == "-") rawnum
p <- priceamountp
let s = amountstyle{ascommodityside=R, ascommodityspaced=not $ null sp, asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps}
return $ Amount c q p s m
<?> "right-symbol amount"
nosymbolamountp :: Monad m => JournalParser m Amount
nosymbolamountp = do
m <- lift multiplierp
suggestedStyle <- getDefaultAmountStyle
(q,prec,mdec,mgrps) <- lift $ numberp suggestedStyle
p <- priceamountp
defcs <- getDefaultCommodityAndStyle
let (c,s) = case defcs of
Just (defc,defs) -> (defc, defs{asprecision=max (asprecision defs) prec})
Nothing -> ("", amountstyle{asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps})
return $ Amount c q p s m
<?> "no-symbol amount"
commoditysymbolp :: TextParser m CommoditySymbol
commoditysymbolp = (quotedcommoditysymbolp <|> simplecommoditysymbolp) <?> "commodity symbol"
quotedcommoditysymbolp :: TextParser m CommoditySymbol
quotedcommoditysymbolp = do
char '"'
s <- some $ noneOf (";\n\"" :: [Char])
char '"'
return $ T.pack s
simplecommoditysymbolp :: TextParser m CommoditySymbol
simplecommoditysymbolp = T.pack <$> some (noneOf nonsimplecommoditychars)
priceamountp :: Monad m => JournalParser m Price
priceamountp =
try (do
lift (many spacenonewline)
char '@'
try (do
char '@'
lift (many spacenonewline)
a <- amountp
return $ TotalPrice a)
<|> (do
lift (many spacenonewline)
a <- amountp
return $ UnitPrice a))
<|> return NoPrice
partialbalanceassertionp :: Monad m => JournalParser m BalanceAssertion
partialbalanceassertionp =
try (do
lift (many spacenonewline)
sourcepos <- genericSourcePos <$> lift getPosition
char '='
lift (many spacenonewline)
a <- amountp
return $ Just (a, sourcepos))
<|> return Nothing
fixedlotpricep :: Monad m => JournalParser m (Maybe Amount)
fixedlotpricep =
try (do
lift (many spacenonewline)
char '{'
lift (many spacenonewline)
char '='
lift (many spacenonewline)
a <- amountp
lift (many spacenonewline)
char '}'
return $ Just a)
<|> return Nothing
numberp :: Maybe AmountStyle -> TextParser m (Quantity, Int, Maybe Char, Maybe DigitGroupStyle)
numberp suggestedStyle = do
sign <- signp
raw <- rawnumberp
dbg8 "numberp parsed" raw `seq` return ()
return $ dbg8 "numberp quantity,precision,mdecimalpoint,mgrps" (fromRawNumber suggestedStyle (sign == "-") raw)
<?> "numberp"
fromRawNumber :: Maybe AmountStyle -> Bool -> (Maybe Char, [String], Maybe (Char, String)) -> (Quantity, Int, Maybe Char, Maybe DigitGroupStyle)
fromRawNumber suggestedStyle negated raw = (quantity, precision, mdecimalpoint, mgrps) where
(mseparator, intparts, mdecimalpoint, frac) =
case raw of
(Just s, [firstGroup, lastGroup], Nothing)
| maybe True (`asdecimalcheck` s) suggestedStyle -> (Nothing, [firstGroup], Just s, lastGroup)
(firstSep, digitGroups, Nothing) -> (firstSep, digitGroups, Nothing, [])
(firstSep, digitGroups, Just (d, frac)) -> (firstSep, digitGroups, Just d, frac)
groupsizes = reverse $ case map length intparts of
(a:b:cs) | a < b -> b:cs
gs -> gs
mgrps = (`DigitGroups` groupsizes) <$> mseparator
repr = (if negated then "-" else "") ++ "0" ++ concat intparts ++ (if null frac then "" else "." ++ frac)
quantity = read repr
precision = length frac
asdecimalcheck :: AmountStyle -> Char -> Bool
asdecimalcheck = \case
AmountStyle{asdecimalpoint = Just d} -> (d ==)
AmountStyle{asdigitgroups = Just (DigitGroups g _)} -> (g /=)
AmountStyle{asprecision = 0} -> const False
_ -> const True
rawnumberp :: TextParser m (Maybe Char, [String], Maybe (Char, String))
rawnumberp = do
let sepChars = ['.', ',']
(firstSep, groups) <- option (Nothing, []) $ do
leadingDigits <- some digitChar
option (Nothing, [leadingDigits]) . try $ do
firstSep <- oneOf sepChars <|> whitespaceChar
groups <- some digitChar `sepBy1` char firstSep
return (Just firstSep, leadingDigits : groups)
let remSepChars = maybe sepChars (`delete` sepChars) firstSep
modifier
| null groups = fmap Just
| otherwise = optional
extraGroup <- modifier $ do
lastSep <- oneOf remSepChars
digits <- modifier $ some digitChar
return (lastSep, fromMaybe [] digits)
notFollowedBy $ oneOf sepChars <|> (whitespaceChar >> digitChar)
return $ dbg8 "rawnumberp" (firstSep, groups, extraGroup)
<?> "rawnumberp"
whitespaceChar :: TextParser m Char
whitespaceChar = charCategory Space
multilinecommentp :: JournalParser m ()
multilinecommentp = do
string "comment" >> lift (many spacenonewline) >> newline
go
where
go = try (eof <|> (string "end comment" >> newline >> return ()))
<|> (anyLine >> go)
anyLine = anyChar `manyTill` newline
emptyorcommentlinep :: JournalParser m ()
emptyorcommentlinep = do
lift (many spacenonewline) >> (linecommentp <|> (lift (many spacenonewline) >> newline >> return ""))
return ()
followingcommentp :: JournalParser m Text
followingcommentp =
do samelinecomment <- lift (many spacenonewline) >> (try commentp <|> (newline >> return ""))
newlinecomments <- many (try (lift (some spacenonewline) >> commentp))
return $ T.unlines $ samelinecomment:newlinecomments
followingcommentandtagsp :: MonadIO m => Maybe Day
-> ErroringJournalParser m (Text, [Tag], Maybe Day, Maybe Day)
followingcommentandtagsp mdefdate = do
startpos <- getPosition
commentandwhitespace :: String <- do
let commentp' = (:) <$> char ';' <*> anyChar `manyTill` eolof
sp1 <- lift (many spacenonewline)
l1 <- try (lift commentp') <|> (newline >> return "")
ls <- lift . many $ try ((++) <$> some spacenonewline <*> commentp')
return $ unlines $ (sp1 ++ l1) : ls
let comment = T.pack $ unlines $ map (lstrip . dropWhile (==';') . strip) $ lines commentandwhitespace
tags <- case runTextParser (setPosition startpos >> tagsp) $ T.pack commentandwhitespace of
Right ts -> return ts
Left e -> throwError $ parseErrorPretty e
epdates <- liftIO $ rejp (setPosition startpos >> postingdatesp mdefdate) $ T.pack commentandwhitespace
pdates <- case epdates of
Right ds -> return ds
Left e -> throwError e
let mdate = headMay $ map snd $ filter ((=="date").fst) pdates
mdate2 = headMay $ map snd $ filter ((=="date2").fst) pdates
return (comment, tags, mdate, mdate2)
commentp :: JournalParser m Text
commentp = commentStartingWithp ";"
linecommentp :: JournalParser m Text
linecommentp = commentStartingWithp ";#*"
commentStartingWithp :: [Char] -> JournalParser m Text
commentStartingWithp cs = do
oneOf cs
lift (many spacenonewline)
l <- anyChar `manyTill` (lift eolof)
optional newline
return $ T.pack l
commentTags :: Text -> [Tag]
commentTags s =
case runTextParser tagsp s of
Right r -> r
Left _ -> []
tagsp :: SimpleTextParser [Tag]
tagsp =
many (try (nontagp >> tagp))
nontagp :: SimpleTextParser String
nontagp =
anyChar `manyTill` lookAhead (try (void tagp) <|> eof)
tagp :: SimpleTextParser Tag
tagp = do
n <- tagnamep
v <- tagvaluep
return (n,v)
tagnamep :: SimpleTextParser Text
tagnamep =
T.pack <$> some (noneOf (": \t\n" :: [Char])) <* char ':'
tagvaluep :: TextParser m Text
tagvaluep = do
v <- anyChar `manyTill` (void (try (char ',')) <|> eolof)
return $ T.pack $ strip $ reverse $ dropWhile (==',') $ reverse $ strip v
postingdatesp :: Monad m => Maybe Day -> ErroringJournalParser m [(TagName,Day)]
postingdatesp mdefdate = do
let p = ((:[]) <$> datetagp mdefdate) <|> bracketeddatetagsp mdefdate
nonp =
many (notFollowedBy p >> anyChar)
concat <$> many (try (nonp >> p))
datetagp :: Monad m => Maybe Day -> ErroringJournalParser m (TagName,Day)
datetagp mdefdate = do
string "date"
n <- fromMaybe "" <$> optional (mptext "2")
char ':'
startpos <- getPosition
v <- lift tagvaluep
j <- get
let ep :: Either (ParseError Char MPErr) Day
ep = parseWithState'
j{jparsedefaultyear=first3.toGregorian <$> mdefdate}
(do
setPosition startpos
datep)
v
case ep
of Left e -> throwError $ parseErrorPretty e
Right d -> return ("date"<>n, d)
bracketeddatetagsp :: Monad m => Maybe Day -> ErroringJournalParser m [(TagName, Day)]
bracketeddatetagsp mdefdate = do
char '['
startpos <- getPosition
let digits = "0123456789"
s <- some (oneOf $ '=':digits++datesepchars)
char ']'
unless (any (`elem` s) digits && any (`elem` datesepchars) s) $
fail "not a bracketed date"
j <- get
let ep :: Either (ParseError Char MPErr) (Maybe Day, Maybe Day)
ep = parseWithState'
j{jparsedefaultyear=first3.toGregorian <$> mdefdate}
(do
setPosition startpos
md1 <- optional datep
maybe (return ()) (setYear.first3.toGregorian) md1
md2 <- optional $ char '=' >> datep
eof
return (md1,md2)
)
(T.pack s)
case ep
of Left e -> throwError $ parseErrorPretty e
Right (md1,md2) -> return $ catMaybes
[("date",) <$> md1, ("date2",) <$> md2]