slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

lib: superficial changes to parsers

Browse Source
This commit is contained in:
Alex Chen 2018-05-23 22:36:19 -06:00 committed by Simon Michael
parent 121ba92ade
commit 84c7e2c403
2 changed files with 88 additions and 108 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

194
hledger-lib/Hledger/Read/Common.hs
View File

@ -339,6 +339,7 @@ parserErrorAt :: Monad m => SourcePos -> String -> ErroringJournalParser m a
parserErrorAt pos s = throwError $ sourcePosPretty pos ++ ":\n" ++ s parserErrorAt pos s = throwError $ sourcePosPretty pos ++ ":\n" ++ s
--- * parsers --- * parsers
--- ** transaction bits --- ** transaction bits
statusp :: TextParser m Status statusp :: TextParser m Status
@ -348,16 +349,15 @@ statusp =
, skipMany spacenonewline >> char '!' >> return Pending , skipMany spacenonewline >> char '!' >> return Pending
, return Unmarked , return Unmarked
] ]
<?> "cleared status"
codep :: TextParser m Text codep :: TextParser m Text
codep = try codep' <|> pure "" where codep = option "" $ try $ do
codep' = do skipSome spacenonewline
skipSome spacenonewline between (char '(') (char ')') $ takeWhileP Nothing (/= ')')
between (char '(' <?> "codep") (char ')') $ takeWhileP Nothing (/= ')')
descriptionp :: JournalParser m Text descriptionp :: JournalParser m Text
descriptionp = takeWhileP Nothing $ \c -> c /= ';' && c /= '\n' descriptionp = takeWhileP Nothing (not . semicolonOrNewline)
where semicolonOrNewline c = c == ';' || c == '\n'
--- ** dates --- ** dates
@ -367,8 +367,8 @@ descriptionp = takeWhileP Nothing $ \c -> c /= ';' && c /= '\n'
-- Leading zeroes may be omitted. -- Leading zeroes may be omitted.
datep :: JournalParser m Day datep :: JournalParser m Day
datep = do datep = do
myear <- getYear mYear <- getYear
lift $ datep' myear lift $ datep' mYear
datep' :: Maybe Year -> TextParser m Day datep' :: Maybe Year -> TextParser m Day
datep' mYear = do datep' mYear = do
@ -380,7 +380,7 @@ datep' mYear = do
where where
fullDate :: Integer -> Char -> Integer -> TextParser m Day fullDate :: Integer -> Char -> Int -> TextParser m Day
fullDate year sep1 month = do fullDate year sep1 month = do
sep2 <- satisfy isDateSepChar <?> "date separator" sep2 <- satisfy isDateSepChar <?> "date separator"
day <- decimal <?> "day" day <- decimal <?> "day"
@ -389,17 +389,18 @@ datep' mYear = do
when (sep1 /= sep2) $ fail $ when (sep1 /= sep2) $ fail $
"invalid date (mixing date separators is not allowed): " ++ dateStr "invalid date (mixing date separators is not allowed): " ++ dateStr
case fromGregorianValid year (fromIntegral month) day of case fromGregorianValid year month day of
Nothing -> fail $ "well-formed but invalid date: " ++ dateStr Nothing -> fail $ "well-formed but invalid date: " ++ dateStr
Just date -> pure date Just date -> pure date
partialDate :: Maybe Year -> Integer -> Char -> Integer -> TextParser m Day partialDate :: Maybe Year -> Integer -> Char -> Int -> TextParser m Day
partialDate mYear month sep day = case mYear of partialDate mYear month sep day = case mYear of
Just year -> Just year ->
case fromGregorianValid year (fromIntegral month) (fromIntegral day) of case fromGregorianValid year (fromIntegral month) day of
Nothing -> fail $ "well-formed but invalid date: " ++ dateStr Nothing -> fail $ "well-formed but invalid date: " ++ dateStr
Just date -> pure date Just date -> pure date
where dateStr = show year ++ [sep] ++ show month ++ [sep] ++ show day where dateStr = show year ++ [sep] ++ show month ++ [sep] ++ show day
Nothing -> fail $ Nothing -> fail $
"partial date "++dateStr++" found, but the current year is unknown" "partial date "++dateStr++" found, but the current year is unknown"
where dateStr = show month ++ [sep] ++ show day where dateStr = show month ++ [sep] ++ show day
@ -438,28 +439,9 @@ datetimep = do
-- return $ localTimeToUTC tz' $ LocalTime day $ TimeOfDay h' m' (fromIntegral s') -- return $ localTimeToUTC tz' $ LocalTime day $ TimeOfDay h' m' (fromIntegral s')
return $ LocalTime day $ TimeOfDay h' m' (fromIntegral s') return $ LocalTime day $ TimeOfDay h' m' (fromIntegral s')
secondarydatep :: Day -> JournalParser m Day secondarydatep :: Day -> TextParser m Day
secondarydatep primarydate = do secondarydatep primaryDate = char '=' *> datep' (Just primaryYear)
char '=' where primaryYear = first3 $ toGregorian primaryDate
-- 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 -- XXX
-- mapM setYear <$> y
return r
withDefaultYear primarydate datep
-- |
-- >> parsewith twoorthreepartdatestringp "2016/01/2"
-- Right "2016/01/2"
-- twoorthreepartdatestringp = do
-- n1 <- some digitChar
-- c <- datesepchar
-- n2 <- some digitChar
-- mn3 <- optional $ char c >> some digitChar
-- return $ n1 ++ c:n2 ++ maybe "" (c:) mn3
--- ** account names --- ** account names
@ -485,8 +467,12 @@ accountnamep = do
firstPart <- part firstPart <- part
otherParts <- many $ try $ singleSpace *> part otherParts <- many $ try $ singleSpace *> part
let account = T.unwords $ firstPart : otherParts let account = T.unwords $ firstPart : otherParts
when (accountNameFromComponents (accountNameComponents account) /= account)
(fail $ "account name seems ill-formed: " ++ T.unpack account) let roundTripAccount =
accountNameFromComponents $ accountNameComponents account
when (account /= roundTripAccount) $ fail $
"account name seems ill-formed: " ++ T.unpack account
pure account pure account
where where
part = takeWhile1P Nothing (not . isSpace) part = takeWhile1P Nothing (not . isSpace)
@ -499,10 +485,9 @@ accountnamep = do
-- "missing" marker amount. -- "missing" marker amount.
spaceandamountormissingp :: Monad m => JournalParser m MixedAmount spaceandamountormissingp :: Monad m => JournalParser m MixedAmount
spaceandamountormissingp = spaceandamountormissingp =
try (do option missingmixedamt $ try $ do
lift $ skipSome spacenonewline lift $ skipSome spacenonewline
(Mixed . (:[])) `fmap` amountp <|> return missingmixedamt Mixed . (:[]) <$> amountp
) <|> return missingmixedamt
#ifdef TESTS #ifdef TESTS
assertParseEqual' :: (Show a, Eq a) => (Either ParseError a) -> a -> Assertion assertParseEqual' :: (Show a, Eq a) => (Either ParseError a) -> a -> Assertion
@ -556,10 +541,7 @@ signp = do
_ -> "" _ -> ""
multiplierp :: TextParser m Bool multiplierp :: TextParser m Bool
multiplierp = do multiplierp = option False $ char '*' *> pure True
multiplier <- optional $ oneOf ("*" :: [Char])
return $ case multiplier of Just '*' -> True
_ -> False
-- | This is like skipMany but it returns True if at least one element -- | This is like skipMany but it returns True if at least one element
-- was skipped. This is helpful if you’re just using many to check if -- was skipped. This is helpful if you’re just using many to check if
@ -622,38 +604,35 @@ commoditysymbolp = (quotedcommoditysymbolp <|> simplecommoditysymbolp) <?> "comm
quotedcommoditysymbolp :: TextParser m CommoditySymbol quotedcommoditysymbolp :: TextParser m CommoditySymbol
quotedcommoditysymbolp = quotedcommoditysymbolp =
between (char '"') (char '"') $ between (char '"') (char '"') $ takeWhile1P Nothing f
takeWhile1P Nothing $ \c -> c /= ';' && c /= '\n' && c /= '\"' where f c = c /= ';' && c /= '\n' && c /= '\"'
simplecommoditysymbolp :: TextParser m CommoditySymbol simplecommoditysymbolp :: TextParser m CommoditySymbol
simplecommoditysymbolp = takeWhile1P Nothing (not . isNonsimpleCommodityChar) simplecommoditysymbolp = takeWhile1P Nothing (not . isNonsimpleCommodityChar)
priceamountp :: Monad m => JournalParser m Price priceamountp :: Monad m => JournalParser m Price
priceamountp = priceamountp = option NoPrice $ try $ do
try (do lift (skipMany spacenonewline)
lift (skipMany spacenonewline) char '@'
char '@'
try (do m <- optional $ char '@'
char '@' let priceConstructor = case m of
lift (skipMany spacenonewline) Just _ -> TotalPrice
a <- amountp -- XXX can parse more prices ad infinitum, shouldn't Nothing -> UnitPrice
return $ TotalPrice a)
<|> (do lift (skipMany spacenonewline)
lift (skipMany spacenonewline) priceAmount <- amountp -- XXX can parse more prices ad infinitum, shouldn't
a <- amountp -- XXX can parse more prices ad infinitum, shouldn't
return $ UnitPrice a)) pure $ priceConstructor priceAmount
<|> return NoPrice
partialbalanceassertionp :: Monad m => JournalParser m BalanceAssertion partialbalanceassertionp :: Monad m => JournalParser m BalanceAssertion
partialbalanceassertionp = partialbalanceassertionp = optional $ try $ do
try (do lift (skipMany spacenonewline)
lift (skipMany spacenonewline) sourcepos <- genericSourcePos <$> lift getPosition
sourcepos <- genericSourcePos <$> lift getPosition char '='
char '=' lift (skipMany spacenonewline)
lift (skipMany spacenonewline) a <- amountp -- XXX should restrict to a simple amount
a <- amountp -- XXX should restrict to a simple amount return (a, sourcepos)
return $ Just (a, sourcepos))
<|> return Nothing
-- balanceassertion :: Monad m => TextParser m (Maybe MixedAmount) -- balanceassertion :: Monad m => TextParser m (Maybe MixedAmount)
-- balanceassertion = -- balanceassertion =
@ -667,18 +646,16 @@ partialbalanceassertionp =
-- http://ledger-cli.org/3.0/doc/ledger3.html#Fixing-Lot-Prices -- http://ledger-cli.org/3.0/doc/ledger3.html#Fixing-Lot-Prices
fixedlotpricep :: Monad m => JournalParser m (Maybe Amount) fixedlotpricep :: Monad m => JournalParser m (Maybe Amount)
fixedlotpricep = fixedlotpricep = optional $ try $ do
try (do lift (skipMany spacenonewline)
lift (skipMany spacenonewline) char '{'
char '{' lift (skipMany spacenonewline)
lift (skipMany spacenonewline) char '='
char '=' lift (skipMany spacenonewline)
lift (skipMany spacenonewline) a <- amountp -- XXX should restrict to a simple amount
a <- amountp -- XXX should restrict to a simple amount lift (skipMany spacenonewline)
lift (skipMany spacenonewline) char '}'
char '}' return a
return $ Just a)
<|> return Nothing
-- | Parse a string representation of a number for its value and display -- | Parse a string representation of a number for its value and display
-- attributes. -- attributes.
@ -733,53 +710,58 @@ fromRawNumber
fromRawNumber suggestedStyle negated raw = case raw of fromRawNumber suggestedStyle negated raw = case raw of
LeadingDecimalPt decPt digitGrp -> LeadingDecimalPt decPt digitGrp ->
let quantity = sign $ Decimal (fromIntegral precision) let quantity = sign $
(digitGroupNumber digitGrp) Decimal (fromIntegral precision) (digitGroupNumber digitGrp)
precision = digitGroupLength digitGrp precision = digitGroupLength digitGrp
in (quantity, precision, Just decPt, Nothing) in (quantity, precision, Just decPt, Nothing)
TrailingDecimalPt digitGrp decPt -> TrailingDecimalPt digitGrp decPt ->
let quantity = sign $ Decimal (fromIntegral precision) let quantity = sign $
(digitGroupNumber digitGrp) Decimal (fromIntegral precision) (digitGroupNumber digitGrp)
precision = 0 precision = 0
in (quantity, precision, Just decPt, Nothing) in (quantity, precision, Just decPt, Nothing)
NoSeparators digitGrp -> NoSeparators digitGrp ->
let quantity = sign $ Decimal (fromIntegral precision) let quantity = sign $
(digitGroupNumber digitGrp) Decimal (fromIntegral precision) (digitGroupNumber digitGrp)
precision = 0 precision = 0
in (quantity, precision, Nothing, Nothing) in (quantity, precision, Nothing, Nothing)
AmbiguousNumber digitGrp1 sep digitGrp2 -> AmbiguousNumber digitGrp1 sep digitGrp2
-- If present, use the suggested style to disambiguate; -- If present, use the suggested style to disambiguate;
-- otherwise, assume that the separator is a decimal point where possible. -- otherwise, assume that the separator is a decimal point where possible.
if isDecimalPointChar sep && maybe True (sep `isValidDecimalBy`) suggestedStyle | isDecimalPointChar sep
&& maybe True (sep `isValidDecimalBy`) suggestedStyle ->
then -- Assuming that the separator is a decimal point -- Assuming that the separator is a decimal point
let quantity = sign $ Decimal (fromIntegral precision) let quantity = sign $
(digitGroupNumber $ digitGrp1 <> digitGrp2) Decimal (fromIntegral precision)
(digitGroupNumber $ digitGrp1 <> digitGrp2)
precision = digitGroupLength digitGrp2 precision = digitGroupLength digitGrp2
in (quantity, precision, Just sep, Nothing) in (quantity, precision, Just sep, Nothing)
else -- Assuming that the separator is digit separator | otherwise ->
let quantity = sign $ Decimal (fromIntegral precision) -- Assuming that the separator is digit separator
(digitGroupNumber $ digitGrp1 <> digitGrp2) let quantity = sign $
Decimal (fromIntegral precision)
(digitGroupNumber $ digitGrp1 <> digitGrp2)
precision = 0 precision = 0
digitGroupStyle = Just $ digitGroupStyle = Just $
DigitGroups sep (groupSizes $ [digitGrp1, digitGrp2]) DigitGroups sep (groupSizes $ [digitGrp1, digitGrp2])
in (quantity, precision, Nothing, digitGroupStyle) in (quantity, precision, Nothing, digitGroupStyle)
DigitSeparators digitSep digitGrps -> DigitSeparators digitSep digitGrps ->
let quantity = sign $ Decimal (fromIntegral precision) let quantity = sign $
(digitGroupNumber $ mconcat digitGrps) Decimal (fromIntegral precision)
(digitGroupNumber $ mconcat digitGrps)
precision = 0 precision = 0
digitGroupStyle = Just $ DigitGroups digitSep (groupSizes digitGrps) digitGroupStyle = Just $ DigitGroups digitSep (groupSizes digitGrps)
in (quantity, precision, Nothing, digitGroupStyle) in (quantity, precision, Nothing, digitGroupStyle)
BothSeparators digitSep digitGrps decPt decimalGrp -> BothSeparators digitSep digitGrps decPt decimalGrp ->
let quantity = let quantity = sign $
sign $ Decimal (fromIntegral precision) Decimal (fromIntegral precision)
(digitGroupNumber $ mconcat digitGrps <> decimalGrp) (digitGroupNumber $ mconcat digitGrps <> decimalGrp)
precision = digitGroupLength decimalGrp precision = digitGroupLength decimalGrp
digitGroupStyle = Just $ DigitGroups digitSep (groupSizes digitGrps) digitGroupStyle = Just $ DigitGroups digitSep (groupSizes digitGrps)
in (quantity, precision, Just decPt, digitGroupStyle) in (quantity, precision, Just decPt, digitGroupStyle)
@ -860,7 +842,6 @@ rawnumberp = label "rawnumberp" $ do
| null grps = AmbiguousNumber grp1 sep grp2 | null grps = AmbiguousNumber grp1 sep grp2
| otherwise = DigitSeparators sep (grp1:grp2:grps) | otherwise = DigitSeparators sep (grp1:grp2:grps)
trailingDecimalPt :: DigitGrp -> TextParser m RawNumber trailingDecimalPt :: DigitGrp -> TextParser m RawNumber
trailingDecimalPt grp1 = do trailingDecimalPt grp1 = do
decimalPt <- satisfy isDecimalPointChar decimalPt <- satisfy isDecimalPointChar
@ -937,10 +918,10 @@ data RawNumber
multilinecommentp :: TextParser m () multilinecommentp :: TextParser m ()
multilinecommentp = startComment *> anyLine `skipManyTill` endComment multilinecommentp = startComment *> anyLine `skipManyTill` endComment
where where
startComment = string "comment" >> emptyLine startComment = string "comment" >> skipLine
endComment = eof <|> (string "end comment" >> emptyLine) endComment = eof <|> string "end comment" *> skipLine
emptyLine = void $ skipMany spacenonewline *> newline skipLine = void $ skipMany spacenonewline *> newline
anyLine = takeWhileP Nothing (\c -> c /= '\n') *> newline anyLine = takeWhileP Nothing (\c -> c /= '\n') *> newline
emptyorcommentlinep :: TextParser m () emptyorcommentlinep :: TextParser m ()
@ -1140,9 +1121,8 @@ bracketedpostingdatesp :: Maybe Day -> SimpleTextParser [(TagName,Day)]
bracketedpostingdatesp mdefdate = do bracketedpostingdatesp mdefdate = do
-- pdbg 0 $ "bracketedpostingdatesp" -- pdbg 0 $ "bracketedpostingdatesp"
skipMany $ notChar '[' skipMany $ notChar '['
fmap concat concat <$> sepEndBy (bracketeddatetagsp mdefdate <|> char '[' *> pure [])
$ sepEndBy (bracketeddatetagsp mdefdate <|> char '[' *> pure []) (skipMany $ notChar '[')
(skipMany $ notChar '[')
--- ** bracketed dates --- ** bracketed dates

2
hledger-lib/Hledger/Read/JournalReader.hs
View File

@ -475,7 +475,7 @@ transactionp = do
-- ptrace "transactionp" -- ptrace "transactionp"
pos <- getPosition pos <- getPosition
date <- datep <?> "transaction" date <- datep <?> "transaction"
edate <- optional (secondarydatep date) <?> "secondary date" edate <- optional (lift $ secondarydatep date) <?> "secondary date"
lookAhead (lift spacenonewline <|> newline) <?> "whitespace or newline" lookAhead (lift spacenonewline <|> newline) <?> "whitespace or newline"
status <- lift statusp <?> "cleared status" status <- lift statusp <?> "cleared status"
code <- lift codep <?> "transaction code" code <- lift codep <?> "transaction code"