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

removing "re-parsing" for pull 807

Browse Source 
For Data/Dates.hs in particular:
- Changed `SimpleTextParser` to `TextParser m` for all parsers
- Changed `string` to the case-insensitive `string'` to match the
  behaviour of `T.toLower` found in `parsePeriodExpr`
- export `periodexprp` for "direct" use
This commit is contained in:
Alex Chen 2018-06-12 13:29:22 -06:00 committed by Simon Michael
parent 34b4553344
commit c6bfd92dd3
2 changed files with 84 additions and 86 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

111
hledger-lib/Hledger/Data/Dates.hs
View File

@ -44,6 +44,7 @@ module Hledger.Data.Dates (
showDateSpanMonthAbbrev, showDateSpanMonthAbbrev,
elapsedSeconds, elapsedSeconds,
prevday, prevday,
periodexprp,
parsePeriodExpr, parsePeriodExpr,
parsePeriodExpr', parsePeriodExpr',
nulldatespan, nulldatespan,
@ -730,14 +731,14 @@ Big numbers not beginning with a valid YYYYMMDD are parsed as a year:
Right ("201813012","","") Right ("201813012","","")
-} -}
smartdate :: SimpleTextParser SmartDate smartdate :: TextParser m SmartDate
smartdate = do smartdate = do
-- XXX maybe obscures date errors ? see ledgerdate -- XXX maybe obscures date errors ? see ledgerdate
(y,m,d) <- choice' [yyyymmdd, yyyymm, ymd, ym, md, y, d, month, mon, today, yesterday, tomorrow, lastthisnextthing] (y,m,d) <- choice' [yyyymmdd, yyyymm, ymd, ym, md, y, d, month, mon, today, yesterday, tomorrow, lastthisnextthing]
return (y,m,d) return (y,m,d)
-- | Like smartdate, but there must be nothing other than whitespace after the date. -- | Like smartdate, but there must be nothing other than whitespace after the date.
smartdateonly :: SimpleTextParser SmartDate smartdateonly :: TextParser m SmartDate
smartdateonly = do smartdateonly = do
d <- smartdate d <- smartdate
skipMany spacenonewline skipMany spacenonewline
@ -763,7 +764,7 @@ failIfInvalidYear s = unless (validYear s) $ fail $ "bad year number: " ++ s
failIfInvalidMonth s = unless (validMonth s) $ fail $ "bad month number: " ++ s failIfInvalidMonth s = unless (validMonth s) $ fail $ "bad month number: " ++ s
failIfInvalidDay s = unless (validDay s) $ fail $ "bad day number: " ++ s failIfInvalidDay s = unless (validDay s) $ fail $ "bad day number: " ++ s
yyyymmdd :: SimpleTextParser SmartDate yyyymmdd :: TextParser m SmartDate
yyyymmdd = do yyyymmdd = do
y <- count 4 digitChar y <- count 4 digitChar
m <- count 2 digitChar m <- count 2 digitChar
@ -772,14 +773,14 @@ yyyymmdd = do
failIfInvalidDay d failIfInvalidDay d
return (y,m,d) return (y,m,d)
yyyymm :: SimpleTextParser SmartDate yyyymm :: TextParser m SmartDate
yyyymm = do yyyymm = do
y <- count 4 digitChar y <- count 4 digitChar
m <- count 2 digitChar m <- count 2 digitChar
failIfInvalidMonth m failIfInvalidMonth m
return (y,m,"01") return (y,m,"01")
ymd :: SimpleTextParser SmartDate ymd :: TextParser m SmartDate
ymd = do ymd = do
y <- some digitChar y <- some digitChar
failIfInvalidYear y failIfInvalidYear y
@ -791,7 +792,7 @@ ymd = do
failIfInvalidDay d failIfInvalidDay d
return $ (y,m,d) return $ (y,m,d)
ym :: SimpleTextParser SmartDate ym :: TextParser m SmartDate
ym = do ym = do
y <- some digitChar y <- some digitChar
failIfInvalidYear y failIfInvalidYear y
@ -800,19 +801,19 @@ ym = do
failIfInvalidMonth m failIfInvalidMonth m
return (y,m,"") return (y,m,"")
y :: SimpleTextParser SmartDate y :: TextParser m SmartDate
y = do y = do
y <- some digitChar y <- some digitChar
failIfInvalidYear y failIfInvalidYear y
return (y,"","") return (y,"","")
d :: SimpleTextParser SmartDate d :: TextParser m SmartDate
d = do d = do
d <- some digitChar d <- some digitChar
failIfInvalidDay d failIfInvalidDay d
return ("","",d) return ("","",d)
md :: SimpleTextParser SmartDate md :: TextParser m SmartDate
md = do md = do
m <- some digitChar m <- some digitChar
failIfInvalidMonth m failIfInvalidMonth m
@ -830,38 +831,38 @@ weekdayabbrevs = ["mon","tue","wed","thu","fri","sat","sun"]
monthIndex t = maybe 0 (+1) $ t `elemIndex` months monthIndex t = maybe 0 (+1) $ t `elemIndex` months
monIndex t = maybe 0 (+1) $ t `elemIndex` monthabbrevs monIndex t = maybe 0 (+1) $ t `elemIndex` monthabbrevs
month :: SimpleTextParser SmartDate month :: TextParser m SmartDate
month = do month = do
m <- choice $ map (try . string) months m <- choice $ map (try . string') months
let i = monthIndex m let i = monthIndex m
return ("",show i,"") return ("",show i,"")
mon :: SimpleTextParser SmartDate mon :: TextParser m SmartDate
mon = do mon = do
m <- choice $ map (try . string) monthabbrevs m <- choice $ map (try . string') monthabbrevs
let i = monIndex m let i = monIndex m
return ("",show i,"") return ("",show i,"")
weekday :: SimpleTextParser Int weekday :: TextParser m Int
weekday = do weekday = do
wday <- choice . map string' $ weekdays ++ weekdayabbrevs wday <- choice . map string' $ weekdays ++ weekdayabbrevs
let i = head . catMaybes $ [wday `elemIndex` weekdays, wday `elemIndex` weekdayabbrevs] let i = head . catMaybes $ [wday `elemIndex` weekdays, wday `elemIndex` weekdayabbrevs]
return (i+1) return (i+1)
today,yesterday,tomorrow :: SimpleTextParser SmartDate today,yesterday,tomorrow :: TextParser m SmartDate
today = string "today" >> return ("","","today") today = string' "today" >> return ("","","today")
yesterday = string "yesterday" >> return ("","","yesterday") yesterday = string' "yesterday" >> return ("","","yesterday")
tomorrow = string "tomorrow" >> return ("","","tomorrow") tomorrow = string' "tomorrow" >> return ("","","tomorrow")
lastthisnextthing :: SimpleTextParser SmartDate lastthisnextthing :: TextParser m SmartDate
lastthisnextthing = do lastthisnextthing = do
r <- choice $ map string [ r <- choice $ map string' [
"last" "last"
,"this" ,"this"
,"next" ,"next"
] ]
skipMany spacenonewline -- make the space optional for easier scripting skipMany spacenonewline -- make the space optional for easier scripting
p <- choice $ map string [ p <- choice $ map string' [
"day" "day"
,"week" ,"week"
,"month" ,"month"
@ -869,7 +870,7 @@ lastthisnextthing = do
,"year" ,"year"
] ]
-- XXX support these in fixSmartDate -- XXX support these in fixSmartDate
-- ++ (map string $ months ++ monthabbrevs ++ weekdays ++ weekdayabbrevs) -- ++ (map string' $ months ++ monthabbrevs ++ weekdays ++ weekdayabbrevs)
return ("", T.unpack r, T.unpack p) return ("", T.unpack r, T.unpack p)
@ -917,13 +918,13 @@ lastthisnextthing = do
-- Right (DayOfMonth 2,DateSpan 2009/01/01-) -- Right (DayOfMonth 2,DateSpan 2009/01/01-)
-- >>> p "every 2nd day of month 2009-" -- >>> p "every 2nd day of month 2009-"
-- Right (DayOfMonth 2,DateSpan 2009/01/01-) -- Right (DayOfMonth 2,DateSpan 2009/01/01-)
periodexprp :: Day -> SimpleTextParser (Interval, DateSpan) periodexprp :: Day -> TextParser m (Interval, DateSpan)
periodexprp rdate = surroundedBy (skipMany spacenonewline) . choice $ map try [ periodexprp rdate = surroundedBy (skipMany spacenonewline) . choice $ map try [
intervalanddateperiodexprp rdate, intervalanddateperiodexprp rdate,
(,) NoInterval <$> periodexprdatespanp rdate (,) NoInterval <$> periodexprdatespanp rdate
] ]
intervalanddateperiodexprp :: Day -> SimpleTextParser (Interval, DateSpan) intervalanddateperiodexprp :: Day -> TextParser m (Interval, DateSpan)
intervalanddateperiodexprp rdate = do intervalanddateperiodexprp rdate = do
i <- reportingintervalp i <- reportingintervalp
s <- option def . try $ do s <- option def . try $ do
@ -932,46 +933,46 @@ intervalanddateperiodexprp rdate = do
return (i,s) return (i,s)
-- Parse a reporting interval. -- Parse a reporting interval.
reportingintervalp :: SimpleTextParser Interval reportingintervalp :: TextParser m Interval
reportingintervalp = choice' [ reportingintervalp = choice' [
tryinterval "day" "daily" Days, tryinterval "day" "daily" Days,
tryinterval "week" "weekly" Weeks, tryinterval "week" "weekly" Weeks,
tryinterval "month" "monthly" Months, tryinterval "month" "monthly" Months,
tryinterval "quarter" "quarterly" Quarters, tryinterval "quarter" "quarterly" Quarters,
tryinterval "year" "yearly" Years, tryinterval "year" "yearly" Years,
do string "biweekly" do string' "biweekly"
return $ Weeks 2, return $ Weeks 2,
do string "bimonthly" do string' "bimonthly"
return $ Months 2, return $ Months 2,
do string "every" do string' "every"
skipMany spacenonewline skipMany spacenonewline
n <- nth n <- nth
skipMany spacenonewline skipMany spacenonewline
string "day" string' "day"
of_ "week" of_ "week"
return $ DayOfWeek n, return $ DayOfWeek n,
do string "every" do string' "every"
skipMany spacenonewline skipMany spacenonewline
n <- weekday n <- weekday
return $ DayOfWeek n, return $ DayOfWeek n,
do string "every" do string' "every"
skipMany spacenonewline skipMany spacenonewline
n <- nth n <- nth
skipMany spacenonewline skipMany spacenonewline
string "day" string' "day"
optOf_ "month" optOf_ "month"
return $ DayOfMonth n, return $ DayOfMonth n,
do string "every" do string' "every"
let mnth = choice' [month, mon] >>= \(_,m,_) -> return (read m) let mnth = choice' [month, mon] >>= \(_,m,_) -> return (read m)
d_o_y <- makePermParser $ DayOfYear <$$> try (skipMany spacenonewline *> mnth) <||> try (skipMany spacenonewline *> nth) d_o_y <- makePermParser $ DayOfYear <$$> try (skipMany spacenonewline *> mnth) <||> try (skipMany spacenonewline *> nth)
optOf_ "year" optOf_ "year"
return d_o_y, return d_o_y,
do string "every" do string' "every"
skipMany spacenonewline skipMany spacenonewline
("",m,d) <- md ("",m,d) <- md
optOf_ "year" optOf_ "year"
return $ DayOfYear (read m) (read d), return $ DayOfYear (read m) (read d),
do string "every" do string' "every"
skipMany spacenonewline skipMany spacenonewline
n <- nth n <- nth
skipMany spacenonewline skipMany spacenonewline
@ -982,31 +983,31 @@ reportingintervalp = choice' [
where where
of_ period = do of_ period = do
skipMany spacenonewline skipMany spacenonewline
string "of" string' "of"
skipMany spacenonewline skipMany spacenonewline
string period string' period
optOf_ period = optional $ try $ of_ period optOf_ period = optional $ try $ of_ period
nth = do n <- some digitChar nth = do n <- some digitChar
choice' $ map string ["st","nd","rd","th"] choice' $ map string' ["st","nd","rd","th"]
return $ read n return $ read n
-- Parse any of several variants of a basic interval, eg "daily", "every day", "every N days". -- Parse any of several variants of a basic interval, eg "daily", "every day", "every N days".
tryinterval :: String -> String -> (Int -> Interval) -> SimpleTextParser Interval tryinterval :: String -> String -> (Int -> Interval) -> TextParser m Interval
tryinterval singular compact intcons = tryinterval singular compact intcons =
choice' [ choice' [
do string compact' do string' compact'
return $ intcons 1, return $ intcons 1,
do string "every" do string' "every"
skipMany spacenonewline skipMany spacenonewline
string singular' string' singular'
return $ intcons 1, return $ intcons 1,
do string "every" do string' "every"
skipMany spacenonewline skipMany spacenonewline
n <- fmap read $ some digitChar n <- fmap read $ some digitChar
skipMany spacenonewline skipMany spacenonewline
string plural' string' plural'
return $ intcons n return $ intcons n
] ]
where where
@ -1014,7 +1015,7 @@ reportingintervalp = choice' [
singular' = T.pack singular singular' = T.pack singular
plural' = T.pack $ singular ++ "s" plural' = T.pack $ singular ++ "s"
periodexprdatespanp :: Day -> SimpleTextParser DateSpan periodexprdatespanp :: Day -> TextParser m DateSpan
periodexprdatespanp rdate = choice $ map try [ periodexprdatespanp rdate = choice $ map try [
doubledatespanp rdate, doubledatespanp rdate,
fromdatespanp rdate, fromdatespanp rdate,
@ -1025,38 +1026,38 @@ periodexprdatespanp rdate = choice $ map try [
-- | -- |
-- -- >>> parsewith (doubledatespan (parsedate "2018/01/01") <* eof) "20180101-201804" -- -- >>> parsewith (doubledatespan (parsedate "2018/01/01") <* eof) "20180101-201804"
-- Right DateSpan 2018/01/01-2018/04/01 -- Right DateSpan 2018/01/01-2018/04/01
doubledatespanp :: Day -> SimpleTextParser DateSpan doubledatespanp :: Day -> TextParser m DateSpan
doubledatespanp rdate = do doubledatespanp rdate = do
optional (string "from" >> skipMany spacenonewline) optional (string' "from" >> skipMany spacenonewline)
b <- smartdate b <- smartdate
skipMany spacenonewline skipMany spacenonewline
optional (choice [string "to", string "-"] >> skipMany spacenonewline) optional (choice [string' "to", string' "-"] >> skipMany spacenonewline)
e <- smartdate e <- smartdate
return $ DateSpan (Just $ fixSmartDate rdate b) (Just $ fixSmartDate rdate e) return $ DateSpan (Just $ fixSmartDate rdate b) (Just $ fixSmartDate rdate e)
fromdatespanp :: Day -> SimpleTextParser DateSpan fromdatespanp :: Day -> TextParser m DateSpan
fromdatespanp rdate = do fromdatespanp rdate = do
b <- choice [ b <- choice [
do do
string "from" >> skipMany spacenonewline string' "from" >> skipMany spacenonewline
smartdate smartdate
, ,
do do
d <- smartdate d <- smartdate
string "-" string' "-"
return d return d
] ]
return $ DateSpan (Just $ fixSmartDate rdate b) Nothing return $ DateSpan (Just $ fixSmartDate rdate b) Nothing
todatespanp :: Day -> SimpleTextParser DateSpan todatespanp :: Day -> TextParser m DateSpan
todatespanp rdate = do todatespanp rdate = do
choice [string "to", string "-"] >> skipMany spacenonewline choice [string' "to", string' "-"] >> skipMany spacenonewline
e <- smartdate e <- smartdate
return $ DateSpan Nothing (Just $ fixSmartDate rdate e) return $ DateSpan Nothing (Just $ fixSmartDate rdate e)
justdatespanp :: Day -> SimpleTextParser DateSpan justdatespanp :: Day -> TextParser m DateSpan
justdatespanp rdate = do justdatespanp rdate = do
optional (string "in" >> skipMany spacenonewline) optional (string' "in" >> skipMany spacenonewline)
d <- smartdate d <- smartdate
return $ spanFromSmartDate rdate d return $ spanFromSmartDate rdate d

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

@ -75,6 +75,7 @@ import qualified Control.Exception as C
import Control.Monad import Control.Monad
import Control.Monad.Except (ExceptT(..)) import Control.Monad.Except (ExceptT(..))
import Control.Monad.State.Strict import Control.Monad.State.Strict
import Data.Bifunctor (first)
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import Data.Text (Text) import Data.Text (Text)
import Data.String import Data.String
@ -461,25 +462,21 @@ periodictransactionp :: MonadIO m => JournalParser m PeriodicTransaction
periodictransactionp = do periodictransactionp = do
char '~' <?> "periodic transaction" char '~' <?> "periodic transaction"
lift $ skipMany spacenonewline lift $ skipMany spacenonewline
-- XXX periodexprp in Hledger.Data.Dates is a SimpleTextParser, which we can't call directly here.
-- Instead, read until two or more spaces and reparse that. More use of two spaces is not ideal.
pos <- getPosition pos <- getPosition
periodtxt <- lift singlespacedtextp
d <- liftIO getCurrentDay d <- liftIO getCurrentDay
(interval, span) <-
case parsePeriodExpr d periodtxt of -- T.strip is for removing the trailing two spaces
Right (i,s) -> return (i,s) (periodtxt, (interval, span)) <- lift $ first T.strip <$> match (periodexprp d)
Left e ->
-- Show an informative error. XXX a bit unidiomatic, check for megaparsec helpers -- not yet sure how I should add context ("while parsing a period expression") and
fail $ -- XXX -- suggestions ("2+ spaces are needed ...") to `TrivialError` parse errors
showGenericSourcePos (genericSourcePos pos) ++ ":\n" ++
(unlines $ drop 1 $ lines $ parseErrorPretty e) ++
"while parsing a period expression in: "++T.unpack periodtxt++"\n" ++
"2+ spaces are needed between period expression and any description/comment."
-- In periodic transactions, the period expression has an additional constraint: -- In periodic transactions, the period expression has an additional constraint:
case checkPeriodicTransactionStartDate interval span periodtxt of case checkPeriodicTransactionStartDate interval span periodtxt of
Just e -> fail e -- XXX Just e -> parseErrorAt pos e
Nothing -> do Nothing -> pure ()
status <- lift statusp status <- lift statusp
code <- lift codep code <- lift codep
description <- lift $ T.strip <$> descriptionp description <- lift $ T.strip <$> descriptionp