* Replace Parsec with Megaparsec (see #289) This builds upon PR #289 by @rasendubi * Revert renaming of parseWithState to parseWithCtx * Fix doctests * Update for Megaparsec 5 * Specialize parser to improve performance * Pretty print errors * Swap StateT and ParsecT This is necessary to get the correct backtracking behavior, i.e. discard state changes if the parsing fails.
This commit is contained in:
parent
90c0d40777
commit
4141067428
@ -1,6 +1,8 @@
|
|||||||
{-# LANGUAGE CPP #-}
|
{-# LANGUAGE CPP #-}
|
||||||
{-# LANGUAGE NoMonoLocalBinds #-}
|
{-# LANGUAGE NoMonoLocalBinds #-}
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-|
|
{-|
|
||||||
|
|
||||||
Date parsing and utilities for hledger.
|
Date parsing and utilities for hledger.
|
||||||
@ -68,6 +70,8 @@ import Prelude.Compat
|
|||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Data.List.Compat
|
import Data.List.Compat
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
|
import Data.Text (Text)
|
||||||
|
import qualified Data.Text as T
|
||||||
#if MIN_VERSION_time(1,5,0)
|
#if MIN_VERSION_time(1,5,0)
|
||||||
import Data.Time.Format hiding (months)
|
import Data.Time.Format hiding (months)
|
||||||
#else
|
#else
|
||||||
@ -80,7 +84,8 @@ import Data.Time.Calendar.WeekDate
|
|||||||
import Data.Time.Clock
|
import Data.Time.Clock
|
||||||
import Data.Time.LocalTime
|
import Data.Time.LocalTime
|
||||||
import Safe (headMay, lastMay, readMay)
|
import Safe (headMay, lastMay, readMay)
|
||||||
import Text.Parsec
|
import Text.Megaparsec
|
||||||
|
import Text.Megaparsec.Text
|
||||||
import Text.Printf
|
import Text.Printf
|
||||||
|
|
||||||
import Hledger.Data.Types
|
import Hledger.Data.Types
|
||||||
@ -298,10 +303,10 @@ earliest (Just d1) (Just d2) = Just $ min d1 d2
|
|||||||
|
|
||||||
-- | Parse a period expression to an Interval and overall DateSpan using
|
-- | Parse a period expression to an Interval and overall DateSpan using
|
||||||
-- the provided reference date, or return a parse error.
|
-- the provided reference date, or return a parse error.
|
||||||
parsePeriodExpr :: Day -> String -> Either ParseError (Interval, DateSpan)
|
parsePeriodExpr :: Day -> Text -> Either (ParseError Char Dec) (Interval, DateSpan)
|
||||||
parsePeriodExpr refdate = parsewith (periodexpr refdate <* eof)
|
parsePeriodExpr refdate = parsewith (periodexpr refdate <* eof)
|
||||||
|
|
||||||
maybePeriod :: Day -> String -> Maybe (Interval,DateSpan)
|
maybePeriod :: Day -> Text -> Maybe (Interval,DateSpan)
|
||||||
maybePeriod refdate = either (const Nothing) Just . parsePeriodExpr refdate
|
maybePeriod refdate = either (const Nothing) Just . parsePeriodExpr refdate
|
||||||
|
|
||||||
-- | Show a DateSpan as a human-readable pseudo-period-expression string.
|
-- | Show a DateSpan as a human-readable pseudo-period-expression string.
|
||||||
@ -354,18 +359,18 @@ spanFromSmartDate refdate sdate = DateSpan (Just b) (Just e)
|
|||||||
|
|
||||||
-- | Convert a smart date string to an explicit yyyy\/mm\/dd string using
|
-- | Convert a smart date string to an explicit yyyy\/mm\/dd string using
|
||||||
-- the provided reference date, or raise an error.
|
-- the provided reference date, or raise an error.
|
||||||
fixSmartDateStr :: Day -> String -> String
|
fixSmartDateStr :: Day -> Text -> String
|
||||||
fixSmartDateStr d s = either
|
fixSmartDateStr d s = either
|
||||||
(\e->error' $ printf "could not parse date %s %s" (show s) (show e))
|
(\e->error' $ printf "could not parse date %s %s" (show s) (show e))
|
||||||
id
|
id
|
||||||
$ fixSmartDateStrEither d s
|
$ (fixSmartDateStrEither d s :: Either (ParseError Char Dec) String)
|
||||||
|
|
||||||
-- | A safe version of fixSmartDateStr.
|
-- | A safe version of fixSmartDateStr.
|
||||||
fixSmartDateStrEither :: Day -> String -> Either ParseError String
|
fixSmartDateStrEither :: Day -> Text -> Either (ParseError Char Dec) String
|
||||||
fixSmartDateStrEither d = either Left (Right . showDate) . fixSmartDateStrEither' d
|
fixSmartDateStrEither d = either Left (Right . showDate) . fixSmartDateStrEither' d
|
||||||
|
|
||||||
fixSmartDateStrEither' :: Day -> String -> Either ParseError Day
|
fixSmartDateStrEither' :: Day -> Text -> Either (ParseError Char Dec) Day
|
||||||
fixSmartDateStrEither' d s = case parsewith smartdateonly (lowercase s) of
|
fixSmartDateStrEither' d s = case parsewith smartdateonly (T.toLower s) of
|
||||||
Right sd -> Right $ fixSmartDate d sd
|
Right sd -> Right $ fixSmartDate d sd
|
||||||
Left e -> Left e
|
Left e -> Left e
|
||||||
|
|
||||||
@ -591,22 +596,23 @@ and maybe some others:
|
|||||||
Returns a SmartDate, to be converted to a full date later (see fixSmartDate).
|
Returns a SmartDate, to be converted to a full date later (see fixSmartDate).
|
||||||
Assumes any text in the parse stream has been lowercased.
|
Assumes any text in the parse stream has been lowercased.
|
||||||
-}
|
-}
|
||||||
smartdate :: Stream s m Char => ParsecT s st m SmartDate
|
smartdate :: Parser SmartDate
|
||||||
smartdate = do
|
smartdate = do
|
||||||
-- XXX maybe obscures date errors ? see ledgerdate
|
-- XXX maybe obscures date errors ? see ledgerdate
|
||||||
(y,m,d) <- choice' [yyyymmdd, ymd, ym, md, y, d, month, mon, today, yesterday, tomorrow, lastthisnextthing]
|
(y,m,d) <- choice' [yyyymmdd, 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 :: Stream s m Char => ParsecT s st m SmartDate
|
smartdateonly :: Parser SmartDate
|
||||||
smartdateonly = do
|
smartdateonly = do
|
||||||
d <- smartdate
|
d <- smartdate
|
||||||
many spacenonewline
|
many spacenonewline
|
||||||
eof
|
eof
|
||||||
return d
|
return d
|
||||||
|
|
||||||
|
datesepchars :: [Char]
|
||||||
datesepchars = "/-."
|
datesepchars = "/-."
|
||||||
datesepchar :: Stream s m Char => ParsecT s st m Char
|
datesepchar :: TextParser m Char
|
||||||
datesepchar = oneOf datesepchars
|
datesepchar = oneOf datesepchars
|
||||||
|
|
||||||
validYear, validMonth, validDay :: String -> Bool
|
validYear, validMonth, validDay :: String -> Bool
|
||||||
@ -619,54 +625,54 @@ 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 :: Stream s m Char => ParsecT s st m SmartDate
|
yyyymmdd :: Parser SmartDate
|
||||||
yyyymmdd = do
|
yyyymmdd = do
|
||||||
y <- count 4 digit
|
y <- count 4 digitChar
|
||||||
m <- count 2 digit
|
m <- count 2 digitChar
|
||||||
failIfInvalidMonth m
|
failIfInvalidMonth m
|
||||||
d <- count 2 digit
|
d <- count 2 digitChar
|
||||||
failIfInvalidDay d
|
failIfInvalidDay d
|
||||||
return (y,m,d)
|
return (y,m,d)
|
||||||
|
|
||||||
ymd :: Stream s m Char => ParsecT s st m SmartDate
|
ymd :: Parser SmartDate
|
||||||
ymd = do
|
ymd = do
|
||||||
y <- many1 digit
|
y <- some digitChar
|
||||||
failIfInvalidYear y
|
failIfInvalidYear y
|
||||||
sep <- datesepchar
|
sep <- datesepchar
|
||||||
m <- many1 digit
|
m <- some digitChar
|
||||||
failIfInvalidMonth m
|
failIfInvalidMonth m
|
||||||
char sep
|
char sep
|
||||||
d <- many1 digit
|
d <- some digitChar
|
||||||
failIfInvalidDay d
|
failIfInvalidDay d
|
||||||
return $ (y,m,d)
|
return $ (y,m,d)
|
||||||
|
|
||||||
ym :: Stream s m Char => ParsecT s st m SmartDate
|
ym :: Parser SmartDate
|
||||||
ym = do
|
ym = do
|
||||||
y <- many1 digit
|
y <- some digitChar
|
||||||
failIfInvalidYear y
|
failIfInvalidYear y
|
||||||
datesepchar
|
datesepchar
|
||||||
m <- many1 digit
|
m <- some digitChar
|
||||||
failIfInvalidMonth m
|
failIfInvalidMonth m
|
||||||
return (y,m,"")
|
return (y,m,"")
|
||||||
|
|
||||||
y :: Stream s m Char => ParsecT s st m SmartDate
|
y :: Parser SmartDate
|
||||||
y = do
|
y = do
|
||||||
y <- many1 digit
|
y <- some digitChar
|
||||||
failIfInvalidYear y
|
failIfInvalidYear y
|
||||||
return (y,"","")
|
return (y,"","")
|
||||||
|
|
||||||
d :: Stream s m Char => ParsecT s st m SmartDate
|
d :: Parser SmartDate
|
||||||
d = do
|
d = do
|
||||||
d <- many1 digit
|
d <- some digitChar
|
||||||
failIfInvalidDay d
|
failIfInvalidDay d
|
||||||
return ("","",d)
|
return ("","",d)
|
||||||
|
|
||||||
md :: Stream s m Char => ParsecT s st m SmartDate
|
md :: Parser SmartDate
|
||||||
md = do
|
md = do
|
||||||
m <- many1 digit
|
m <- some digitChar
|
||||||
failIfInvalidMonth m
|
failIfInvalidMonth m
|
||||||
datesepchar
|
datesepchar
|
||||||
d <- many1 digit
|
d <- some digitChar
|
||||||
failIfInvalidDay d
|
failIfInvalidDay d
|
||||||
return ("",m,d)
|
return ("",m,d)
|
||||||
|
|
||||||
@ -679,24 +685,24 @@ monthabbrevs = ["jan","feb","mar","apr","may","jun","jul","aug","sep","oct","n
|
|||||||
monthIndex s = maybe 0 (+1) $ lowercase s `elemIndex` months
|
monthIndex s = maybe 0 (+1) $ lowercase s `elemIndex` months
|
||||||
monIndex s = maybe 0 (+1) $ lowercase s `elemIndex` monthabbrevs
|
monIndex s = maybe 0 (+1) $ lowercase s `elemIndex` monthabbrevs
|
||||||
|
|
||||||
month :: Stream s m Char => ParsecT s st m SmartDate
|
month :: Parser 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 :: Stream s m Char => ParsecT s st m SmartDate
|
mon :: Parser 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,"")
|
||||||
|
|
||||||
today,yesterday,tomorrow :: Stream s m Char => ParsecT s st m SmartDate
|
today,yesterday,tomorrow :: Parser 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 :: Stream s m Char => ParsecT s st m SmartDate
|
lastthisnextthing :: Parser SmartDate
|
||||||
lastthisnextthing = do
|
lastthisnextthing = do
|
||||||
r <- choice [
|
r <- choice [
|
||||||
string "last"
|
string "last"
|
||||||
@ -717,7 +723,7 @@ lastthisnextthing = do
|
|||||||
return ("",r,p)
|
return ("",r,p)
|
||||||
|
|
||||||
-- |
|
-- |
|
||||||
-- >>> let p = parsewith (periodexpr (parsedate "2008/11/26"))
|
-- >>> let p = parsewith (periodexpr (parsedate "2008/11/26")) :: T.Text -> Either (ParseError Char Dec) (Interval, DateSpan)
|
||||||
-- >>> p "from aug to oct"
|
-- >>> p "from aug to oct"
|
||||||
-- Right (NoInterval,DateSpan 2008/08/01-2008/09/30)
|
-- Right (NoInterval,DateSpan 2008/08/01-2008/09/30)
|
||||||
-- >>> p "aug to oct"
|
-- >>> p "aug to oct"
|
||||||
@ -728,7 +734,7 @@ lastthisnextthing = do
|
|||||||
-- Right (Days 1,DateSpan 2008/08/01-)
|
-- Right (Days 1,DateSpan 2008/08/01-)
|
||||||
-- >>> p "every week to 2009"
|
-- >>> p "every week to 2009"
|
||||||
-- Right (Weeks 1,DateSpan -2008/12/31)
|
-- Right (Weeks 1,DateSpan -2008/12/31)
|
||||||
periodexpr :: Stream s m Char => Day -> ParsecT s st m (Interval, DateSpan)
|
periodexpr :: Day -> Parser (Interval, DateSpan)
|
||||||
periodexpr rdate = choice $ map try [
|
periodexpr rdate = choice $ map try [
|
||||||
intervalanddateperiodexpr rdate,
|
intervalanddateperiodexpr rdate,
|
||||||
intervalperiodexpr,
|
intervalperiodexpr,
|
||||||
@ -736,7 +742,7 @@ periodexpr rdate = choice $ map try [
|
|||||||
(return (NoInterval,DateSpan Nothing Nothing))
|
(return (NoInterval,DateSpan Nothing Nothing))
|
||||||
]
|
]
|
||||||
|
|
||||||
intervalanddateperiodexpr :: Stream s m Char => Day -> ParsecT s st m (Interval, DateSpan)
|
intervalanddateperiodexpr :: Day -> Parser (Interval, DateSpan)
|
||||||
intervalanddateperiodexpr rdate = do
|
intervalanddateperiodexpr rdate = do
|
||||||
many spacenonewline
|
many spacenonewline
|
||||||
i <- reportinginterval
|
i <- reportinginterval
|
||||||
@ -744,20 +750,20 @@ intervalanddateperiodexpr rdate = do
|
|||||||
s <- periodexprdatespan rdate
|
s <- periodexprdatespan rdate
|
||||||
return (i,s)
|
return (i,s)
|
||||||
|
|
||||||
intervalperiodexpr :: Stream s m Char => ParsecT s st m (Interval, DateSpan)
|
intervalperiodexpr :: Parser (Interval, DateSpan)
|
||||||
intervalperiodexpr = do
|
intervalperiodexpr = do
|
||||||
many spacenonewline
|
many spacenonewline
|
||||||
i <- reportinginterval
|
i <- reportinginterval
|
||||||
return (i, DateSpan Nothing Nothing)
|
return (i, DateSpan Nothing Nothing)
|
||||||
|
|
||||||
dateperiodexpr :: Stream s m Char => Day -> ParsecT s st m (Interval, DateSpan)
|
dateperiodexpr :: Day -> Parser (Interval, DateSpan)
|
||||||
dateperiodexpr rdate = do
|
dateperiodexpr rdate = do
|
||||||
many spacenonewline
|
many spacenonewline
|
||||||
s <- periodexprdatespan rdate
|
s <- periodexprdatespan rdate
|
||||||
return (NoInterval, s)
|
return (NoInterval, s)
|
||||||
|
|
||||||
-- Parse a reporting interval.
|
-- Parse a reporting interval.
|
||||||
reportinginterval :: Stream s m Char => ParsecT s st m Interval
|
reportinginterval :: Parser Interval
|
||||||
reportinginterval = choice' [
|
reportinginterval = choice' [
|
||||||
tryinterval "day" "daily" Days,
|
tryinterval "day" "daily" Days,
|
||||||
tryinterval "week" "weekly" Weeks,
|
tryinterval "week" "weekly" Weeks,
|
||||||
@ -770,7 +776,7 @@ reportinginterval = choice' [
|
|||||||
return $ Months 2,
|
return $ Months 2,
|
||||||
do string "every"
|
do string "every"
|
||||||
many spacenonewline
|
many spacenonewline
|
||||||
n <- fmap read $ many1 digit
|
n <- fmap read $ some digitChar
|
||||||
thsuffix
|
thsuffix
|
||||||
many spacenonewline
|
many spacenonewline
|
||||||
string "day"
|
string "day"
|
||||||
@ -781,7 +787,7 @@ reportinginterval = choice' [
|
|||||||
return $ DayOfWeek n,
|
return $ DayOfWeek n,
|
||||||
do string "every"
|
do string "every"
|
||||||
many spacenonewline
|
many spacenonewline
|
||||||
n <- fmap read $ many1 digit
|
n <- fmap read $ some digitChar
|
||||||
thsuffix
|
thsuffix
|
||||||
many spacenonewline
|
many spacenonewline
|
||||||
string "day"
|
string "day"
|
||||||
@ -797,7 +803,7 @@ reportinginterval = choice' [
|
|||||||
thsuffix = choice' $ map string ["st","nd","rd","th"]
|
thsuffix = choice' $ map string ["st","nd","rd","th"]
|
||||||
|
|
||||||
-- 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 :: Stream s m Char => String -> String -> (Int -> Interval) -> ParsecT s st m Interval
|
tryinterval :: String -> String -> (Int -> Interval) -> Parser Interval
|
||||||
tryinterval singular compact intcons =
|
tryinterval singular compact intcons =
|
||||||
choice' [
|
choice' [
|
||||||
do string compact
|
do string compact
|
||||||
@ -808,14 +814,14 @@ reportinginterval = choice' [
|
|||||||
return $ intcons 1,
|
return $ intcons 1,
|
||||||
do string "every"
|
do string "every"
|
||||||
many spacenonewline
|
many spacenonewline
|
||||||
n <- fmap read $ many1 digit
|
n <- fmap read $ some digitChar
|
||||||
many spacenonewline
|
many spacenonewline
|
||||||
string plural
|
string plural
|
||||||
return $ intcons n
|
return $ intcons n
|
||||||
]
|
]
|
||||||
where plural = singular ++ "s"
|
where plural = singular ++ "s"
|
||||||
|
|
||||||
periodexprdatespan :: Stream s m Char => Day -> ParsecT s st m DateSpan
|
periodexprdatespan :: Day -> Parser DateSpan
|
||||||
periodexprdatespan rdate = choice $ map try [
|
periodexprdatespan rdate = choice $ map try [
|
||||||
doubledatespan rdate,
|
doubledatespan rdate,
|
||||||
fromdatespan rdate,
|
fromdatespan rdate,
|
||||||
@ -823,7 +829,7 @@ periodexprdatespan rdate = choice $ map try [
|
|||||||
justdatespan rdate
|
justdatespan rdate
|
||||||
]
|
]
|
||||||
|
|
||||||
doubledatespan :: Stream s m Char => Day -> ParsecT s st m DateSpan
|
doubledatespan :: Day -> Parser DateSpan
|
||||||
doubledatespan rdate = do
|
doubledatespan rdate = do
|
||||||
optional (string "from" >> many spacenonewline)
|
optional (string "from" >> many spacenonewline)
|
||||||
b <- smartdate
|
b <- smartdate
|
||||||
@ -832,7 +838,7 @@ doubledatespan rdate = do
|
|||||||
e <- smartdate
|
e <- smartdate
|
||||||
return $ DateSpan (Just $ fixSmartDate rdate b) (Just $ fixSmartDate rdate e)
|
return $ DateSpan (Just $ fixSmartDate rdate b) (Just $ fixSmartDate rdate e)
|
||||||
|
|
||||||
fromdatespan :: Stream s m Char => Day -> ParsecT s st m DateSpan
|
fromdatespan :: Day -> Parser DateSpan
|
||||||
fromdatespan rdate = do
|
fromdatespan rdate = do
|
||||||
b <- choice [
|
b <- choice [
|
||||||
do
|
do
|
||||||
@ -846,13 +852,13 @@ fromdatespan rdate = do
|
|||||||
]
|
]
|
||||||
return $ DateSpan (Just $ fixSmartDate rdate b) Nothing
|
return $ DateSpan (Just $ fixSmartDate rdate b) Nothing
|
||||||
|
|
||||||
todatespan :: Stream s m Char => Day -> ParsecT s st m DateSpan
|
todatespan :: Day -> Parser DateSpan
|
||||||
todatespan rdate = do
|
todatespan rdate = do
|
||||||
choice [string "to", string "-"] >> many spacenonewline
|
choice [string "to", string "-"] >> many spacenonewline
|
||||||
e <- smartdate
|
e <- smartdate
|
||||||
return $ DateSpan Nothing (Just $ fixSmartDate rdate e)
|
return $ DateSpan Nothing (Just $ fixSmartDate rdate e)
|
||||||
|
|
||||||
justdatespan :: Stream s m Char => Day -> ParsecT s st m DateSpan
|
justdatespan :: Day -> Parser DateSpan
|
||||||
justdatespan rdate = do
|
justdatespan rdate = do
|
||||||
optional (string "in" >> many spacenonewline)
|
optional (string "in" >> many spacenonewline)
|
||||||
d <- smartdate
|
d <- smartdate
|
||||||
|
|||||||
@ -23,6 +23,7 @@ module Hledger.Data.RawOptions (
|
|||||||
where
|
where
|
||||||
|
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
|
import qualified Data.Text as T
|
||||||
import Safe
|
import Safe
|
||||||
|
|
||||||
import Hledger.Utils
|
import Hledger.Utils
|
||||||
@ -32,7 +33,7 @@ import Hledger.Utils
|
|||||||
type RawOpts = [(String,String)]
|
type RawOpts = [(String,String)]
|
||||||
|
|
||||||
setopt :: String -> String -> RawOpts -> RawOpts
|
setopt :: String -> String -> RawOpts -> RawOpts
|
||||||
setopt name val = (++ [(name, quoteIfNeeded val)])
|
setopt name val = (++ [(name, quoteIfNeeded $ val)])
|
||||||
|
|
||||||
setboolopt :: String -> RawOpts -> RawOpts
|
setboolopt :: String -> RawOpts -> RawOpts
|
||||||
setboolopt name = (++ [(name,"")])
|
setboolopt name = (++ [(name,"")])
|
||||||
@ -45,7 +46,7 @@ boolopt :: String -> RawOpts -> Bool
|
|||||||
boolopt = inRawOpts
|
boolopt = inRawOpts
|
||||||
|
|
||||||
maybestringopt :: String -> RawOpts -> Maybe String
|
maybestringopt :: String -> RawOpts -> Maybe String
|
||||||
maybestringopt name = maybe Nothing (Just . stripquotes) . lookup name . reverse
|
maybestringopt name = maybe Nothing (Just . T.unpack . stripquotes . T.pack) . lookup name . reverse
|
||||||
|
|
||||||
stringopt :: String -> RawOpts -> String
|
stringopt :: String -> RawOpts -> String
|
||||||
stringopt name = fromMaybe "" . maybestringopt name
|
stringopt name = fromMaybe "" . maybestringopt name
|
||||||
|
|||||||
@ -2,7 +2,7 @@
|
|||||||
-- hledger's report item fields. The formats are used by
|
-- hledger's report item fields. The formats are used by
|
||||||
-- report-specific renderers like renderBalanceReportItem.
|
-- report-specific renderers like renderBalanceReportItem.
|
||||||
|
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts, TypeFamilies #-}
|
||||||
|
|
||||||
module Hledger.Data.StringFormat (
|
module Hledger.Data.StringFormat (
|
||||||
parseStringFormat
|
parseStringFormat
|
||||||
@ -19,7 +19,8 @@ import Numeric
|
|||||||
import Data.Char (isPrint)
|
import Data.Char (isPrint)
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Test.HUnit
|
import Test.HUnit
|
||||||
import Text.Parsec
|
import Text.Megaparsec
|
||||||
|
import Text.Megaparsec.String
|
||||||
|
|
||||||
import Hledger.Utils.String (formatString)
|
import Hledger.Utils.String (formatString)
|
||||||
|
|
||||||
@ -79,15 +80,15 @@ data ReportItemField =
|
|||||||
|
|
||||||
-- | Parse a string format specification, or return a parse error.
|
-- | Parse a string format specification, or return a parse error.
|
||||||
parseStringFormat :: String -> Either String StringFormat
|
parseStringFormat :: String -> Either String StringFormat
|
||||||
parseStringFormat input = case (runParser (stringformatp <* eof) () "(unknown)") input of
|
parseStringFormat input = case (runParser (stringformatp <* eof) "(unknown)") input of
|
||||||
Left y -> Left $ show y
|
Left y -> Left $ show y
|
||||||
Right x -> Right x
|
Right x -> Right x
|
||||||
|
|
||||||
defaultStringFormatStyle = BottomAligned
|
defaultStringFormatStyle = BottomAligned
|
||||||
|
|
||||||
stringformatp :: Stream [Char] m Char => ParsecT [Char] st m StringFormat
|
stringformatp :: Parser StringFormat
|
||||||
stringformatp = do
|
stringformatp = do
|
||||||
alignspec <- optionMaybe (try $ char '%' >> oneOf "^_,")
|
alignspec <- optional (try $ char '%' >> oneOf "^_,")
|
||||||
let constructor =
|
let constructor =
|
||||||
case alignspec of
|
case alignspec of
|
||||||
Just '^' -> TopAligned
|
Just '^' -> TopAligned
|
||||||
@ -96,24 +97,24 @@ stringformatp = do
|
|||||||
_ -> defaultStringFormatStyle
|
_ -> defaultStringFormatStyle
|
||||||
constructor <$> many componentp
|
constructor <$> many componentp
|
||||||
|
|
||||||
componentp :: Stream [Char] m Char => ParsecT [Char] st m StringFormatComponent
|
componentp :: Parser StringFormatComponent
|
||||||
componentp = formatliteralp <|> formatfieldp
|
componentp = formatliteralp <|> formatfieldp
|
||||||
|
|
||||||
formatliteralp :: Stream [Char] m Char => ParsecT [Char] st m StringFormatComponent
|
formatliteralp :: Parser StringFormatComponent
|
||||||
formatliteralp = do
|
formatliteralp = do
|
||||||
s <- many1 c
|
s <- some c
|
||||||
return $ FormatLiteral s
|
return $ FormatLiteral s
|
||||||
where
|
where
|
||||||
isPrintableButNotPercentage x = isPrint x && (not $ x == '%')
|
isPrintableButNotPercentage x = isPrint x && (not $ x == '%')
|
||||||
c = (satisfy isPrintableButNotPercentage <?> "printable character")
|
c = (satisfy isPrintableButNotPercentage <?> "printable character")
|
||||||
<|> try (string "%%" >> return '%')
|
<|> try (string "%%" >> return '%')
|
||||||
|
|
||||||
formatfieldp :: Stream [Char] m Char => ParsecT [Char] st m StringFormatComponent
|
formatfieldp :: Parser StringFormatComponent
|
||||||
formatfieldp = do
|
formatfieldp = do
|
||||||
char '%'
|
char '%'
|
||||||
leftJustified <- optionMaybe (char '-')
|
leftJustified <- optional (char '-')
|
||||||
minWidth <- optionMaybe (many1 $ digit)
|
minWidth <- optional (some $ digitChar)
|
||||||
maxWidth <- optionMaybe (do char '.'; many1 $ digit) -- TODO: Can this be (char '1') *> (many1 digit)
|
maxWidth <- optional (do char '.'; some $ digitChar) -- TODO: Can this be (char '1') *> (some digitChar)
|
||||||
char '('
|
char '('
|
||||||
f <- fieldp
|
f <- fieldp
|
||||||
char ')'
|
char ')'
|
||||||
@ -123,14 +124,14 @@ formatfieldp = do
|
|||||||
Just text -> Just m where ((m,_):_) = readDec text
|
Just text -> Just m where ((m,_):_) = readDec text
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
|
||||||
fieldp :: Stream [Char] m Char => ParsecT [Char] st m ReportItemField
|
fieldp :: Parser ReportItemField
|
||||||
fieldp = do
|
fieldp = do
|
||||||
try (string "account" >> return AccountField)
|
try (string "account" >> return AccountField)
|
||||||
<|> try (string "depth_spacer" >> return DepthSpacerField)
|
<|> try (string "depth_spacer" >> return DepthSpacerField)
|
||||||
<|> try (string "date" >> return DescriptionField)
|
<|> try (string "date" >> return DescriptionField)
|
||||||
<|> try (string "description" >> return DescriptionField)
|
<|> try (string "description" >> return DescriptionField)
|
||||||
<|> try (string "total" >> return TotalField)
|
<|> try (string "total" >> return TotalField)
|
||||||
<|> try (many1 digit >>= (\s -> return $ FieldNo $ read s))
|
<|> try (some digitChar >>= (\s -> return $ FieldNo $ read s))
|
||||||
|
|
||||||
----------------------------------------------------------------------
|
----------------------------------------------------------------------
|
||||||
|
|
||||||
|
|||||||
@ -5,7 +5,7 @@ transactions..) by various criteria, and a parser for query expressions.
|
|||||||
|
|
||||||
-}
|
-}
|
||||||
|
|
||||||
{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}
|
{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, ViewPatterns #-}
|
||||||
|
|
||||||
module Hledger.Query (
|
module Hledger.Query (
|
||||||
-- * Query and QueryOpt
|
-- * Query and QueryOpt
|
||||||
@ -48,15 +48,16 @@ import Data.Data
|
|||||||
import Data.Either
|
import Data.Either
|
||||||
import Data.List
|
import Data.List
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
|
import Data.Monoid ((<>))
|
||||||
-- import Data.Text (Text)
|
-- import Data.Text (Text)
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import Data.Time.Calendar
|
import Data.Time.Calendar
|
||||||
import Safe (readDef, headDef)
|
import Safe (readDef, headDef)
|
||||||
import Test.HUnit
|
import Test.HUnit
|
||||||
-- import Text.ParserCombinators.Parsec
|
import Text.Megaparsec
|
||||||
import Text.Parsec hiding (Empty)
|
import Text.Megaparsec.Text
|
||||||
|
|
||||||
import Hledger.Utils
|
import Hledger.Utils hiding (words')
|
||||||
import Hledger.Data.Types
|
import Hledger.Data.Types
|
||||||
import Hledger.Data.AccountName
|
import Hledger.Data.AccountName
|
||||||
import Hledger.Data.Amount (amount, nullamt, usd)
|
import Hledger.Data.Amount (amount, nullamt, usd)
|
||||||
@ -154,7 +155,7 @@ data QueryOpt = QueryOptInAcctOnly AccountName -- ^ show an account register fo
|
|||||||
-- 1. multiple account patterns are OR'd together
|
-- 1. multiple account patterns are OR'd together
|
||||||
-- 2. multiple description patterns are OR'd together
|
-- 2. multiple description patterns are OR'd together
|
||||||
-- 3. then all terms are AND'd together
|
-- 3. then all terms are AND'd together
|
||||||
parseQuery :: Day -> String -> (Query,[QueryOpt])
|
parseQuery :: Day -> T.Text -> (Query,[QueryOpt])
|
||||||
parseQuery d s = (q, opts)
|
parseQuery d s = (q, opts)
|
||||||
where
|
where
|
||||||
terms = words'' prefixes s
|
terms = words'' prefixes s
|
||||||
@ -178,21 +179,27 @@ tests_parseQuery = [
|
|||||||
-- | Quote-and-prefix-aware version of words - don't split on spaces which
|
-- | Quote-and-prefix-aware version of words - don't split on spaces which
|
||||||
-- are inside quotes, including quotes which may have one of the specified
|
-- are inside quotes, including quotes which may have one of the specified
|
||||||
-- prefixes in front, and maybe an additional not: prefix in front of that.
|
-- prefixes in front, and maybe an additional not: prefix in front of that.
|
||||||
words'' :: [String] -> String -> [String]
|
words'' :: [T.Text] -> T.Text -> [T.Text]
|
||||||
words'' prefixes = fromparse . parsewith maybeprefixedquotedphrases -- XXX
|
words'' prefixes = fromparse . parsewith maybeprefixedquotedphrases -- XXX
|
||||||
where
|
where
|
||||||
maybeprefixedquotedphrases = choice' [prefixedQuotedPattern, singleQuotedPattern, doubleQuotedPattern, pattern] `sepBy` many1 spacenonewline
|
maybeprefixedquotedphrases :: Parser [T.Text]
|
||||||
|
maybeprefixedquotedphrases = choice' [prefixedQuotedPattern, singleQuotedPattern, doubleQuotedPattern, pattern] `sepBy` some spacenonewline
|
||||||
|
prefixedQuotedPattern :: Parser T.Text
|
||||||
prefixedQuotedPattern = do
|
prefixedQuotedPattern = do
|
||||||
not' <- fromMaybe "" `fmap` (optionMaybe $ string "not:")
|
not' <- fromMaybe "" `fmap` (optional $ string "not:")
|
||||||
let allowednexts | null not' = prefixes
|
let allowednexts | null not' = prefixes
|
||||||
| otherwise = prefixes ++ [""]
|
| otherwise = prefixes ++ [""]
|
||||||
next <- choice' $ map string allowednexts
|
next <- fmap T.pack $ choice' $ map (string . T.unpack) allowednexts
|
||||||
let prefix = not' ++ next
|
let prefix :: T.Text
|
||||||
|
prefix = T.pack not' <> next
|
||||||
p <- singleQuotedPattern <|> doubleQuotedPattern
|
p <- singleQuotedPattern <|> doubleQuotedPattern
|
||||||
return $ prefix ++ stripquotes p
|
return $ prefix <> stripquotes p
|
||||||
singleQuotedPattern = between (char '\'') (char '\'') (many $ noneOf "'") >>= return . stripquotes
|
singleQuotedPattern :: Parser T.Text
|
||||||
doubleQuotedPattern = between (char '"') (char '"') (many $ noneOf "\"") >>= return . stripquotes
|
singleQuotedPattern = between (char '\'') (char '\'') (many $ noneOf ("'" :: [Char])) >>= return . stripquotes . T.pack
|
||||||
pattern = many (noneOf " \n\r")
|
doubleQuotedPattern :: Parser T.Text
|
||||||
|
doubleQuotedPattern = between (char '"') (char '"') (many $ noneOf ("\"" :: [Char])) >>= return . stripquotes . T.pack
|
||||||
|
pattern :: Parser T.Text
|
||||||
|
pattern = fmap T.pack $ many (noneOf (" \n\r" :: [Char]))
|
||||||
|
|
||||||
tests_words'' = [
|
tests_words'' = [
|
||||||
"words''" ~: do
|
"words''" ~: do
|
||||||
@ -209,7 +216,8 @@ tests_words'' = [
|
|||||||
|
|
||||||
-- XXX
|
-- XXX
|
||||||
-- keep synced with patterns below, excluding "not"
|
-- keep synced with patterns below, excluding "not"
|
||||||
prefixes = map (++":") [
|
prefixes :: [T.Text]
|
||||||
|
prefixes = map (<>":") [
|
||||||
"inacctonly"
|
"inacctonly"
|
||||||
,"inacct"
|
,"inacct"
|
||||||
,"amt"
|
,"amt"
|
||||||
@ -226,6 +234,7 @@ prefixes = map (++":") [
|
|||||||
,"tag"
|
,"tag"
|
||||||
]
|
]
|
||||||
|
|
||||||
|
defaultprefix :: T.Text
|
||||||
defaultprefix = "acct"
|
defaultprefix = "acct"
|
||||||
|
|
||||||
-- -- | Parse the query string as a boolean tree of match patterns.
|
-- -- | Parse the query string as a boolean tree of match patterns.
|
||||||
@ -240,36 +249,37 @@ defaultprefix = "acct"
|
|||||||
|
|
||||||
-- | Parse a single query term as either a query or a query option,
|
-- | Parse a single query term as either a query or a query option,
|
||||||
-- or raise an error if it has invalid syntax.
|
-- or raise an error if it has invalid syntax.
|
||||||
parseQueryTerm :: Day -> String -> Either Query QueryOpt
|
parseQueryTerm :: Day -> T.Text -> Either Query QueryOpt
|
||||||
parseQueryTerm _ ('i':'n':'a':'c':'c':'t':'o':'n':'l':'y':':':s) = Right $ QueryOptInAcctOnly $ T.pack s
|
parseQueryTerm _ (T.stripPrefix "inacctonly:" -> Just s) = Right $ QueryOptInAcctOnly s
|
||||||
parseQueryTerm _ ('i':'n':'a':'c':'c':'t':':':s) = Right $ QueryOptInAcct $ T.pack s
|
parseQueryTerm _ (T.stripPrefix "inacct:" -> Just s) = Right $ QueryOptInAcct s
|
||||||
parseQueryTerm d ('n':'o':'t':':':s) = case parseQueryTerm d s of
|
parseQueryTerm d (T.stripPrefix "not:" -> Just s) =
|
||||||
Left m -> Left $ Not m
|
case parseQueryTerm d s of
|
||||||
Right _ -> Left Any -- not:somequeryoption will be ignored
|
Left m -> Left $ Not m
|
||||||
parseQueryTerm _ ('c':'o':'d':'e':':':s) = Left $ Code s
|
Right _ -> Left Any -- not:somequeryoption will be ignored
|
||||||
parseQueryTerm _ ('d':'e':'s':'c':':':s) = Left $ Desc s
|
parseQueryTerm _ (T.stripPrefix "code:" -> Just s) = Left $ Code $ T.unpack s
|
||||||
parseQueryTerm _ ('a':'c':'c':'t':':':s) = Left $ Acct s
|
parseQueryTerm _ (T.stripPrefix "desc:" -> Just s) = Left $ Desc $ T.unpack s
|
||||||
parseQueryTerm d ('d':'a':'t':'e':'2':':':s) =
|
parseQueryTerm _ (T.stripPrefix "acct:" -> Just s) = Left $ Acct $ T.unpack s
|
||||||
case parsePeriodExpr d s of Left e -> error' $ "\"date2:"++s++"\" gave a "++showDateParseError e
|
parseQueryTerm d (T.stripPrefix "date2:" -> Just s) =
|
||||||
|
case parsePeriodExpr d s of Left e -> error' $ "\"date2:"++T.unpack s++"\" gave a "++showDateParseError e
|
||||||
Right (_,span) -> Left $ Date2 span
|
Right (_,span) -> Left $ Date2 span
|
||||||
parseQueryTerm d ('d':'a':'t':'e':':':s) =
|
parseQueryTerm d (T.stripPrefix "date:" -> Just s) =
|
||||||
case parsePeriodExpr d s of Left e -> error' $ "\"date:"++s++"\" gave a "++showDateParseError e
|
case parsePeriodExpr d s of Left e -> error' $ "\"date:"++T.unpack s++"\" gave a "++showDateParseError e
|
||||||
Right (_,span) -> Left $ Date span
|
Right (_,span) -> Left $ Date span
|
||||||
parseQueryTerm _ ('s':'t':'a':'t':'u':'s':':':s) =
|
parseQueryTerm _ (T.stripPrefix "status:" -> Just s) =
|
||||||
case parseStatus s of Left e -> error' $ "\"status:"++s++"\" gave a parse error: " ++ e
|
case parseStatus s of Left e -> error' $ "\"status:"++T.unpack s++"\" gave a parse error: " ++ e
|
||||||
Right st -> Left $ Status st
|
Right st -> Left $ Status st
|
||||||
parseQueryTerm _ ('r':'e':'a':'l':':':s) = Left $ Real $ parseBool s || null s
|
parseQueryTerm _ (T.stripPrefix "real:" -> Just s) = Left $ Real $ parseBool s || T.null s
|
||||||
parseQueryTerm _ ('a':'m':'t':':':s) = Left $ Amt ord q where (ord, q) = parseAmountQueryTerm s
|
parseQueryTerm _ (T.stripPrefix "amt:" -> Just s) = Left $ Amt ord q where (ord, q) = parseAmountQueryTerm s
|
||||||
parseQueryTerm _ ('e':'m':'p':'t':'y':':':s) = Left $ Empty $ parseBool s
|
parseQueryTerm _ (T.stripPrefix "empty:" -> Just s) = Left $ Empty $ parseBool s
|
||||||
parseQueryTerm _ ('d':'e':'p':'t':'h':':':s)
|
parseQueryTerm _ (T.stripPrefix "depth:" -> Just s)
|
||||||
| n >= 0 = Left $ Depth n
|
| n >= 0 = Left $ Depth n
|
||||||
| otherwise = error' "depth: should have a positive number"
|
| otherwise = error' "depth: should have a positive number"
|
||||||
where n = readDef 0 s
|
where n = readDef 0 (T.unpack s)
|
||||||
|
|
||||||
parseQueryTerm _ ('c':'u':'r':':':s) = Left $ Sym s -- support cur: as an alias
|
parseQueryTerm _ (T.stripPrefix "cur:" -> Just s) = Left $ Sym (T.unpack s) -- support cur: as an alias
|
||||||
parseQueryTerm _ ('t':'a':'g':':':s) = Left $ Tag n v where (n,v) = parseTag s
|
parseQueryTerm _ (T.stripPrefix "tag:" -> Just s) = Left $ Tag n v where (n,v) = parseTag s
|
||||||
parseQueryTerm _ "" = Left $ Any
|
parseQueryTerm _ "" = Left $ Any
|
||||||
parseQueryTerm d s = parseQueryTerm d $ defaultprefix++":"++s
|
parseQueryTerm d s = parseQueryTerm d $ defaultprefix<>":"<>s
|
||||||
|
|
||||||
tests_parseQueryTerm = [
|
tests_parseQueryTerm = [
|
||||||
"parseQueryTerm" ~: do
|
"parseQueryTerm" ~: do
|
||||||
@ -298,35 +308,40 @@ data OrdPlus = Lt | LtEq | Gt | GtEq | Eq | AbsLt | AbsLtEq | AbsGt | AbsGtEq |
|
|||||||
deriving (Show,Eq,Data,Typeable)
|
deriving (Show,Eq,Data,Typeable)
|
||||||
|
|
||||||
-- can fail
|
-- can fail
|
||||||
parseAmountQueryTerm :: String -> (OrdPlus, Quantity)
|
parseAmountQueryTerm :: T.Text -> (OrdPlus, Quantity)
|
||||||
parseAmountQueryTerm s' =
|
parseAmountQueryTerm s' =
|
||||||
case s' of
|
case s' of
|
||||||
-- feel free to do this a smarter way
|
-- feel free to do this a smarter way
|
||||||
"" -> err
|
"" -> err
|
||||||
'<':'+':s -> (Lt, readDef err s)
|
(T.stripPrefix "<+" -> Just s) -> (Lt, readDef err (T.unpack s))
|
||||||
'<':'=':'+':s -> (LtEq, readDef err s)
|
(T.stripPrefix "<=+" -> Just s) -> (LtEq, readDef err (T.unpack s))
|
||||||
'>':'+':s -> (Gt, readDef err s)
|
(T.stripPrefix ">+" -> Just s) -> (Gt, readDef err (T.unpack s))
|
||||||
'>':'=':'+':s -> (GtEq, readDef err s)
|
(T.stripPrefix ">=+" -> Just s) -> (GtEq, readDef err (T.unpack s))
|
||||||
'=':'+':s -> (Eq, readDef err s)
|
(T.stripPrefix "=+" -> Just s) -> (Eq, readDef err (T.unpack s))
|
||||||
'+':s -> (Eq, readDef err s)
|
(T.stripPrefix "+" -> Just s) -> (Eq, readDef err (T.unpack s))
|
||||||
'<':'-':s -> (Lt, negate $ readDef err s)
|
(T.stripPrefix "<-" -> Just s) -> (Lt, negate $ readDef err (T.unpack s))
|
||||||
'<':'=':'-':s -> (LtEq, negate $ readDef err s)
|
(T.stripPrefix "<=-" -> Just s) -> (LtEq, negate $ readDef err (T.unpack s))
|
||||||
'>':'-':s -> (Gt, negate $ readDef err s)
|
(T.stripPrefix ">-" -> Just s) -> (Gt, negate $ readDef err (T.unpack s))
|
||||||
'>':'=':'-':s -> (GtEq, negate $ readDef err s)
|
(T.stripPrefix ">=-" -> Just s) -> (GtEq, negate $ readDef err (T.unpack s))
|
||||||
'=':'-':s -> (Eq, negate $ readDef err s)
|
(T.stripPrefix "=-" -> Just s) -> (Eq, negate $ readDef err (T.unpack s))
|
||||||
'-':s -> (Eq, negate $ readDef err s)
|
(T.stripPrefix "-" -> Just s) -> (Eq, negate $ readDef err (T.unpack s))
|
||||||
'<':'=':s -> let n = readDef err s in case n of 0 -> (LtEq, 0)
|
(T.stripPrefix "<=" -> Just s) -> let n = readDef err (T.unpack s) in
|
||||||
_ -> (AbsLtEq, n)
|
case n of
|
||||||
'<':s -> let n = readDef err s in case n of 0 -> (Lt, 0)
|
0 -> (LtEq, 0)
|
||||||
_ -> (AbsLt, n)
|
_ -> (AbsLtEq, n)
|
||||||
'>':'=':s -> let n = readDef err s in case n of 0 -> (GtEq, 0)
|
(T.stripPrefix "<" -> Just s) -> let n = readDef err (T.unpack s) in
|
||||||
_ -> (AbsGtEq, n)
|
case n of 0 -> (Lt, 0)
|
||||||
'>':s -> let n = readDef err s in case n of 0 -> (Gt, 0)
|
_ -> (AbsLt, n)
|
||||||
_ -> (AbsGt, n)
|
(T.stripPrefix ">=" -> Just s) -> let n = readDef err (T.unpack s) in
|
||||||
'=':s -> (AbsEq, readDef err s)
|
case n of 0 -> (GtEq, 0)
|
||||||
s -> (AbsEq, readDef err s)
|
_ -> (AbsGtEq, n)
|
||||||
|
(T.stripPrefix ">" -> Just s) -> let n = readDef err (T.unpack s) in
|
||||||
|
case n of 0 -> (Gt, 0)
|
||||||
|
_ -> (AbsGt, n)
|
||||||
|
(T.stripPrefix "=" -> Just s) -> (AbsEq, readDef err (T.unpack s))
|
||||||
|
s -> (AbsEq, readDef err (T.unpack s))
|
||||||
where
|
where
|
||||||
err = error' $ "could not parse as '=', '<', or '>' (optional) followed by a (optionally signed) numeric quantity: " ++ s'
|
err = error' $ "could not parse as '=', '<', or '>' (optional) followed by a (optionally signed) numeric quantity: " ++ T.unpack s'
|
||||||
|
|
||||||
tests_parseAmountQueryTerm = [
|
tests_parseAmountQueryTerm = [
|
||||||
"parseAmountQueryTerm" ~: do
|
"parseAmountQueryTerm" ~: do
|
||||||
@ -340,13 +355,13 @@ tests_parseAmountQueryTerm = [
|
|||||||
"-0.23" `gives` (Eq,(-0.23))
|
"-0.23" `gives` (Eq,(-0.23))
|
||||||
]
|
]
|
||||||
|
|
||||||
parseTag :: String -> (Regexp, Maybe Regexp)
|
parseTag :: T.Text -> (Regexp, Maybe Regexp)
|
||||||
parseTag s | '=' `elem` s = (n, Just $ tail v)
|
parseTag s | "=" `T.isInfixOf` s = (T.unpack n, Just $ tail $ T.unpack v)
|
||||||
| otherwise = (s, Nothing)
|
| otherwise = (T.unpack s, Nothing)
|
||||||
where (n,v) = break (=='=') s
|
where (n,v) = T.break (=='=') s
|
||||||
|
|
||||||
-- | Parse the value part of a "status:" query, or return an error.
|
-- | Parse the value part of a "status:" query, or return an error.
|
||||||
parseStatus :: String -> Either String ClearedStatus
|
parseStatus :: T.Text -> Either String ClearedStatus
|
||||||
parseStatus s | s `elem` ["*","1"] = Right Cleared
|
parseStatus s | s `elem` ["*","1"] = Right Cleared
|
||||||
| s `elem` ["!"] = Right Pending
|
| s `elem` ["!"] = Right Pending
|
||||||
| s `elem` ["","0"] = Right Uncleared
|
| s `elem` ["","0"] = Right Uncleared
|
||||||
@ -354,10 +369,10 @@ parseStatus s | s `elem` ["*","1"] = Right Cleared
|
|||||||
|
|
||||||
-- | Parse the boolean value part of a "status:" query. "1" means true,
|
-- | Parse the boolean value part of a "status:" query. "1" means true,
|
||||||
-- anything else will be parsed as false without error.
|
-- anything else will be parsed as false without error.
|
||||||
parseBool :: String -> Bool
|
parseBool :: T.Text -> Bool
|
||||||
parseBool s = s `elem` truestrings
|
parseBool s = s `elem` truestrings
|
||||||
|
|
||||||
truestrings :: [String]
|
truestrings :: [T.Text]
|
||||||
truestrings = ["1"]
|
truestrings = ["1"]
|
||||||
|
|
||||||
simplifyQuery :: Query -> Query
|
simplifyQuery :: Query -> Query
|
||||||
|
|||||||
@ -21,10 +21,12 @@ where
|
|||||||
import Prelude ()
|
import Prelude ()
|
||||||
import Prelude.Compat hiding (readFile)
|
import Prelude.Compat hiding (readFile)
|
||||||
import Control.Monad.Compat
|
import Control.Monad.Compat
|
||||||
import Control.Monad.Except (ExceptT(..), liftIO, runExceptT, throwError) --, catchError)
|
import Control.Monad.Except (ExceptT(..), runExceptT, throwError) --, catchError)
|
||||||
|
import Control.Monad.State.Strict
|
||||||
import Data.Char (isNumber)
|
import Data.Char (isNumber)
|
||||||
import Data.Functor.Identity
|
import Data.Functor.Identity
|
||||||
import Data.List.Compat
|
import Data.List.Compat
|
||||||
|
import Data.List.NonEmpty (NonEmpty(..))
|
||||||
import Data.List.Split (wordsBy)
|
import Data.List.Split (wordsBy)
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Data.Monoid
|
import Data.Monoid
|
||||||
@ -34,7 +36,8 @@ import Data.Time.Calendar
|
|||||||
import Data.Time.LocalTime
|
import Data.Time.LocalTime
|
||||||
import Safe
|
import Safe
|
||||||
import System.Time (getClockTime)
|
import System.Time (getClockTime)
|
||||||
import Text.Parsec hiding (parse)
|
import Text.Megaparsec hiding (parse,State)
|
||||||
|
import Text.Megaparsec.Text
|
||||||
|
|
||||||
import Hledger.Data
|
import Hledger.Data
|
||||||
import Hledger.Utils
|
import Hledger.Utils
|
||||||
@ -43,40 +46,27 @@ import Hledger.Utils
|
|||||||
|
|
||||||
--- * parsing utils
|
--- * parsing utils
|
||||||
|
|
||||||
-- | A parser of strings with generic user state, monad and return type.
|
|
||||||
type StringParser u m a = ParsecT String u m a
|
|
||||||
|
|
||||||
-- | A parser of strict text with generic user state, monad and return type.
|
|
||||||
type TextParser u m a = ParsecT Text u m a
|
|
||||||
|
|
||||||
-- | A text parser with journal-parsing state.
|
|
||||||
type JournalParser m a = TextParser Journal m a
|
|
||||||
|
|
||||||
-- | A journal parser that runs in IO and can throw an error mid-parse.
|
|
||||||
type ErroringJournalParser a = JournalParser (ExceptT String IO) a
|
|
||||||
|
|
||||||
-- | Run a string parser with no state in the identity monad.
|
-- | Run a string parser with no state in the identity monad.
|
||||||
runStringParser, rsp :: StringParser () Identity a -> String -> Either ParseError a
|
runTextParser, rtp :: TextParser Identity a -> Text -> Either (ParseError Char Dec) a
|
||||||
runStringParser p s = runIdentity $ runParserT p () "" s
|
runTextParser p t = runParser p "" t
|
||||||
rsp = runStringParser
|
|
||||||
|
|
||||||
-- | Run a string parser with no state in the identity monad.
|
|
||||||
runTextParser, rtp :: TextParser () Identity a -> Text -> Either ParseError a
|
|
||||||
runTextParser p t = runIdentity $ runParserT p () "" t
|
|
||||||
rtp = runTextParser
|
rtp = runTextParser
|
||||||
|
|
||||||
-- | Run a journal parser with a null journal-parsing state.
|
-- | Run a journal parser with a null journal-parsing state.
|
||||||
runJournalParser, rjp :: Monad m => JournalParser m a -> Text -> m (Either ParseError a)
|
runJournalParser, rjp :: Monad m => TextParser m a -> Text -> m (Either (ParseError Char Dec) a)
|
||||||
runJournalParser p t = runParserT p mempty "" t
|
runJournalParser p t = runParserT p "" t
|
||||||
rjp = runJournalParser
|
rjp = runJournalParser
|
||||||
|
|
||||||
-- | Run an error-raising journal parser with a null journal-parsing state.
|
-- | Run an error-raising journal parser with a null journal-parsing state.
|
||||||
runErroringJournalParser, rejp :: ErroringJournalParser a -> Text -> IO (Either String a)
|
runErroringJournalParser, rejp :: ErroringJournalParser a -> Text -> IO (Either String a)
|
||||||
runErroringJournalParser p t = runExceptT $ runJournalParser p t >>= either (throwError.show) return
|
runErroringJournalParser p t =
|
||||||
|
runExceptT $
|
||||||
|
runJournalParser (evalStateT p mempty)
|
||||||
|
t >>=
|
||||||
|
either (throwError . parseErrorPretty) return
|
||||||
rejp = runErroringJournalParser
|
rejp = runErroringJournalParser
|
||||||
|
|
||||||
genericSourcePos :: SourcePos -> GenericSourcePos
|
genericSourcePos :: SourcePos -> GenericSourcePos
|
||||||
genericSourcePos p = GenericSourcePos (sourceName p) (sourceLine p) (sourceColumn p)
|
genericSourcePos p = GenericSourcePos (sourceName p) (fromIntegral . unPos $ sourceLine p) (fromIntegral . unPos $ sourceColumn p)
|
||||||
|
|
||||||
-- | Given a parsec ParsedJournal parser, file path and data string,
|
-- | Given a parsec ParsedJournal parser, file path and data string,
|
||||||
-- parse and post-process a ready-to-use Journal, or give an error.
|
-- parse and post-process a ready-to-use Journal, or give an error.
|
||||||
@ -84,60 +74,71 @@ parseAndFinaliseJournal :: ErroringJournalParser ParsedJournal -> Bool -> FilePa
|
|||||||
parseAndFinaliseJournal parser assrt f txt = do
|
parseAndFinaliseJournal parser assrt f txt = do
|
||||||
t <- liftIO getClockTime
|
t <- liftIO getClockTime
|
||||||
y <- liftIO getCurrentYear
|
y <- liftIO getCurrentYear
|
||||||
ep <- runParserT parser nulljournal{jparsedefaultyear=Just y} f txt
|
ep <- runParserT (evalStateT parser nulljournal {jparsedefaultyear=Just y}) f txt
|
||||||
case ep of
|
case ep of
|
||||||
Right pj -> case journalFinalise t f txt assrt pj of
|
Right pj -> case journalFinalise t f txt assrt pj of
|
||||||
Right j -> return j
|
Right j -> return j
|
||||||
Left e -> throwError e
|
Left e -> throwError e
|
||||||
Left e -> throwError $ show e
|
Left e -> throwError $ parseErrorPretty e
|
||||||
|
|
||||||
setYear :: Monad m => Integer -> JournalParser m ()
|
parseAndFinaliseJournal' :: JournalParser ParsedJournal -> Bool -> FilePath -> Text -> ExceptT String IO Journal
|
||||||
setYear y = modifyState (\j -> j{jparsedefaultyear=Just y})
|
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
|
||||||
|
|
||||||
getYear :: Monad m => JournalParser m (Maybe Integer)
|
setYear :: Monad m => Year -> JournalStateParser m ()
|
||||||
getYear = fmap jparsedefaultyear getState
|
setYear y = modify' (\j -> j{jparsedefaultyear=Just y})
|
||||||
|
|
||||||
setDefaultCommodityAndStyle :: Monad m => (CommoditySymbol,AmountStyle) -> JournalParser m ()
|
getYear :: Monad m => JournalStateParser m (Maybe Year)
|
||||||
setDefaultCommodityAndStyle cs = modifyState (\j -> j{jparsedefaultcommodity=Just cs})
|
getYear = fmap jparsedefaultyear get
|
||||||
|
|
||||||
getDefaultCommodityAndStyle :: Monad m => JournalParser m (Maybe (CommoditySymbol,AmountStyle))
|
setDefaultCommodityAndStyle :: (CommoditySymbol,AmountStyle) -> ErroringJournalParser ()
|
||||||
getDefaultCommodityAndStyle = jparsedefaultcommodity `fmap` getState
|
setDefaultCommodityAndStyle cs = modify' (\j -> j{jparsedefaultcommodity=Just cs})
|
||||||
|
|
||||||
pushAccount :: Monad m => AccountName -> JournalParser m ()
|
getDefaultCommodityAndStyle :: Monad m => JournalStateParser m (Maybe (CommoditySymbol,AmountStyle))
|
||||||
pushAccount acct = modifyState (\j -> j{jaccounts = acct : jaccounts j})
|
getDefaultCommodityAndStyle = jparsedefaultcommodity `fmap` get
|
||||||
|
|
||||||
pushParentAccount :: Monad m => AccountName -> JournalParser m ()
|
pushAccount :: AccountName -> ErroringJournalParser ()
|
||||||
pushParentAccount acct = modifyState (\j -> j{jparseparentaccounts = acct : jparseparentaccounts j})
|
pushAccount acct = modify' (\j -> j{jaccounts = acct : jaccounts j})
|
||||||
|
|
||||||
popParentAccount :: Monad m => JournalParser m ()
|
pushParentAccount :: AccountName -> ErroringJournalParser ()
|
||||||
|
pushParentAccount acct = modify' (\j -> j{jparseparentaccounts = acct : jparseparentaccounts j})
|
||||||
|
|
||||||
|
popParentAccount :: ErroringJournalParser ()
|
||||||
popParentAccount = do
|
popParentAccount = do
|
||||||
j <- getState
|
j <- get
|
||||||
case jparseparentaccounts j of
|
case jparseparentaccounts j of
|
||||||
[] -> unexpected "End of apply account block with no beginning"
|
[] -> unexpected (Tokens ('E' :| "nd of apply account block with no beginning"))
|
||||||
(_:rest) -> setState j{jparseparentaccounts=rest}
|
(_:rest) -> put j{jparseparentaccounts=rest}
|
||||||
|
|
||||||
getParentAccount :: Monad m => JournalParser m AccountName
|
getParentAccount :: ErroringJournalParser AccountName
|
||||||
getParentAccount = fmap (concatAccountNames . reverse . jparseparentaccounts) getState
|
getParentAccount = fmap (concatAccountNames . reverse . jparseparentaccounts) get
|
||||||
|
|
||||||
addAccountAlias :: Monad m => AccountAlias -> JournalParser m ()
|
addAccountAlias :: MonadState Journal m => AccountAlias -> m ()
|
||||||
addAccountAlias a = modifyState (\(j@Journal{..}) -> j{jparsealiases=a:jparsealiases})
|
addAccountAlias a = modify' (\(j@Journal{..}) -> j{jparsealiases=a:jparsealiases})
|
||||||
|
|
||||||
getAccountAliases :: Monad m => JournalParser m [AccountAlias]
|
getAccountAliases :: MonadState Journal m => m [AccountAlias]
|
||||||
getAccountAliases = fmap jparsealiases getState
|
getAccountAliases = fmap jparsealiases get
|
||||||
|
|
||||||
clearAccountAliases :: Monad m => JournalParser m ()
|
clearAccountAliases :: MonadState Journal m => m ()
|
||||||
clearAccountAliases = modifyState (\(j@Journal{..}) -> j{jparsealiases=[]})
|
clearAccountAliases = modify' (\(j@Journal{..}) -> j{jparsealiases=[]})
|
||||||
|
|
||||||
getTransactionCount :: Monad m => JournalParser m Integer
|
getTransactionCount :: MonadState Journal m => m Integer
|
||||||
getTransactionCount = fmap jparsetransactioncount getState
|
getTransactionCount = fmap jparsetransactioncount get
|
||||||
|
|
||||||
setTransactionCount :: Monad m => Integer -> JournalParser m ()
|
setTransactionCount :: MonadState Journal m => Integer -> m ()
|
||||||
setTransactionCount i = modifyState (\j -> j{jparsetransactioncount=i})
|
setTransactionCount i = modify' (\j -> j{jparsetransactioncount=i})
|
||||||
|
|
||||||
-- | Increment the transaction index by one and return the new value.
|
-- | Increment the transaction index by one and return the new value.
|
||||||
incrementTransactionCount :: Monad m => JournalParser m Integer
|
incrementTransactionCount :: MonadState Journal m => m Integer
|
||||||
incrementTransactionCount = do
|
incrementTransactionCount = do
|
||||||
modifyState (\j -> j{jparsetransactioncount=jparsetransactioncount j + 1})
|
modify' (\j -> j{jparsetransactioncount=jparsetransactioncount j + 1})
|
||||||
getTransactionCount
|
getTransactionCount
|
||||||
|
|
||||||
journalAddFile :: (FilePath,Text) -> Journal -> Journal
|
journalAddFile :: (FilePath,Text) -> Journal -> Journal
|
||||||
@ -155,12 +156,12 @@ journalAddFile f j@Journal{jfiles=fs} = j{jfiles=fs++[f]}
|
|||||||
-- | Terminate parsing entirely, returning the given error message
|
-- | Terminate parsing entirely, returning the given error message
|
||||||
-- with the given parse position prepended.
|
-- with the given parse position prepended.
|
||||||
parserErrorAt :: SourcePos -> String -> ErroringJournalParser a
|
parserErrorAt :: SourcePos -> String -> ErroringJournalParser a
|
||||||
parserErrorAt pos s = throwError $ show pos ++ ":\n" ++ s
|
parserErrorAt pos s = throwError $ sourcePosPretty pos ++ ":\n" ++ s
|
||||||
|
|
||||||
--- * parsers
|
--- * parsers
|
||||||
--- ** transaction bits
|
--- ** transaction bits
|
||||||
|
|
||||||
statusp :: Monad m => JournalParser m ClearedStatus
|
statusp :: TextParser m ClearedStatus
|
||||||
statusp =
|
statusp =
|
||||||
choice'
|
choice'
|
||||||
[ many spacenonewline >> char '*' >> return Cleared
|
[ many spacenonewline >> char '*' >> return Cleared
|
||||||
@ -169,11 +170,11 @@ statusp =
|
|||||||
]
|
]
|
||||||
<?> "cleared status"
|
<?> "cleared status"
|
||||||
|
|
||||||
codep :: Monad m => JournalParser m String
|
codep :: TextParser m String
|
||||||
codep = try (do { many1 spacenonewline; char '(' <?> "codep"; anyChar `manyTill` char ')' } ) <|> return ""
|
codep = try (do { some spacenonewline; char '(' <?> "codep"; anyChar `manyTill` char ')' } ) <|> return ""
|
||||||
|
|
||||||
descriptionp :: Monad m => JournalParser m String
|
descriptionp :: ErroringJournalParser String
|
||||||
descriptionp = many (noneOf ";\n")
|
descriptionp = many (noneOf (";\n" :: [Char]))
|
||||||
|
|
||||||
--- ** dates
|
--- ** dates
|
||||||
|
|
||||||
@ -181,14 +182,14 @@ descriptionp = many (noneOf ";\n")
|
|||||||
-- Hyphen (-) and period (.) are also allowed as separators.
|
-- Hyphen (-) and period (.) are also allowed as separators.
|
||||||
-- The year may be omitted if a default year has been set.
|
-- The year may be omitted if a default year has been set.
|
||||||
-- Leading zeroes may be omitted.
|
-- Leading zeroes may be omitted.
|
||||||
datep :: Monad m => JournalParser m Day
|
datep :: Monad m => JournalStateParser m Day
|
||||||
datep = do
|
datep = do
|
||||||
-- hacky: try to ensure precise errors for invalid dates
|
-- hacky: try to ensure precise errors for invalid dates
|
||||||
-- XXX reported error position is not too good
|
-- XXX reported error position is not too good
|
||||||
-- pos <- genericSourcePos <$> getPosition
|
-- pos <- genericSourcePos <$> getPosition
|
||||||
datestr <- do
|
datestr <- do
|
||||||
c <- digit
|
c <- digitChar
|
||||||
cs <- many $ choice' [digit, datesepchar]
|
cs <- lift $ many $ choice' [digitChar, datesepchar]
|
||||||
return $ c:cs
|
return $ c:cs
|
||||||
let sepchars = nub $ sort $ filter (`elem` datesepchars) datestr
|
let sepchars = nub $ sort $ filter (`elem` datesepchars) datestr
|
||||||
when (length sepchars /= 1) $ fail $ "bad date, different separators used: " ++ datestr
|
when (length sepchars /= 1) $ fail $ "bad date, different separators used: " ++ datestr
|
||||||
@ -211,35 +212,35 @@ datep = do
|
|||||||
-- Seconds are optional.
|
-- Seconds are optional.
|
||||||
-- The timezone is optional and ignored (the time is always interpreted as a local time).
|
-- The timezone is optional and ignored (the time is always interpreted as a local time).
|
||||||
-- Leading zeroes may be omitted (except in a timezone).
|
-- Leading zeroes may be omitted (except in a timezone).
|
||||||
datetimep :: Monad m => JournalParser m LocalTime
|
datetimep :: ErroringJournalParser LocalTime
|
||||||
datetimep = do
|
datetimep = do
|
||||||
day <- datep
|
day <- datep
|
||||||
many1 spacenonewline
|
lift $ some spacenonewline
|
||||||
h <- many1 digit
|
h <- some digitChar
|
||||||
let h' = read h
|
let h' = read h
|
||||||
guard $ h' >= 0 && h' <= 23
|
guard $ h' >= 0 && h' <= 23
|
||||||
char ':'
|
char ':'
|
||||||
m <- many1 digit
|
m <- some digitChar
|
||||||
let m' = read m
|
let m' = read m
|
||||||
guard $ m' >= 0 && m' <= 59
|
guard $ m' >= 0 && m' <= 59
|
||||||
s <- optionMaybe $ char ':' >> many1 digit
|
s <- optional $ char ':' >> some digitChar
|
||||||
let s' = case s of Just sstr -> read sstr
|
let s' = case s of Just sstr -> read sstr
|
||||||
Nothing -> 0
|
Nothing -> 0
|
||||||
guard $ s' >= 0 && s' <= 59
|
guard $ s' >= 0 && s' <= 59
|
||||||
{- tz <- -}
|
{- tz <- -}
|
||||||
optionMaybe $ do
|
optional $ do
|
||||||
plusminus <- oneOf "-+"
|
plusminus <- oneOf ("-+" :: [Char])
|
||||||
d1 <- digit
|
d1 <- digitChar
|
||||||
d2 <- digit
|
d2 <- digitChar
|
||||||
d3 <- digit
|
d3 <- digitChar
|
||||||
d4 <- digit
|
d4 <- digitChar
|
||||||
return $ plusminus:d1:d2:d3:d4:""
|
return $ plusminus:d1:d2:d3:d4:""
|
||||||
-- ltz <- liftIO $ getCurrentTimeZone
|
-- ltz <- liftIO $ getCurrentTimeZone
|
||||||
-- let tz' = maybe ltz (fromMaybe ltz . parseTime defaultTimeLocale "%z") tz
|
-- let tz' = maybe ltz (fromMaybe ltz . parseTime defaultTimeLocale "%z") tz
|
||||||
-- 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 :: Monad m => Day -> JournalParser m Day
|
secondarydatep :: Day -> ErroringJournalParser Day
|
||||||
secondarydatep primarydate = do
|
secondarydatep primarydate = do
|
||||||
char '='
|
char '='
|
||||||
-- kludgy way to use primary date for default year
|
-- kludgy way to use primary date for default year
|
||||||
@ -256,20 +257,20 @@ secondarydatep primarydate = do
|
|||||||
-- >> parsewith twoorthreepartdatestringp "2016/01/2"
|
-- >> parsewith twoorthreepartdatestringp "2016/01/2"
|
||||||
-- Right "2016/01/2"
|
-- Right "2016/01/2"
|
||||||
-- twoorthreepartdatestringp = do
|
-- twoorthreepartdatestringp = do
|
||||||
-- n1 <- many1 digit
|
-- n1 <- some digitChar
|
||||||
-- c <- datesepchar
|
-- c <- datesepchar
|
||||||
-- n2 <- many1 digit
|
-- n2 <- some digitChar
|
||||||
-- mn3 <- optionMaybe $ char c >> many1 digit
|
-- mn3 <- optional $ char c >> some digitChar
|
||||||
-- return $ n1 ++ c:n2 ++ maybe "" (c:) mn3
|
-- return $ n1 ++ c:n2 ++ maybe "" (c:) mn3
|
||||||
|
|
||||||
--- ** account names
|
--- ** account names
|
||||||
|
|
||||||
-- | Parse an account name, then apply any parent account prefix and/or account aliases currently in effect.
|
-- | Parse an account name, then apply any parent account prefix and/or account aliases currently in effect.
|
||||||
modifiedaccountnamep :: Monad m => JournalParser m AccountName
|
modifiedaccountnamep :: ErroringJournalParser AccountName
|
||||||
modifiedaccountnamep = do
|
modifiedaccountnamep = do
|
||||||
parent <- getParentAccount
|
parent <- getParentAccount
|
||||||
aliases <- getAccountAliases
|
aliases <- getAccountAliases
|
||||||
a <- accountnamep
|
a <- lift accountnamep
|
||||||
return $
|
return $
|
||||||
accountNameApplyAliases aliases $
|
accountNameApplyAliases aliases $
|
||||||
-- XXX accountNameApplyAliasesMemo ? doesn't seem to make a difference
|
-- XXX accountNameApplyAliasesMemo ? doesn't seem to make a difference
|
||||||
@ -281,7 +282,7 @@ modifiedaccountnamep = do
|
|||||||
-- spaces (or end of input). Also they have one or more components of
|
-- spaces (or end of input). Also they have one or more components of
|
||||||
-- at least one character, separated by the account separator char.
|
-- at least one character, separated by the account separator char.
|
||||||
-- (This parser will also consume one following space, if present.)
|
-- (This parser will also consume one following space, if present.)
|
||||||
accountnamep :: Monad m => TextParser u m AccountName
|
accountnamep :: TextParser m AccountName
|
||||||
accountnamep = do
|
accountnamep = do
|
||||||
astr <- do
|
astr <- do
|
||||||
c <- nonspace
|
c <- nonspace
|
||||||
@ -304,10 +305,10 @@ accountnamep = do
|
|||||||
-- | Parse whitespace then an amount, with an optional left or right
|
-- | Parse whitespace then an amount, with an optional left or right
|
||||||
-- currency symbol and optional price, or return the special
|
-- currency symbol and optional price, or return the special
|
||||||
-- "missing" marker amount.
|
-- "missing" marker amount.
|
||||||
spaceandamountormissingp :: Monad m => JournalParser m MixedAmount
|
spaceandamountormissingp :: ErroringJournalParser MixedAmount
|
||||||
spaceandamountormissingp =
|
spaceandamountormissingp =
|
||||||
try (do
|
try (do
|
||||||
many1 spacenonewline
|
lift $ some spacenonewline
|
||||||
(Mixed . (:[])) `fmap` amountp <|> return missingmixedamt
|
(Mixed . (:[])) `fmap` amountp <|> return missingmixedamt
|
||||||
) <|> return missingmixedamt
|
) <|> return missingmixedamt
|
||||||
|
|
||||||
@ -328,7 +329,7 @@ test_spaceandamountormissingp = do
|
|||||||
-- | Parse a single-commodity amount, with optional symbol on the left or
|
-- | Parse a single-commodity amount, with optional symbol on the left or
|
||||||
-- right, optional unit or total price, and optional (ignored)
|
-- right, optional unit or total price, and optional (ignored)
|
||||||
-- ledger-style balance assertion or fixed lot price declaration.
|
-- ledger-style balance assertion or fixed lot price declaration.
|
||||||
amountp :: Monad m => JournalParser m Amount
|
amountp :: Monad m => JournalStateParser m Amount
|
||||||
amountp = try leftsymbolamountp <|> try rightsymbolamountp <|> nosymbolamountp
|
amountp = try leftsymbolamountp <|> try rightsymbolamountp <|> nosymbolamountp
|
||||||
|
|
||||||
#ifdef TESTS
|
#ifdef TESTS
|
||||||
@ -348,7 +349,7 @@ test_amountp = do
|
|||||||
-- | Parse an amount from a string, or get an error.
|
-- | Parse an amount from a string, or get an error.
|
||||||
amountp' :: String -> Amount
|
amountp' :: String -> Amount
|
||||||
amountp' s =
|
amountp' s =
|
||||||
case runParser (amountp <* eof) mempty "" (T.pack s) of
|
case runParser (evalStateT (amountp <* eof) mempty) "" (T.pack s) of
|
||||||
Right amt -> amt
|
Right amt -> amt
|
||||||
Left err -> error' $ show err -- XXX should throwError
|
Left err -> error' $ show err -- XXX should throwError
|
||||||
|
|
||||||
@ -356,37 +357,37 @@ amountp' s =
|
|||||||
mamountp' :: String -> MixedAmount
|
mamountp' :: String -> MixedAmount
|
||||||
mamountp' = Mixed . (:[]) . amountp'
|
mamountp' = Mixed . (:[]) . amountp'
|
||||||
|
|
||||||
signp :: Monad m => JournalParser m String
|
signp :: TextParser m String
|
||||||
signp = do
|
signp = do
|
||||||
sign <- optionMaybe $ oneOf "+-"
|
sign <- optional $ oneOf ("+-" :: [Char])
|
||||||
return $ case sign of Just '-' -> "-"
|
return $ case sign of Just '-' -> "-"
|
||||||
_ -> ""
|
_ -> ""
|
||||||
|
|
||||||
leftsymbolamountp :: Monad m => JournalParser m Amount
|
leftsymbolamountp :: Monad m => JournalStateParser m Amount
|
||||||
leftsymbolamountp = do
|
leftsymbolamountp = do
|
||||||
sign <- signp
|
sign <- lift signp
|
||||||
c <- commoditysymbolp
|
c <- lift commoditysymbolp
|
||||||
sp <- many spacenonewline
|
sp <- lift $ many spacenonewline
|
||||||
(q,prec,mdec,mgrps) <- numberp
|
(q,prec,mdec,mgrps) <- lift numberp
|
||||||
let s = amountstyle{ascommodityside=L, ascommodityspaced=not $ null sp, asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps}
|
let s = amountstyle{ascommodityside=L, ascommodityspaced=not $ null sp, asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps}
|
||||||
p <- priceamountp
|
p <- priceamountp
|
||||||
let applysign = if sign=="-" then negate else id
|
let applysign = if sign=="-" then negate else id
|
||||||
return $ applysign $ Amount c q p s
|
return $ applysign $ Amount c q p s
|
||||||
<?> "left-symbol amount"
|
<?> "left-symbol amount"
|
||||||
|
|
||||||
rightsymbolamountp :: Monad m => JournalParser m Amount
|
rightsymbolamountp :: Monad m => JournalStateParser m Amount
|
||||||
rightsymbolamountp = do
|
rightsymbolamountp = do
|
||||||
(q,prec,mdec,mgrps) <- numberp
|
(q,prec,mdec,mgrps) <- lift numberp
|
||||||
sp <- many spacenonewline
|
sp <- lift $ many spacenonewline
|
||||||
c <- commoditysymbolp
|
c <- lift commoditysymbolp
|
||||||
p <- priceamountp
|
p <- priceamountp
|
||||||
let s = amountstyle{ascommodityside=R, ascommodityspaced=not $ null sp, asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps}
|
let s = amountstyle{ascommodityside=R, ascommodityspaced=not $ null sp, asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps}
|
||||||
return $ Amount c q p s
|
return $ Amount c q p s
|
||||||
<?> "right-symbol amount"
|
<?> "right-symbol amount"
|
||||||
|
|
||||||
nosymbolamountp :: Monad m => JournalParser m Amount
|
nosymbolamountp :: Monad m => JournalStateParser m Amount
|
||||||
nosymbolamountp = do
|
nosymbolamountp = do
|
||||||
(q,prec,mdec,mgrps) <- numberp
|
(q,prec,mdec,mgrps) <- lift numberp
|
||||||
p <- priceamountp
|
p <- priceamountp
|
||||||
-- apply the most recently seen default commodity and style to this commodityless amount
|
-- apply the most recently seen default commodity and style to this commodityless amount
|
||||||
defcs <- getDefaultCommodityAndStyle
|
defcs <- getDefaultCommodityAndStyle
|
||||||
@ -396,66 +397,66 @@ nosymbolamountp = do
|
|||||||
return $ Amount c q p s
|
return $ Amount c q p s
|
||||||
<?> "no-symbol amount"
|
<?> "no-symbol amount"
|
||||||
|
|
||||||
commoditysymbolp :: Monad m => JournalParser m CommoditySymbol
|
commoditysymbolp :: TextParser m CommoditySymbol
|
||||||
commoditysymbolp = (quotedcommoditysymbolp <|> simplecommoditysymbolp) <?> "commodity symbol"
|
commoditysymbolp = (quotedcommoditysymbolp <|> simplecommoditysymbolp) <?> "commodity symbol"
|
||||||
|
|
||||||
quotedcommoditysymbolp :: Monad m => JournalParser m CommoditySymbol
|
quotedcommoditysymbolp :: TextParser m CommoditySymbol
|
||||||
quotedcommoditysymbolp = do
|
quotedcommoditysymbolp = do
|
||||||
char '"'
|
char '"'
|
||||||
s <- many1 $ noneOf ";\n\""
|
s <- some $ noneOf (";\n\"" :: [Char])
|
||||||
char '"'
|
char '"'
|
||||||
return $ T.pack s
|
return $ T.pack s
|
||||||
|
|
||||||
simplecommoditysymbolp :: Monad m => JournalParser m CommoditySymbol
|
simplecommoditysymbolp :: TextParser m CommoditySymbol
|
||||||
simplecommoditysymbolp = T.pack <$> many1 (noneOf nonsimplecommoditychars)
|
simplecommoditysymbolp = T.pack <$> some (noneOf nonsimplecommoditychars)
|
||||||
|
|
||||||
priceamountp :: Monad m => JournalParser m Price
|
priceamountp :: Monad m => JournalStateParser m Price
|
||||||
priceamountp =
|
priceamountp =
|
||||||
try (do
|
try (do
|
||||||
many spacenonewline
|
lift (many spacenonewline)
|
||||||
char '@'
|
char '@'
|
||||||
try (do
|
try (do
|
||||||
char '@'
|
char '@'
|
||||||
many spacenonewline
|
lift (many spacenonewline)
|
||||||
a <- amountp -- XXX can parse more prices ad infinitum, shouldn't
|
a <- amountp -- XXX can parse more prices ad infinitum, shouldn't
|
||||||
return $ TotalPrice a)
|
return $ TotalPrice a)
|
||||||
<|> (do
|
<|> (do
|
||||||
many spacenonewline
|
lift (many spacenonewline)
|
||||||
a <- amountp -- XXX can parse more prices ad infinitum, shouldn't
|
a <- amountp -- XXX can parse more prices ad infinitum, shouldn't
|
||||||
return $ UnitPrice a))
|
return $ UnitPrice a))
|
||||||
<|> return NoPrice
|
<|> return NoPrice
|
||||||
|
|
||||||
partialbalanceassertionp :: Monad m => JournalParser m (Maybe MixedAmount)
|
partialbalanceassertionp :: ErroringJournalParser (Maybe MixedAmount)
|
||||||
partialbalanceassertionp =
|
partialbalanceassertionp =
|
||||||
try (do
|
try (do
|
||||||
many spacenonewline
|
lift (many spacenonewline)
|
||||||
char '='
|
char '='
|
||||||
many spacenonewline
|
lift (many spacenonewline)
|
||||||
a <- amountp -- XXX should restrict to a simple amount
|
a <- amountp -- XXX should restrict to a simple amount
|
||||||
return $ Just $ Mixed [a])
|
return $ Just $ Mixed [a])
|
||||||
<|> return Nothing
|
<|> return Nothing
|
||||||
|
|
||||||
-- balanceassertion :: Monad m => JournalParser m (Maybe MixedAmount)
|
-- balanceassertion :: Monad m => TextParser m (Maybe MixedAmount)
|
||||||
-- balanceassertion =
|
-- balanceassertion =
|
||||||
-- try (do
|
-- try (do
|
||||||
-- many spacenonewline
|
-- lift (many spacenonewline)
|
||||||
-- string "=="
|
-- string "=="
|
||||||
-- many spacenonewline
|
-- lift (many spacenonewline)
|
||||||
-- a <- amountp -- XXX should restrict to a simple amount
|
-- a <- amountp -- XXX should restrict to a simple amount
|
||||||
-- return $ Just $ Mixed [a])
|
-- return $ Just $ Mixed [a])
|
||||||
-- <|> return Nothing
|
-- <|> return Nothing
|
||||||
|
|
||||||
-- 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 :: ErroringJournalParser (Maybe Amount)
|
||||||
fixedlotpricep =
|
fixedlotpricep =
|
||||||
try (do
|
try (do
|
||||||
many spacenonewline
|
lift (many spacenonewline)
|
||||||
char '{'
|
char '{'
|
||||||
many spacenonewline
|
lift (many spacenonewline)
|
||||||
char '='
|
char '='
|
||||||
many spacenonewline
|
lift (many spacenonewline)
|
||||||
a <- amountp -- XXX should restrict to a simple amount
|
a <- amountp -- XXX should restrict to a simple amount
|
||||||
many spacenonewline
|
lift (many spacenonewline)
|
||||||
char '}'
|
char '}'
|
||||||
return $ Just a)
|
return $ Just a)
|
||||||
<|> return Nothing
|
<|> return Nothing
|
||||||
@ -472,13 +473,13 @@ fixedlotpricep =
|
|||||||
-- seen following the decimal point), the decimal point character used if any,
|
-- seen following the decimal point), the decimal point character used if any,
|
||||||
-- and the digit group style if any.
|
-- and the digit group style if any.
|
||||||
--
|
--
|
||||||
numberp :: Monad m => JournalParser m (Quantity, Int, Maybe Char, Maybe DigitGroupStyle)
|
numberp :: TextParser m (Quantity, Int, Maybe Char, Maybe DigitGroupStyle)
|
||||||
numberp = do
|
numberp = do
|
||||||
-- a number is an optional sign followed by a sequence of digits possibly
|
-- a number is an optional sign followed by a sequence of digits possibly
|
||||||
-- interspersed with periods, commas, or both
|
-- interspersed with periods, commas, or both
|
||||||
-- ptrace "numberp"
|
-- ptrace "numberp"
|
||||||
sign <- signp
|
sign <- signp
|
||||||
parts <- many1 $ choice' [many1 digit, many1 $ char ',', many1 $ char '.']
|
parts <- some $ choice' [some digitChar, some $ char ',', some $ char '.']
|
||||||
dbg8 "numberp parsed" (sign,parts) `seq` return ()
|
dbg8 "numberp parsed" (sign,parts) `seq` return ()
|
||||||
|
|
||||||
-- check the number is well-formed and identify the decimal point and digit
|
-- check the number is well-formed and identify the decimal point and digit
|
||||||
@ -546,26 +547,26 @@ numberp = do
|
|||||||
|
|
||||||
--- ** comments
|
--- ** comments
|
||||||
|
|
||||||
multilinecommentp :: Monad m => JournalParser m ()
|
multilinecommentp :: ErroringJournalParser ()
|
||||||
multilinecommentp = do
|
multilinecommentp = do
|
||||||
string "comment" >> many spacenonewline >> newline
|
string "comment" >> lift (many spacenonewline) >> newline
|
||||||
go
|
go
|
||||||
where
|
where
|
||||||
go = try (eof <|> (string "end comment" >> newline >> return ()))
|
go = try (eof <|> (string "end comment" >> newline >> return ()))
|
||||||
<|> (anyLine >> go)
|
<|> (anyLine >> go)
|
||||||
anyLine = anyChar `manyTill` newline
|
anyLine = anyChar `manyTill` newline
|
||||||
|
|
||||||
emptyorcommentlinep :: Monad m => JournalParser m ()
|
emptyorcommentlinep :: ErroringJournalParser ()
|
||||||
emptyorcommentlinep = do
|
emptyorcommentlinep = do
|
||||||
many spacenonewline >> (commentp <|> (many spacenonewline >> newline >> return ""))
|
lift (many spacenonewline) >> (commentp <|> (lift (many spacenonewline) >> newline >> return ""))
|
||||||
return ()
|
return ()
|
||||||
|
|
||||||
-- | Parse a possibly multi-line comment following a semicolon.
|
-- | Parse a possibly multi-line comment following a semicolon.
|
||||||
followingcommentp :: Monad m => JournalParser m Text
|
followingcommentp :: ErroringJournalParser Text
|
||||||
followingcommentp =
|
followingcommentp =
|
||||||
-- ptrace "followingcommentp"
|
-- ptrace "followingcommentp"
|
||||||
do samelinecomment <- many spacenonewline >> (try semicoloncommentp <|> (newline >> return ""))
|
do samelinecomment <- lift (many spacenonewline) >> (try semicoloncommentp <|> (newline >> return ""))
|
||||||
newlinecomments <- many (try (many1 spacenonewline >> semicoloncommentp))
|
newlinecomments <- many (try (lift (some spacenonewline) >> semicoloncommentp))
|
||||||
return $ T.unlines $ samelinecomment:newlinecomments
|
return $ T.unlines $ samelinecomment:newlinecomments
|
||||||
|
|
||||||
-- | Parse a possibly multi-line comment following a semicolon, and
|
-- | Parse a possibly multi-line comment following a semicolon, and
|
||||||
@ -580,7 +581,7 @@ followingcommentp =
|
|||||||
--
|
--
|
||||||
-- Year unspecified and no default provided -> unknown year error, at correct position:
|
-- Year unspecified and no default provided -> unknown year error, at correct position:
|
||||||
-- >>> rejp (followingcommentandtagsp Nothing) " ; xxx date:3/4\n ; second line"
|
-- >>> rejp (followingcommentandtagsp Nothing) " ; xxx date:3/4\n ; second line"
|
||||||
-- Left ...line 1, column 22...year is unknown...
|
-- Left ...1:22...partial date 3/4 found, but the current year is unknown...
|
||||||
--
|
--
|
||||||
-- Date tag value contains trailing text - forgot the comma, confused:
|
-- Date tag value contains trailing text - forgot the comma, confused:
|
||||||
-- the syntaxes ? We'll accept the leading date anyway
|
-- the syntaxes ? We'll accept the leading date anyway
|
||||||
@ -597,9 +598,9 @@ followingcommentandtagsp mdefdate = do
|
|||||||
startpos <- getPosition
|
startpos <- getPosition
|
||||||
commentandwhitespace :: String <- do
|
commentandwhitespace :: String <- do
|
||||||
let semicoloncommentp' = (:) <$> char ';' <*> anyChar `manyTill` eolof
|
let semicoloncommentp' = (:) <$> char ';' <*> anyChar `manyTill` eolof
|
||||||
sp1 <- many spacenonewline
|
sp1 <- lift (many spacenonewline)
|
||||||
l1 <- try semicoloncommentp' <|> (newline >> return "")
|
l1 <- try (lift semicoloncommentp') <|> (newline >> return "")
|
||||||
ls <- many $ try ((++) <$> many1 spacenonewline <*> semicoloncommentp')
|
ls <- lift . many $ try ((++) <$> some spacenonewline <*> semicoloncommentp')
|
||||||
return $ unlines $ (sp1 ++ l1) : ls
|
return $ unlines $ (sp1 ++ l1) : ls
|
||||||
let comment = T.pack $ unlines $ map (lstrip . dropWhile (==';') . strip) $ lines commentandwhitespace
|
let comment = T.pack $ unlines $ map (lstrip . dropWhile (==';') . strip) $ lines commentandwhitespace
|
||||||
-- pdbg 0 $ "commentws:"++show commentandwhitespace
|
-- pdbg 0 $ "commentws:"++show commentandwhitespace
|
||||||
@ -608,7 +609,7 @@ followingcommentandtagsp mdefdate = do
|
|||||||
-- Reparse the comment for any tags.
|
-- Reparse the comment for any tags.
|
||||||
tags <- case runTextParser (setPosition startpos >> tagsp) $ T.pack commentandwhitespace of
|
tags <- case runTextParser (setPosition startpos >> tagsp) $ T.pack commentandwhitespace of
|
||||||
Right ts -> return ts
|
Right ts -> return ts
|
||||||
Left e -> throwError $ show e
|
Left e -> throwError $ parseErrorPretty e
|
||||||
-- pdbg 0 $ "tags: "++show tags
|
-- pdbg 0 $ "tags: "++show tags
|
||||||
|
|
||||||
-- Reparse the comment for any posting dates. Use the transaction date for defaults, if provided.
|
-- Reparse the comment for any posting dates. Use the transaction date for defaults, if provided.
|
||||||
@ -622,21 +623,21 @@ followingcommentandtagsp mdefdate = do
|
|||||||
|
|
||||||
return (comment, tags, mdate, mdate2)
|
return (comment, tags, mdate, mdate2)
|
||||||
|
|
||||||
commentp :: Monad m => JournalParser m Text
|
commentp :: ErroringJournalParser Text
|
||||||
commentp = commentStartingWithp commentchars
|
commentp = commentStartingWithp commentchars
|
||||||
|
|
||||||
commentchars :: [Char]
|
commentchars :: [Char]
|
||||||
commentchars = "#;*"
|
commentchars = "#;*"
|
||||||
|
|
||||||
semicoloncommentp :: Monad m => JournalParser m Text
|
semicoloncommentp :: ErroringJournalParser Text
|
||||||
semicoloncommentp = commentStartingWithp ";"
|
semicoloncommentp = commentStartingWithp ";"
|
||||||
|
|
||||||
commentStartingWithp :: Monad m => [Char] -> JournalParser m Text
|
commentStartingWithp :: [Char] -> ErroringJournalParser Text
|
||||||
commentStartingWithp cs = do
|
commentStartingWithp cs = do
|
||||||
-- ptrace "commentStartingWith"
|
-- ptrace "commentStartingWith"
|
||||||
oneOf cs
|
oneOf cs
|
||||||
many spacenonewline
|
lift (many spacenonewline)
|
||||||
l <- anyChar `manyTill` eolof
|
l <- anyChar `manyTill` (lift eolof)
|
||||||
optional newline
|
optional newline
|
||||||
return $ T.pack l
|
return $ T.pack l
|
||||||
|
|
||||||
@ -662,7 +663,7 @@ commentTags s =
|
|||||||
Left _ -> [] -- shouldn't happen
|
Left _ -> [] -- shouldn't happen
|
||||||
|
|
||||||
-- | Parse all tags found in a string.
|
-- | Parse all tags found in a string.
|
||||||
tagsp :: TextParser u Identity [Tag]
|
tagsp :: Parser [Tag]
|
||||||
tagsp = -- do
|
tagsp = -- do
|
||||||
-- pdbg 0 $ "tagsp"
|
-- pdbg 0 $ "tagsp"
|
||||||
many (try (nontagp >> tagp))
|
many (try (nontagp >> tagp))
|
||||||
@ -671,7 +672,7 @@ tagsp = -- do
|
|||||||
--
|
--
|
||||||
-- >>> rtp nontagp "\na b:, \nd:e, f"
|
-- >>> rtp nontagp "\na b:, \nd:e, f"
|
||||||
-- Right "\na "
|
-- Right "\na "
|
||||||
nontagp :: TextParser u Identity String
|
nontagp :: Parser String
|
||||||
nontagp = -- do
|
nontagp = -- do
|
||||||
-- pdbg 0 "nontagp"
|
-- pdbg 0 "nontagp"
|
||||||
-- anyChar `manyTill` (lookAhead (try (tagorbracketeddatetagsp Nothing >> return ()) <|> eof))
|
-- anyChar `manyTill` (lookAhead (try (tagorbracketeddatetagsp Nothing >> return ()) <|> eof))
|
||||||
@ -685,7 +686,7 @@ nontagp = -- do
|
|||||||
-- >>> rtp tagp "a:b b , c AuxDate: 4/2"
|
-- >>> rtp tagp "a:b b , c AuxDate: 4/2"
|
||||||
-- Right ("a","b b")
|
-- Right ("a","b b")
|
||||||
--
|
--
|
||||||
tagp :: Monad m => TextParser u m Tag
|
tagp :: Parser Tag
|
||||||
tagp = do
|
tagp = do
|
||||||
-- pdbg 0 "tagp"
|
-- pdbg 0 "tagp"
|
||||||
n <- tagnamep
|
n <- tagnamep
|
||||||
@ -695,12 +696,12 @@ tagp = do
|
|||||||
-- |
|
-- |
|
||||||
-- >>> rtp tagnamep "a:"
|
-- >>> rtp tagnamep "a:"
|
||||||
-- Right "a"
|
-- Right "a"
|
||||||
tagnamep :: Monad m => TextParser u m Text
|
tagnamep :: Parser Text
|
||||||
tagnamep = -- do
|
tagnamep = -- do
|
||||||
-- pdbg 0 "tagnamep"
|
-- pdbg 0 "tagnamep"
|
||||||
T.pack <$> many1 (noneOf ": \t\n") <* char ':'
|
T.pack <$> some (noneOf (": \t\n" :: [Char])) <* char ':'
|
||||||
|
|
||||||
tagvaluep :: Monad m => TextParser u m Text
|
tagvaluep :: TextParser m Text
|
||||||
tagvaluep = do
|
tagvaluep = do
|
||||||
-- ptrace "tagvalue"
|
-- ptrace "tagvalue"
|
||||||
v <- anyChar `manyTill` (void (try (char ',')) <|> eolof)
|
v <- anyChar `manyTill` (void (try (char ',')) <|> eolof)
|
||||||
@ -736,29 +737,30 @@ postingdatesp mdefdate = do
|
|||||||
-- Right ("date2",2001-03-04)
|
-- Right ("date2",2001-03-04)
|
||||||
--
|
--
|
||||||
-- >>> rejp (datetagp Nothing) "date: 3/4"
|
-- >>> rejp (datetagp Nothing) "date: 3/4"
|
||||||
-- Left ...line 1, column 9...year is unknown...
|
-- Left ...1:9...partial date 3/4 found, but the current year is unknown...
|
||||||
--
|
--
|
||||||
datetagp :: Maybe Day -> ErroringJournalParser (TagName,Day)
|
datetagp :: Maybe Day -> ErroringJournalParser (TagName,Day)
|
||||||
datetagp mdefdate = do
|
datetagp mdefdate = do
|
||||||
-- pdbg 0 "datetagp"
|
-- pdbg 0 "datetagp"
|
||||||
string "date"
|
string "date"
|
||||||
n <- T.pack . fromMaybe "" <$> optionMaybe (string "2")
|
n <- T.pack . fromMaybe "" <$> optional (string "2")
|
||||||
char ':'
|
char ':'
|
||||||
startpos <- getPosition
|
startpos <- getPosition
|
||||||
v <- tagvaluep
|
v <- lift tagvaluep
|
||||||
-- re-parse value as a date.
|
-- re-parse value as a date.
|
||||||
j <- getState
|
j <- get
|
||||||
ep <- parseWithState
|
let ep :: Either (ParseError Char Dec) Day
|
||||||
j{jparsedefaultyear=first3.toGregorian <$> mdefdate}
|
ep = parseWithState'
|
||||||
-- The value extends to a comma, newline, or end of file.
|
j{jparsedefaultyear=first3.toGregorian <$> mdefdate}
|
||||||
-- It seems like ignoring any extra stuff following a date
|
-- The value extends to a comma, newline, or end of file.
|
||||||
-- gives better errors here.
|
-- It seems like ignoring any extra stuff following a date
|
||||||
(do
|
-- gives better errors here.
|
||||||
setPosition startpos
|
(do
|
||||||
datep) -- <* eof)
|
setPosition startpos
|
||||||
v
|
datep) -- <* eof)
|
||||||
|
v
|
||||||
case ep
|
case ep
|
||||||
of Left e -> throwError $ show e
|
of Left e -> throwError $ parseErrorPretty e
|
||||||
Right d -> return ("date"<>n, d)
|
Right d -> return ("date"<>n, d)
|
||||||
|
|
||||||
--- ** bracketed dates
|
--- ** bracketed dates
|
||||||
@ -785,13 +787,13 @@ datetagp mdefdate = do
|
|||||||
-- Left ...not a bracketed date...
|
-- Left ...not a bracketed date...
|
||||||
--
|
--
|
||||||
-- >>> rejp (bracketeddatetagsp Nothing) "[2016/1/32]"
|
-- >>> rejp (bracketeddatetagsp Nothing) "[2016/1/32]"
|
||||||
-- Left ...line 1, column 11...bad date...
|
-- Left ...1:11:...bad date: 2016/1/32...
|
||||||
--
|
--
|
||||||
-- >>> rejp (bracketeddatetagsp Nothing) "[1/31]"
|
-- >>> rejp (bracketeddatetagsp Nothing) "[1/31]"
|
||||||
-- Left ...line 1, column 6...year is unknown...
|
-- Left ...1:6:...partial date 1/31 found, but the current year is unknown...
|
||||||
--
|
--
|
||||||
-- >>> rejp (bracketeddatetagsp Nothing) "[0123456789/-.=/-.=]"
|
-- >>> rejp (bracketeddatetagsp Nothing) "[0123456789/-.=/-.=]"
|
||||||
-- Left ...line 1, column 15...bad date, different separators...
|
-- Left ...1:15:...bad date, different separators...
|
||||||
--
|
--
|
||||||
bracketeddatetagsp :: Maybe Day -> ErroringJournalParser [(TagName, Day)]
|
bracketeddatetagsp :: Maybe Day -> ErroringJournalParser [(TagName, Day)]
|
||||||
bracketeddatetagsp mdefdate = do
|
bracketeddatetagsp mdefdate = do
|
||||||
@ -799,27 +801,28 @@ bracketeddatetagsp mdefdate = do
|
|||||||
char '['
|
char '['
|
||||||
startpos <- getPosition
|
startpos <- getPosition
|
||||||
let digits = "0123456789"
|
let digits = "0123456789"
|
||||||
s <- many1 (oneOf $ '=':digits++datesepchars)
|
s <- some (oneOf $ '=':digits++datesepchars)
|
||||||
char ']'
|
char ']'
|
||||||
unless (any (`elem` s) digits && any (`elem` datesepchars) s) $
|
unless (any (`elem` s) digits && any (`elem` datesepchars) s) $
|
||||||
parserFail "not a bracketed date"
|
fail "not a bracketed date"
|
||||||
|
|
||||||
-- looks sufficiently like a bracketed date, now we
|
-- looks sufficiently like a bracketed date, now we
|
||||||
-- re-parse as dates and throw any errors
|
-- re-parse as dates and throw any errors
|
||||||
j <- getState
|
j <- get
|
||||||
ep <- parseWithState
|
let ep :: Either (ParseError Char Dec) (Maybe Day, Maybe Day)
|
||||||
j{jparsedefaultyear=first3.toGregorian <$> mdefdate}
|
ep = parseWithState'
|
||||||
(do
|
j{jparsedefaultyear=first3.toGregorian <$> mdefdate}
|
||||||
setPosition startpos
|
(do
|
||||||
md1 <- optionMaybe datep
|
setPosition startpos
|
||||||
maybe (return ()) (setYear.first3.toGregorian) md1
|
md1 <- optional datep
|
||||||
md2 <- optionMaybe $ char '=' >> datep
|
maybe (return ()) (setYear.first3.toGregorian) md1
|
||||||
eof
|
md2 <- optional $ char '=' >> datep
|
||||||
return (md1,md2)
|
eof
|
||||||
)
|
return (md1,md2)
|
||||||
(T.pack s)
|
)
|
||||||
|
(T.pack s)
|
||||||
case ep
|
case ep
|
||||||
of Left e -> throwError $ show e
|
of Left e -> throwError $ parseErrorPretty e
|
||||||
Right (md1,md2) -> return $ catMaybes
|
Right (md1,md2) -> return $ catMaybes
|
||||||
[("date",) <$> md1, ("date2",) <$> md2]
|
[("date",) <$> md1, ("date2",) <$> md2]
|
||||||
|
|
||||||
|
|||||||
@ -6,6 +6,9 @@ A reader for CSV data, using an extra rules file to help interpret the data.
|
|||||||
-}
|
-}
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
|
|
||||||
module Hledger.Read.CsvReader (
|
module Hledger.Read.CsvReader (
|
||||||
-- * Reader
|
-- * Reader
|
||||||
@ -25,11 +28,13 @@ import Prelude.Compat hiding (getContents)
|
|||||||
import Control.Exception hiding (try)
|
import Control.Exception hiding (try)
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Control.Monad.Except
|
import Control.Monad.Except
|
||||||
|
import Control.Monad.State.Strict (StateT, State, get, modify', evalStateT)
|
||||||
-- import Test.HUnit
|
-- import Test.HUnit
|
||||||
import Data.Char (toLower, isDigit, isSpace)
|
import Data.Char (toLower, isDigit, isSpace)
|
||||||
import Data.List.Compat
|
import Data.List.Compat
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Data.Ord
|
import Data.Ord
|
||||||
|
import qualified Data.Set as S
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import Data.Time.Calendar (Day)
|
import Data.Time.Calendar (Day)
|
||||||
@ -43,11 +48,11 @@ import Safe
|
|||||||
import System.Directory (doesFileExist)
|
import System.Directory (doesFileExist)
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
import System.IO (stderr)
|
import System.IO (stderr)
|
||||||
import Test.HUnit
|
import Test.HUnit hiding (State)
|
||||||
import Text.CSV (parseCSV, CSV)
|
import Text.CSV (parseCSV, CSV)
|
||||||
import Text.Parsec hiding (parse)
|
import Text.Megaparsec hiding (parse, State)
|
||||||
import Text.Parsec.Pos
|
import Text.Megaparsec.Text
|
||||||
import Text.Parsec.Error
|
import qualified Text.Parsec as Parsec
|
||||||
import Text.Printf (hPrintf,printf)
|
import Text.Printf (hPrintf,printf)
|
||||||
|
|
||||||
import Hledger.Data
|
import Hledger.Data
|
||||||
@ -126,7 +131,12 @@ readJournalFromCsv mrulesfile csvfile csvdata =
|
|||||||
|
|
||||||
-- convert to transactions and return as a journal
|
-- convert to transactions and return as a journal
|
||||||
let txns = snd $ mapAccumL
|
let txns = snd $ mapAccumL
|
||||||
(\pos r -> (pos, transactionFromCsvRecord (incSourceLine pos 1) rules r))
|
(\pos r -> (pos,
|
||||||
|
transactionFromCsvRecord
|
||||||
|
(let SourcePos name line col = pos in
|
||||||
|
SourcePos name (unsafePos $ unPos line + 1) col)
|
||||||
|
rules
|
||||||
|
r))
|
||||||
(initialPos parsecfilename) records
|
(initialPos parsecfilename) records
|
||||||
|
|
||||||
-- heuristic: if the records appear to have been in reverse date order,
|
-- heuristic: if the records appear to have been in reverse date order,
|
||||||
@ -136,14 +146,14 @@ readJournalFromCsv mrulesfile csvfile csvdata =
|
|||||||
| otherwise = txns
|
| otherwise = txns
|
||||||
return $ Right nulljournal{jtxns=sortBy (comparing tdate) txns'}
|
return $ Right nulljournal{jtxns=sortBy (comparing tdate) txns'}
|
||||||
|
|
||||||
parseCsv :: FilePath -> String -> IO (Either ParseError CSV)
|
parseCsv :: FilePath -> String -> IO (Either Parsec.ParseError CSV)
|
||||||
parseCsv path csvdata =
|
parseCsv path csvdata =
|
||||||
case path of
|
case path of
|
||||||
"-" -> liftM (parseCSV "(stdin)") getContents
|
"-" -> liftM (parseCSV "(stdin)") getContents
|
||||||
_ -> return $ parseCSV path csvdata
|
_ -> return $ parseCSV path csvdata
|
||||||
|
|
||||||
-- | Return the cleaned up and validated CSV data, or an error.
|
-- | Return the cleaned up and validated CSV data, or an error.
|
||||||
validateCsv :: Int -> Either ParseError CSV -> Either String [CsvRecord]
|
validateCsv :: Int -> Either Parsec.ParseError CSV -> Either String [CsvRecord]
|
||||||
validateCsv _ (Left e) = Left $ show e
|
validateCsv _ (Left e) = Left $ show e
|
||||||
validateCsv numhdrlines (Right rs) = validate $ drop numhdrlines $ filternulls rs
|
validateCsv numhdrlines (Right rs) = validate $ drop numhdrlines $ filternulls rs
|
||||||
where
|
where
|
||||||
@ -298,6 +308,8 @@ data CsvRules = CsvRules {
|
|||||||
rconditionalblocks :: [ConditionalBlock]
|
rconditionalblocks :: [ConditionalBlock]
|
||||||
} deriving (Show, Eq)
|
} deriving (Show, Eq)
|
||||||
|
|
||||||
|
type CsvRulesParser a = StateT CsvRules Parser a
|
||||||
|
|
||||||
type DirectiveName = String
|
type DirectiveName = String
|
||||||
type CsvFieldName = String
|
type CsvFieldName = String
|
||||||
type CsvFieldIndex = Int
|
type CsvFieldIndex = Int
|
||||||
@ -354,26 +366,27 @@ parseRulesFile f = do
|
|||||||
Left e -> return $ Left $ show $ toParseError e
|
Left e -> return $ Left $ show $ toParseError e
|
||||||
Right r -> return $ Right r
|
Right r -> return $ Right r
|
||||||
where
|
where
|
||||||
toParseError s = newErrorMessage (Message s) (initialPos "")
|
toParseError :: forall s. Ord s => s -> ParseError Char s
|
||||||
|
toParseError s = (mempty :: ParseError Char s) { errorCustom = S.singleton s}
|
||||||
|
|
||||||
-- | Pre-parse csv rules to interpolate included files, recursively.
|
-- | Pre-parse csv rules to interpolate included files, recursively.
|
||||||
-- This is a cheap hack to avoid rewriting the existing parser.
|
-- This is a cheap hack to avoid rewriting the existing parser.
|
||||||
expandIncludes :: FilePath -> String -> IO String
|
expandIncludes :: FilePath -> T.Text -> IO T.Text
|
||||||
expandIncludes basedir content = do
|
expandIncludes basedir content = do
|
||||||
let (ls,rest) = break (isPrefixOf "include") $ lines content
|
let (ls,rest) = break (T.isPrefixOf "include") $ T.lines content
|
||||||
case rest of
|
case rest of
|
||||||
[] -> return $ unlines ls
|
[] -> return $ T.unlines ls
|
||||||
(('i':'n':'c':'l':'u':'d':'e':f):ls') -> do
|
((T.stripPrefix "include" -> Just f):ls') -> do
|
||||||
let f' = basedir </> dropWhile isSpace f
|
let f' = basedir </> dropWhile isSpace (T.unpack f)
|
||||||
basedir' = takeDirectory f'
|
basedir' = takeDirectory f'
|
||||||
included <- readFile f' >>= expandIncludes basedir'
|
included <- readFile' f' >>= expandIncludes basedir'
|
||||||
return $ unlines [unlines ls, included, unlines ls']
|
return $ T.unlines [T.unlines ls, included, T.unlines ls']
|
||||||
ls' -> return $ unlines $ ls ++ ls' -- should never get here
|
ls' -> return $ T.unlines $ ls ++ ls' -- should never get here
|
||||||
|
|
||||||
parseCsvRules :: FilePath -> String -> Either ParseError CsvRules
|
parseCsvRules :: FilePath -> T.Text -> Either (ParseError Char Dec) CsvRules
|
||||||
-- parseCsvRules rulesfile s = runParser csvrulesfile nullrules{baseAccount=takeBaseName rulesfile} rulesfile s
|
-- parseCsvRules rulesfile s = runParser csvrulesfile nullrules{baseAccount=takeBaseName rulesfile} rulesfile s
|
||||||
parseCsvRules rulesfile s =
|
parseCsvRules rulesfile s =
|
||||||
runParser rulesp rules rulesfile s
|
runParser (evalStateT rulesp rules) rulesfile s
|
||||||
|
|
||||||
-- | Return the validated rules, or an error.
|
-- | Return the validated rules, or an error.
|
||||||
validateRules :: CsvRules -> ExceptT String IO CsvRules
|
validateRules :: CsvRules -> ExceptT String IO CsvRules
|
||||||
@ -391,40 +404,40 @@ validateRules rules = do
|
|||||||
|
|
||||||
-- parsers
|
-- parsers
|
||||||
|
|
||||||
rulesp :: Stream [Char] m t => ParsecT [Char] CsvRules m CsvRules
|
rulesp :: CsvRulesParser CsvRules
|
||||||
rulesp = do
|
rulesp = do
|
||||||
many $ choice'
|
many $ choiceInState
|
||||||
[blankorcommentlinep <?> "blank or comment line"
|
[blankorcommentlinep <?> "blank or comment line"
|
||||||
,(directivep >>= modifyState . addDirective) <?> "directive"
|
,(directivep >>= modify' . addDirective) <?> "directive"
|
||||||
,(fieldnamelistp >>= modifyState . setIndexesAndAssignmentsFromList) <?> "field name list"
|
,(fieldnamelistp >>= modify' . setIndexesAndAssignmentsFromList) <?> "field name list"
|
||||||
,(fieldassignmentp >>= modifyState . addAssignment) <?> "field assignment"
|
,(fieldassignmentp >>= modify' . addAssignment) <?> "field assignment"
|
||||||
,(conditionalblockp >>= modifyState . addConditionalBlock) <?> "conditional block"
|
,(conditionalblockp >>= modify' . addConditionalBlock) <?> "conditional block"
|
||||||
]
|
]
|
||||||
eof
|
eof
|
||||||
r <- getState
|
r <- get
|
||||||
return r{rdirectives=reverse $ rdirectives r
|
return r{rdirectives=reverse $ rdirectives r
|
||||||
,rassignments=reverse $ rassignments r
|
,rassignments=reverse $ rassignments r
|
||||||
,rconditionalblocks=reverse $ rconditionalblocks r
|
,rconditionalblocks=reverse $ rconditionalblocks r
|
||||||
}
|
}
|
||||||
|
|
||||||
blankorcommentlinep :: Stream [Char] m t => ParsecT [Char] CsvRules m ()
|
blankorcommentlinep :: CsvRulesParser ()
|
||||||
blankorcommentlinep = pdbg 3 "trying blankorcommentlinep" >> choice' [blanklinep, commentlinep]
|
blankorcommentlinep = lift (pdbg 3 "trying blankorcommentlinep") >> choiceInState [blanklinep, commentlinep]
|
||||||
|
|
||||||
blanklinep :: Stream [Char] m t => ParsecT [Char] CsvRules m ()
|
blanklinep :: CsvRulesParser ()
|
||||||
blanklinep = many spacenonewline >> newline >> return () <?> "blank line"
|
blanklinep = lift (many spacenonewline) >> newline >> return () <?> "blank line"
|
||||||
|
|
||||||
commentlinep :: Stream [Char] m t => ParsecT [Char] CsvRules m ()
|
commentlinep :: CsvRulesParser ()
|
||||||
commentlinep = many spacenonewline >> commentcharp >> restofline >> return () <?> "comment line"
|
commentlinep = lift (many spacenonewline) >> commentcharp >> lift restofline >> return () <?> "comment line"
|
||||||
|
|
||||||
commentcharp :: Stream [Char] m t => ParsecT [Char] CsvRules m Char
|
commentcharp :: CsvRulesParser Char
|
||||||
commentcharp = oneOf ";#*"
|
commentcharp = oneOf (";#*" :: [Char])
|
||||||
|
|
||||||
directivep :: Stream [Char] m t => ParsecT [Char] CsvRules m (DirectiveName, String)
|
directivep :: CsvRulesParser (DirectiveName, String)
|
||||||
directivep = (do
|
directivep = (do
|
||||||
pdbg 3 "trying directive"
|
lift $ pdbg 3 "trying directive"
|
||||||
d <- choice' $ map string directives
|
d <- choiceInState $ map string directives
|
||||||
v <- (((char ':' >> many spacenonewline) <|> many1 spacenonewline) >> directivevalp)
|
v <- (((char ':' >> lift (many spacenonewline)) <|> lift (some spacenonewline)) >> directivevalp)
|
||||||
<|> (optional (char ':') >> many spacenonewline >> eolof >> return "")
|
<|> (optional (char ':') >> lift (many spacenonewline) >> lift eolof >> return "")
|
||||||
return (d,v)
|
return (d,v)
|
||||||
) <?> "directive"
|
) <?> "directive"
|
||||||
|
|
||||||
@ -438,46 +451,46 @@ directives =
|
|||||||
-- ,"base-currency"
|
-- ,"base-currency"
|
||||||
]
|
]
|
||||||
|
|
||||||
directivevalp :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]
|
directivevalp :: CsvRulesParser String
|
||||||
directivevalp = anyChar `manyTill` eolof
|
directivevalp = anyChar `manyTill` lift eolof
|
||||||
|
|
||||||
fieldnamelistp :: Stream [Char] m t => ParsecT [Char] CsvRules m [CsvFieldName]
|
fieldnamelistp :: CsvRulesParser [CsvFieldName]
|
||||||
fieldnamelistp = (do
|
fieldnamelistp = (do
|
||||||
pdbg 3 "trying fieldnamelist"
|
lift $ pdbg 3 "trying fieldnamelist"
|
||||||
string "fields"
|
string "fields"
|
||||||
optional $ char ':'
|
optional $ char ':'
|
||||||
many1 spacenonewline
|
lift (some spacenonewline)
|
||||||
let separator = many spacenonewline >> char ',' >> many spacenonewline
|
let separator = lift (many spacenonewline) >> char ',' >> lift (many spacenonewline)
|
||||||
f <- fromMaybe "" <$> optionMaybe fieldnamep
|
f <- fromMaybe "" <$> optional fieldnamep
|
||||||
fs <- many1 $ (separator >> fromMaybe "" <$> optionMaybe fieldnamep)
|
fs <- some $ (separator >> fromMaybe "" <$> optional fieldnamep)
|
||||||
restofline
|
lift restofline
|
||||||
return $ map (map toLower) $ f:fs
|
return $ map (map toLower) $ f:fs
|
||||||
) <?> "field name list"
|
) <?> "field name list"
|
||||||
|
|
||||||
fieldnamep :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]
|
fieldnamep :: CsvRulesParser String
|
||||||
fieldnamep = quotedfieldnamep <|> barefieldnamep
|
fieldnamep = quotedfieldnamep <|> barefieldnamep
|
||||||
|
|
||||||
quotedfieldnamep :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]
|
quotedfieldnamep :: CsvRulesParser String
|
||||||
quotedfieldnamep = do
|
quotedfieldnamep = do
|
||||||
char '"'
|
char '"'
|
||||||
f <- many1 $ noneOf "\"\n:;#~"
|
f <- some $ noneOf ("\"\n:;#~" :: [Char])
|
||||||
char '"'
|
char '"'
|
||||||
return f
|
return f
|
||||||
|
|
||||||
barefieldnamep :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]
|
barefieldnamep :: CsvRulesParser String
|
||||||
barefieldnamep = many1 $ noneOf " \t\n,;#~"
|
barefieldnamep = some $ noneOf (" \t\n,;#~" :: [Char])
|
||||||
|
|
||||||
fieldassignmentp :: Stream [Char] m t => ParsecT [Char] CsvRules m (JournalFieldName, FieldTemplate)
|
fieldassignmentp :: CsvRulesParser (JournalFieldName, FieldTemplate)
|
||||||
fieldassignmentp = do
|
fieldassignmentp = do
|
||||||
pdbg 3 "trying fieldassignment"
|
lift $ pdbg 3 "trying fieldassignmentp"
|
||||||
f <- journalfieldnamep
|
f <- journalfieldnamep
|
||||||
assignmentseparatorp
|
assignmentseparatorp
|
||||||
v <- fieldvalp
|
v <- fieldvalp
|
||||||
return (f,v)
|
return (f,v)
|
||||||
<?> "field assignment"
|
<?> "field assignment"
|
||||||
|
|
||||||
journalfieldnamep :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]
|
journalfieldnamep :: CsvRulesParser String
|
||||||
journalfieldnamep = pdbg 2 "trying journalfieldnamep" >> choice' (map string journalfieldnames)
|
journalfieldnamep = lift (pdbg 2 "trying journalfieldnamep") >> choiceInState (map string journalfieldnames)
|
||||||
|
|
||||||
journalfieldnames =
|
journalfieldnames =
|
||||||
[-- pseudo fields:
|
[-- pseudo fields:
|
||||||
@ -496,74 +509,74 @@ journalfieldnames =
|
|||||||
,"comment"
|
,"comment"
|
||||||
]
|
]
|
||||||
|
|
||||||
assignmentseparatorp :: Stream [Char] m t => ParsecT [Char] CsvRules m ()
|
assignmentseparatorp :: CsvRulesParser ()
|
||||||
assignmentseparatorp = do
|
assignmentseparatorp = do
|
||||||
pdbg 3 "trying assignmentseparatorp"
|
lift $ pdbg 3 "trying assignmentseparatorp"
|
||||||
choice [
|
choice [
|
||||||
-- try (many spacenonewline >> oneOf ":="),
|
-- try (lift (many spacenonewline) >> oneOf ":="),
|
||||||
try (many spacenonewline >> char ':'),
|
try (void $ lift (many spacenonewline) >> char ':'),
|
||||||
space
|
space
|
||||||
]
|
]
|
||||||
_ <- many spacenonewline
|
_ <- lift (many spacenonewline)
|
||||||
return ()
|
return ()
|
||||||
|
|
||||||
fieldvalp :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]
|
fieldvalp :: CsvRulesParser String
|
||||||
fieldvalp = do
|
fieldvalp = do
|
||||||
pdbg 2 "trying fieldval"
|
lift $ pdbg 2 "trying fieldvalp"
|
||||||
anyChar `manyTill` eolof
|
anyChar `manyTill` lift eolof
|
||||||
|
|
||||||
conditionalblockp :: Stream [Char] m t => ParsecT [Char] CsvRules m ConditionalBlock
|
conditionalblockp :: CsvRulesParser ConditionalBlock
|
||||||
conditionalblockp = do
|
conditionalblockp = do
|
||||||
pdbg 3 "trying conditionalblockp"
|
lift $ pdbg 3 "trying conditionalblockp"
|
||||||
string "if" >> many spacenonewline >> optional newline
|
string "if" >> lift (many spacenonewline) >> optional newline
|
||||||
ms <- many1 recordmatcherp
|
ms <- some recordmatcherp
|
||||||
as <- many (many1 spacenonewline >> fieldassignmentp)
|
as <- many (lift (some spacenonewline) >> fieldassignmentp)
|
||||||
when (null as) $
|
when (null as) $
|
||||||
fail "start of conditional block found, but no assignment rules afterward\n(assignment rules in a conditional block should be indented)\n"
|
fail "start of conditional block found, but no assignment rules afterward\n(assignment rules in a conditional block should be indented)\n"
|
||||||
return (ms, as)
|
return (ms, as)
|
||||||
<?> "conditional block"
|
<?> "conditional block"
|
||||||
|
|
||||||
recordmatcherp :: Stream [Char] m t => ParsecT [Char] CsvRules m [[Char]]
|
recordmatcherp :: CsvRulesParser [String]
|
||||||
recordmatcherp = do
|
recordmatcherp = do
|
||||||
pdbg 2 "trying recordmatcherp"
|
lift $ pdbg 2 "trying recordmatcherp"
|
||||||
-- pos <- currentPos
|
-- pos <- currentPos
|
||||||
_ <- optional (matchoperatorp >> many spacenonewline >> optional newline)
|
_ <- optional (matchoperatorp >> lift (many spacenonewline) >> optional newline)
|
||||||
ps <- patternsp
|
ps <- patternsp
|
||||||
when (null ps) $
|
when (null ps) $
|
||||||
fail "start of record matcher found, but no patterns afterward\n(patterns should not be indented)\n"
|
fail "start of record matcher found, but no patterns afterward\n(patterns should not be indented)\n"
|
||||||
return ps
|
return ps
|
||||||
<?> "record matcher"
|
<?> "record matcher"
|
||||||
|
|
||||||
matchoperatorp :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]
|
matchoperatorp :: CsvRulesParser String
|
||||||
matchoperatorp = choice' $ map string
|
matchoperatorp = choiceInState $ map string
|
||||||
["~"
|
["~"
|
||||||
-- ,"!~"
|
-- ,"!~"
|
||||||
-- ,"="
|
-- ,"="
|
||||||
-- ,"!="
|
-- ,"!="
|
||||||
]
|
]
|
||||||
|
|
||||||
patternsp :: Stream [Char] m t => ParsecT [Char] CsvRules m [[Char]]
|
patternsp :: CsvRulesParser [String]
|
||||||
patternsp = do
|
patternsp = do
|
||||||
pdbg 3 "trying patternsp"
|
lift $ pdbg 3 "trying patternsp"
|
||||||
ps <- many regexp
|
ps <- many regexp
|
||||||
return ps
|
return ps
|
||||||
|
|
||||||
regexp :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]
|
regexp :: CsvRulesParser String
|
||||||
regexp = do
|
regexp = do
|
||||||
pdbg 3 "trying regexp"
|
lift $ pdbg 3 "trying regexp"
|
||||||
notFollowedBy matchoperatorp
|
notFollowedBy matchoperatorp
|
||||||
c <- nonspace
|
c <- lift nonspace
|
||||||
cs <- anyChar `manyTill` eolof
|
cs <- anyChar `manyTill` lift eolof
|
||||||
return $ strip $ c:cs
|
return $ strip $ c:cs
|
||||||
|
|
||||||
-- fieldmatcher = do
|
-- fieldmatcher = do
|
||||||
-- pdbg 2 "trying fieldmatcher"
|
-- pdbg 2 "trying fieldmatcher"
|
||||||
-- f <- fromMaybe "all" `fmap` (optionMaybe $ do
|
-- f <- fromMaybe "all" `fmap` (optional $ do
|
||||||
-- f' <- fieldname
|
-- f' <- fieldname
|
||||||
-- many spacenonewline
|
-- lift (many spacenonewline)
|
||||||
-- return f')
|
-- return f')
|
||||||
-- char '~'
|
-- char '~'
|
||||||
-- many spacenonewline
|
-- lift (many spacenonewline)
|
||||||
-- ps <- patterns
|
-- ps <- patterns
|
||||||
-- let r = "(" ++ intercalate "|" ps ++ ")"
|
-- let r = "(" ++ intercalate "|" ps ++ ")"
|
||||||
-- return (f,r)
|
-- return (f,r)
|
||||||
@ -607,7 +620,9 @@ transactionFromCsvRecord sourcepos rules record = t
|
|||||||
status =
|
status =
|
||||||
case mfieldtemplate "status" of
|
case mfieldtemplate "status" of
|
||||||
Nothing -> Uncleared
|
Nothing -> Uncleared
|
||||||
Just str -> either statuserror id $ runParser (statusp <* eof) mempty "" $ T.pack $ render str
|
Just str -> either statuserror id .
|
||||||
|
runParser (statusp <* eof) "" .
|
||||||
|
T.pack $ render str
|
||||||
where
|
where
|
||||||
statuserror err = error' $ unlines
|
statuserror err = error' $ unlines
|
||||||
["error: could not parse \""++str++"\" as a cleared status (should be *, ! or empty)"
|
["error: could not parse \""++str++"\" as a cleared status (should be *, ! or empty)"
|
||||||
@ -619,7 +634,7 @@ transactionFromCsvRecord sourcepos rules record = t
|
|||||||
precomment = maybe "" render $ mfieldtemplate "precomment"
|
precomment = maybe "" render $ mfieldtemplate "precomment"
|
||||||
currency = maybe (fromMaybe "" mdefaultcurrency) render $ mfieldtemplate "currency"
|
currency = maybe (fromMaybe "" mdefaultcurrency) render $ mfieldtemplate "currency"
|
||||||
amountstr = (currency++) $ negateIfParenthesised $ getAmountStr rules record
|
amountstr = (currency++) $ negateIfParenthesised $ getAmountStr rules record
|
||||||
amount = either amounterror (Mixed . (:[])) $ runParser (amountp <* eof) mempty "" $ T.pack amountstr
|
amount = either amounterror (Mixed . (:[])) $ runParser (evalStateT (amountp <* eof) mempty) "" $ T.pack amountstr
|
||||||
amounterror err = error' $ unlines
|
amounterror err = error' $ unlines
|
||||||
["error: could not parse \""++amountstr++"\" as an amount"
|
["error: could not parse \""++amountstr++"\" as an amount"
|
||||||
,showRecord record
|
,showRecord record
|
||||||
@ -786,10 +801,10 @@ test_parser = [
|
|||||||
-- ([("A",Nothing)], "a")
|
-- ([("A",Nothing)], "a")
|
||||||
|
|
||||||
,"convert rules parsing: trailing comments" ~: do
|
,"convert rules parsing: trailing comments" ~: do
|
||||||
assertParse (parseWithState rules rulesp "skip\n# \n#\n")
|
assertParse (parseWithState' rules rulesp "skip\n# \n#\n")
|
||||||
|
|
||||||
,"convert rules parsing: trailing blank lines" ~: do
|
,"convert rules parsing: trailing blank lines" ~: do
|
||||||
assertParse (parseWithState rules rulesp "skip\n\n \n")
|
assertParse (parseWithState' rules rulesp "skip\n\n \n")
|
||||||
|
|
||||||
-- not supported
|
-- not supported
|
||||||
-- ,"convert rules parsing: no final newline" ~: do
|
-- ,"convert rules parsing: no final newline" ~: do
|
||||||
|
|||||||
@ -40,8 +40,6 @@ module Hledger.Read.JournalReader (
|
|||||||
-- * Parsing utils
|
-- * Parsing utils
|
||||||
genericSourcePos,
|
genericSourcePos,
|
||||||
parseAndFinaliseJournal,
|
parseAndFinaliseJournal,
|
||||||
runStringParser,
|
|
||||||
rsp,
|
|
||||||
runJournalParser,
|
runJournalParser,
|
||||||
rjp,
|
rjp,
|
||||||
runErroringJournalParser,
|
runErroringJournalParser,
|
||||||
@ -78,7 +76,8 @@ import Prelude ()
|
|||||||
import Prelude.Compat hiding (readFile)
|
import Prelude.Compat hiding (readFile)
|
||||||
import qualified Control.Exception as C
|
import qualified Control.Exception as C
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Control.Monad.Except (ExceptT(..), liftIO, runExceptT, throwError)
|
import Control.Monad.Except (ExceptT(..), runExceptT, throwError)
|
||||||
|
import Control.Monad.State.Strict
|
||||||
import qualified Data.Map.Strict as M
|
import qualified Data.Map.Strict as M
|
||||||
import Data.Monoid
|
import Data.Monoid
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
@ -89,9 +88,9 @@ import Safe
|
|||||||
import Test.HUnit
|
import Test.HUnit
|
||||||
#ifdef TESTS
|
#ifdef TESTS
|
||||||
import Test.Framework
|
import Test.Framework
|
||||||
import Text.Parsec.Error
|
import Text.Megaparsec.Error
|
||||||
#endif
|
#endif
|
||||||
import Text.Parsec hiding (parse)
|
import Text.Megaparsec hiding (parse)
|
||||||
import Text.Printf
|
import Text.Printf
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
|
|
||||||
@ -137,7 +136,7 @@ journalp :: ErroringJournalParser ParsedJournal
|
|||||||
journalp = do
|
journalp = do
|
||||||
many addJournalItemP
|
many addJournalItemP
|
||||||
eof
|
eof
|
||||||
getState
|
get
|
||||||
|
|
||||||
-- | A side-effecting parser; parses any kind of journal item
|
-- | A side-effecting parser; parses any kind of journal item
|
||||||
-- and updates the parse state accordingly.
|
-- and updates the parse state accordingly.
|
||||||
@ -147,10 +146,10 @@ addJournalItemP =
|
|||||||
-- character, can use choice without backtracking
|
-- character, can use choice without backtracking
|
||||||
choice [
|
choice [
|
||||||
directivep
|
directivep
|
||||||
, transactionp >>= modifyState . addTransaction
|
, transactionp >>= modify' . addTransaction
|
||||||
, modifiertransactionp >>= modifyState . addModifierTransaction
|
, modifiertransactionp >>= modify' . addModifierTransaction
|
||||||
, periodictransactionp >>= modifyState . addPeriodicTransaction
|
, periodictransactionp >>= modify' . addPeriodicTransaction
|
||||||
, marketpricedirectivep >>= modifyState . addMarketPrice
|
, marketpricedirectivep >>= modify' . addMarketPrice
|
||||||
, void emptyorcommentlinep
|
, void emptyorcommentlinep
|
||||||
, void multilinecommentp
|
, void multilinecommentp
|
||||||
] <?> "transaction or directive"
|
] <?> "transaction or directive"
|
||||||
@ -163,7 +162,7 @@ addJournalItemP =
|
|||||||
directivep :: ErroringJournalParser ()
|
directivep :: ErroringJournalParser ()
|
||||||
directivep = (do
|
directivep = (do
|
||||||
optional $ char '!'
|
optional $ char '!'
|
||||||
choice' [
|
choiceInState [
|
||||||
includedirectivep
|
includedirectivep
|
||||||
,aliasdirectivep
|
,aliasdirectivep
|
||||||
,endaliasesdirectivep
|
,endaliasesdirectivep
|
||||||
@ -183,24 +182,27 @@ directivep = (do
|
|||||||
includedirectivep :: ErroringJournalParser ()
|
includedirectivep :: ErroringJournalParser ()
|
||||||
includedirectivep = do
|
includedirectivep = do
|
||||||
string "include"
|
string "include"
|
||||||
many1 spacenonewline
|
lift (some spacenonewline)
|
||||||
filename <- restofline
|
filename <- lift restofline
|
||||||
parentpos <- getPosition
|
parentpos <- getPosition
|
||||||
parentj <- getState
|
parentj <- get
|
||||||
let childj = newJournalWithParseStateFrom parentj
|
let childj = newJournalWithParseStateFrom parentj
|
||||||
(ej :: Either String ParsedJournal) <-
|
(ej :: Either String ParsedJournal) <-
|
||||||
liftIO $ runExceptT $ do
|
liftIO $ runExceptT $ do
|
||||||
let curdir = takeDirectory (sourceName parentpos)
|
let curdir = takeDirectory (sourceName parentpos)
|
||||||
filepath <- expandPath curdir filename `orRethrowIOError` (show parentpos ++ " locating " ++ filename)
|
filepath <- expandPath curdir filename `orRethrowIOError` (show parentpos ++ " locating " ++ filename)
|
||||||
txt <- readFileAnyLineEnding filepath `orRethrowIOError` (show parentpos ++ " reading " ++ filepath)
|
txt <- readFileAnyLineEnding filepath `orRethrowIOError` (show parentpos ++ " reading " ++ filepath)
|
||||||
(ej1::Either ParseError ParsedJournal) <-
|
(ej1::Either (ParseError Char Dec) ParsedJournal) <-
|
||||||
runParserT
|
runParserT
|
||||||
(choice' [journalp
|
(evalStateT
|
||||||
,timeclockfilep
|
(choiceInState
|
||||||
,timedotfilep
|
[journalp
|
||||||
-- can't include a csv file yet, that reader is special
|
,timeclockfilep
|
||||||
])
|
,timedotfilep
|
||||||
childj filepath txt
|
-- can't include a csv file yet, that reader is special
|
||||||
|
])
|
||||||
|
childj)
|
||||||
|
filepath txt
|
||||||
either
|
either
|
||||||
(throwError
|
(throwError
|
||||||
. ((show parentpos ++ " in included file " ++ show filename ++ ":\n") ++)
|
. ((show parentpos ++ " in included file " ++ show filename ++ ":\n") ++)
|
||||||
@ -209,7 +211,7 @@ includedirectivep = do
|
|||||||
ej1
|
ej1
|
||||||
case ej of
|
case ej of
|
||||||
Left e -> throwError e
|
Left e -> throwError e
|
||||||
Right childj -> modifyState (\parentj -> childj <> parentj)
|
Right childj -> modify' (\parentj -> childj <> parentj)
|
||||||
-- discard child's parse info, prepend its (reversed) list data, combine other fields
|
-- discard child's parse info, prepend its (reversed) list data, combine other fields
|
||||||
|
|
||||||
newJournalWithParseStateFrom :: Journal -> Journal
|
newJournalWithParseStateFrom :: Journal -> Journal
|
||||||
@ -233,13 +235,13 @@ orRethrowIOError io msg =
|
|||||||
accountdirectivep :: ErroringJournalParser ()
|
accountdirectivep :: ErroringJournalParser ()
|
||||||
accountdirectivep = do
|
accountdirectivep = do
|
||||||
string "account"
|
string "account"
|
||||||
many1 spacenonewline
|
lift (some spacenonewline)
|
||||||
acct <- accountnamep
|
acct <- lift accountnamep
|
||||||
newline
|
newline
|
||||||
_ <- many indentedlinep
|
_ <- many indentedlinep
|
||||||
modifyState (\j -> j{jaccounts = acct : jaccounts j})
|
modify' (\j -> j{jaccounts = acct : jaccounts j})
|
||||||
|
|
||||||
indentedlinep = many1 spacenonewline >> (rstrip <$> restofline)
|
indentedlinep = lift (some spacenonewline) >> (rstrip <$> lift restofline)
|
||||||
|
|
||||||
-- | Parse a one-line or multi-line commodity directive.
|
-- | Parse a one-line or multi-line commodity directive.
|
||||||
--
|
--
|
||||||
@ -257,12 +259,12 @@ commoditydirectivep = try commoditydirectiveonelinep <|> commoditydirectivemulti
|
|||||||
commoditydirectiveonelinep :: ErroringJournalParser ()
|
commoditydirectiveonelinep :: ErroringJournalParser ()
|
||||||
commoditydirectiveonelinep = do
|
commoditydirectiveonelinep = do
|
||||||
string "commodity"
|
string "commodity"
|
||||||
many1 spacenonewline
|
lift (some spacenonewline)
|
||||||
Amount{acommodity,astyle} <- amountp
|
Amount{acommodity,astyle} <- amountp
|
||||||
many spacenonewline
|
lift (many spacenonewline)
|
||||||
_ <- followingcommentp <|> (eolof >> return "")
|
_ <- followingcommentp <|> (lift eolof >> return "")
|
||||||
let comm = Commodity{csymbol=acommodity, cformat=Just astyle}
|
let comm = Commodity{csymbol=acommodity, cformat=Just astyle}
|
||||||
modifyState (\j -> j{jcommodities=M.insert acommodity comm $ jcommodities j})
|
modify' (\j -> j{jcommodities=M.insert acommodity comm $ jcommodities j})
|
||||||
|
|
||||||
-- | Parse a multi-line commodity directive, containing 0 or more format subdirectives.
|
-- | Parse a multi-line commodity directive, containing 0 or more format subdirectives.
|
||||||
--
|
--
|
||||||
@ -270,24 +272,24 @@ commoditydirectiveonelinep = do
|
|||||||
commoditydirectivemultilinep :: ErroringJournalParser ()
|
commoditydirectivemultilinep :: ErroringJournalParser ()
|
||||||
commoditydirectivemultilinep = do
|
commoditydirectivemultilinep = do
|
||||||
string "commodity"
|
string "commodity"
|
||||||
many1 spacenonewline
|
lift (some spacenonewline)
|
||||||
sym <- commoditysymbolp
|
sym <- lift commoditysymbolp
|
||||||
_ <- followingcommentp <|> (eolof >> return "")
|
_ <- followingcommentp <|> (lift eolof >> return "")
|
||||||
mformat <- lastMay <$> many (indented $ formatdirectivep sym)
|
mformat <- lastMay <$> many (indented $ formatdirectivep sym)
|
||||||
let comm = Commodity{csymbol=sym, cformat=mformat}
|
let comm = Commodity{csymbol=sym, cformat=mformat}
|
||||||
modifyState (\j -> j{jcommodities=M.insert sym comm $ jcommodities j})
|
modify' (\j -> j{jcommodities=M.insert sym comm $ jcommodities j})
|
||||||
where
|
where
|
||||||
indented = (many1 spacenonewline >>)
|
indented = (lift (some spacenonewline) >>)
|
||||||
|
|
||||||
-- | Parse a format (sub)directive, throwing a parse error if its
|
-- | Parse a format (sub)directive, throwing a parse error if its
|
||||||
-- symbol does not match the one given.
|
-- symbol does not match the one given.
|
||||||
formatdirectivep :: CommoditySymbol -> ErroringJournalParser AmountStyle
|
formatdirectivep :: CommoditySymbol -> ErroringJournalParser AmountStyle
|
||||||
formatdirectivep expectedsym = do
|
formatdirectivep expectedsym = do
|
||||||
string "format"
|
string "format"
|
||||||
many1 spacenonewline
|
lift (some spacenonewline)
|
||||||
pos <- getPosition
|
pos <- getPosition
|
||||||
Amount{acommodity,astyle} <- amountp
|
Amount{acommodity,astyle} <- amountp
|
||||||
_ <- followingcommentp <|> (eolof >> return "")
|
_ <- followingcommentp <|> (lift eolof >> return "")
|
||||||
if acommodity==expectedsym
|
if acommodity==expectedsym
|
||||||
then return astyle
|
then return astyle
|
||||||
else parserErrorAt pos $
|
else parserErrorAt pos $
|
||||||
@ -295,41 +297,41 @@ formatdirectivep expectedsym = do
|
|||||||
|
|
||||||
applyaccountdirectivep :: ErroringJournalParser ()
|
applyaccountdirectivep :: ErroringJournalParser ()
|
||||||
applyaccountdirectivep = do
|
applyaccountdirectivep = do
|
||||||
string "apply" >> many1 spacenonewline >> string "account"
|
string "apply" >> lift (some spacenonewline) >> string "account"
|
||||||
many1 spacenonewline
|
lift (some spacenonewline)
|
||||||
parent <- accountnamep
|
parent <- lift accountnamep
|
||||||
newline
|
newline
|
||||||
pushParentAccount parent
|
pushParentAccount parent
|
||||||
|
|
||||||
endapplyaccountdirectivep :: ErroringJournalParser ()
|
endapplyaccountdirectivep :: ErroringJournalParser ()
|
||||||
endapplyaccountdirectivep = do
|
endapplyaccountdirectivep = do
|
||||||
string "end" >> many1 spacenonewline >> string "apply" >> many1 spacenonewline >> string "account"
|
string "end" >> lift (some spacenonewline) >> string "apply" >> lift (some spacenonewline) >> string "account"
|
||||||
popParentAccount
|
popParentAccount
|
||||||
|
|
||||||
aliasdirectivep :: ErroringJournalParser ()
|
aliasdirectivep :: ErroringJournalParser ()
|
||||||
aliasdirectivep = do
|
aliasdirectivep = do
|
||||||
string "alias"
|
string "alias"
|
||||||
many1 spacenonewline
|
lift (some spacenonewline)
|
||||||
alias <- accountaliasp
|
alias <- lift accountaliasp
|
||||||
addAccountAlias alias
|
addAccountAlias alias
|
||||||
|
|
||||||
accountaliasp :: Monad m => TextParser u m AccountAlias
|
accountaliasp :: TextParser m AccountAlias
|
||||||
accountaliasp = regexaliasp <|> basicaliasp
|
accountaliasp = regexaliasp <|> basicaliasp
|
||||||
|
|
||||||
basicaliasp :: Monad m => TextParser u m AccountAlias
|
basicaliasp :: TextParser m AccountAlias
|
||||||
basicaliasp = do
|
basicaliasp = do
|
||||||
-- pdbg 0 "basicaliasp"
|
-- pdbg 0 "basicaliasp"
|
||||||
old <- rstrip <$> many1 (noneOf "=")
|
old <- rstrip <$> (some $ noneOf ("=" :: [Char]))
|
||||||
char '='
|
char '='
|
||||||
many spacenonewline
|
many spacenonewline
|
||||||
new <- rstrip <$> anyChar `manyTill` eolof -- don't require a final newline, good for cli options
|
new <- rstrip <$> anyChar `manyTill` eolof -- don't require a final newline, good for cli options
|
||||||
return $ BasicAlias (T.pack old) (T.pack new)
|
return $ BasicAlias (T.pack old) (T.pack new)
|
||||||
|
|
||||||
regexaliasp :: Monad m => TextParser u m AccountAlias
|
regexaliasp :: TextParser m AccountAlias
|
||||||
regexaliasp = do
|
regexaliasp = do
|
||||||
-- pdbg 0 "regexaliasp"
|
-- pdbg 0 "regexaliasp"
|
||||||
char '/'
|
char '/'
|
||||||
re <- many1 $ noneOf "/\n\r" -- paranoid: don't try to read past line end
|
re <- some $ noneOf ("/\n\r" :: [Char]) -- paranoid: don't try to read past line end
|
||||||
char '/'
|
char '/'
|
||||||
many spacenonewline
|
many spacenonewline
|
||||||
char '='
|
char '='
|
||||||
@ -345,22 +347,22 @@ endaliasesdirectivep = do
|
|||||||
tagdirectivep :: ErroringJournalParser ()
|
tagdirectivep :: ErroringJournalParser ()
|
||||||
tagdirectivep = do
|
tagdirectivep = do
|
||||||
string "tag" <?> "tag directive"
|
string "tag" <?> "tag directive"
|
||||||
many1 spacenonewline
|
lift (some spacenonewline)
|
||||||
_ <- many1 nonspace
|
_ <- lift $ some nonspace
|
||||||
restofline
|
lift restofline
|
||||||
return ()
|
return ()
|
||||||
|
|
||||||
endtagdirectivep :: ErroringJournalParser ()
|
endtagdirectivep :: ErroringJournalParser ()
|
||||||
endtagdirectivep = do
|
endtagdirectivep = do
|
||||||
(string "end tag" <|> string "pop") <?> "end tag or pop directive"
|
(string "end tag" <|> string "pop") <?> "end tag or pop directive"
|
||||||
restofline
|
lift restofline
|
||||||
return ()
|
return ()
|
||||||
|
|
||||||
defaultyeardirectivep :: ErroringJournalParser ()
|
defaultyeardirectivep :: ErroringJournalParser ()
|
||||||
defaultyeardirectivep = do
|
defaultyeardirectivep = do
|
||||||
char 'Y' <?> "default year"
|
char 'Y' <?> "default year"
|
||||||
many spacenonewline
|
lift (many spacenonewline)
|
||||||
y <- many1 digit
|
y <- some digitChar
|
||||||
let y' = read y
|
let y' = read y
|
||||||
failIfInvalidYear y
|
failIfInvalidYear y
|
||||||
setYear y'
|
setYear y'
|
||||||
@ -368,41 +370,41 @@ defaultyeardirectivep = do
|
|||||||
defaultcommoditydirectivep :: ErroringJournalParser ()
|
defaultcommoditydirectivep :: ErroringJournalParser ()
|
||||||
defaultcommoditydirectivep = do
|
defaultcommoditydirectivep = do
|
||||||
char 'D' <?> "default commodity"
|
char 'D' <?> "default commodity"
|
||||||
many1 spacenonewline
|
lift (some spacenonewline)
|
||||||
Amount{..} <- amountp
|
Amount{..} <- amountp
|
||||||
restofline
|
lift restofline
|
||||||
setDefaultCommodityAndStyle (acommodity, astyle)
|
setDefaultCommodityAndStyle (acommodity, astyle)
|
||||||
|
|
||||||
marketpricedirectivep :: ErroringJournalParser MarketPrice
|
marketpricedirectivep :: ErroringJournalParser MarketPrice
|
||||||
marketpricedirectivep = do
|
marketpricedirectivep = do
|
||||||
char 'P' <?> "market price"
|
char 'P' <?> "market price"
|
||||||
many spacenonewline
|
lift (many spacenonewline)
|
||||||
date <- try (do {LocalTime d _ <- datetimep; return d}) <|> datep -- a time is ignored
|
date <- try (do {LocalTime d _ <- datetimep; return d}) <|> datep -- a time is ignored
|
||||||
many1 spacenonewline
|
lift (some spacenonewline)
|
||||||
symbol <- commoditysymbolp
|
symbol <- lift commoditysymbolp
|
||||||
many spacenonewline
|
lift (many spacenonewline)
|
||||||
price <- amountp
|
price <- amountp
|
||||||
restofline
|
lift restofline
|
||||||
return $ MarketPrice date symbol price
|
return $ MarketPrice date symbol price
|
||||||
|
|
||||||
ignoredpricecommoditydirectivep :: ErroringJournalParser ()
|
ignoredpricecommoditydirectivep :: ErroringJournalParser ()
|
||||||
ignoredpricecommoditydirectivep = do
|
ignoredpricecommoditydirectivep = do
|
||||||
char 'N' <?> "ignored-price commodity"
|
char 'N' <?> "ignored-price commodity"
|
||||||
many1 spacenonewline
|
lift (some spacenonewline)
|
||||||
commoditysymbolp
|
lift commoditysymbolp
|
||||||
restofline
|
lift restofline
|
||||||
return ()
|
return ()
|
||||||
|
|
||||||
commodityconversiondirectivep :: ErroringJournalParser ()
|
commodityconversiondirectivep :: ErroringJournalParser ()
|
||||||
commodityconversiondirectivep = do
|
commodityconversiondirectivep = do
|
||||||
char 'C' <?> "commodity conversion"
|
char 'C' <?> "commodity conversion"
|
||||||
many1 spacenonewline
|
lift (some spacenonewline)
|
||||||
amountp
|
amountp
|
||||||
many spacenonewline
|
lift (many spacenonewline)
|
||||||
char '='
|
char '='
|
||||||
many spacenonewline
|
lift (many spacenonewline)
|
||||||
amountp
|
amountp
|
||||||
restofline
|
lift restofline
|
||||||
return ()
|
return ()
|
||||||
|
|
||||||
--- ** transactions
|
--- ** transactions
|
||||||
@ -410,16 +412,16 @@ commodityconversiondirectivep = do
|
|||||||
modifiertransactionp :: ErroringJournalParser ModifierTransaction
|
modifiertransactionp :: ErroringJournalParser ModifierTransaction
|
||||||
modifiertransactionp = do
|
modifiertransactionp = do
|
||||||
char '=' <?> "modifier transaction"
|
char '=' <?> "modifier transaction"
|
||||||
many spacenonewline
|
lift (many spacenonewline)
|
||||||
valueexpr <- T.pack <$> restofline
|
valueexpr <- T.pack <$> lift restofline
|
||||||
postings <- postingsp Nothing
|
postings <- postingsp Nothing
|
||||||
return $ ModifierTransaction valueexpr postings
|
return $ ModifierTransaction valueexpr postings
|
||||||
|
|
||||||
periodictransactionp :: ErroringJournalParser PeriodicTransaction
|
periodictransactionp :: ErroringJournalParser PeriodicTransaction
|
||||||
periodictransactionp = do
|
periodictransactionp = do
|
||||||
char '~' <?> "periodic transaction"
|
char '~' <?> "periodic transaction"
|
||||||
many spacenonewline
|
lift (many spacenonewline)
|
||||||
periodexpr <- T.pack <$> restofline
|
periodexpr <- T.pack <$> lift restofline
|
||||||
postings <- postingsp Nothing
|
postings <- postingsp Nothing
|
||||||
return $ PeriodicTransaction periodexpr postings
|
return $ PeriodicTransaction periodexpr postings
|
||||||
|
|
||||||
@ -429,10 +431,10 @@ transactionp = do
|
|||||||
-- ptrace "transactionp"
|
-- ptrace "transactionp"
|
||||||
sourcepos <- genericSourcePos <$> getPosition
|
sourcepos <- genericSourcePos <$> getPosition
|
||||||
date <- datep <?> "transaction"
|
date <- datep <?> "transaction"
|
||||||
edate <- optionMaybe (secondarydatep date) <?> "secondary date"
|
edate <- optional (secondarydatep date) <?> "secondary date"
|
||||||
lookAhead (spacenonewline <|> newline) <?> "whitespace or newline"
|
lookAhead (lift spacenonewline <|> newline) <?> "whitespace or newline"
|
||||||
status <- statusp <?> "cleared status"
|
status <- lift statusp <?> "cleared status"
|
||||||
code <- T.pack <$> codep <?> "transaction code"
|
code <- T.pack <$> lift codep <?> "transaction code"
|
||||||
description <- T.pack . strip <$> descriptionp
|
description <- T.pack . strip <$> descriptionp
|
||||||
comment <- try followingcommentp <|> (newline >> return "")
|
comment <- try followingcommentp <|> (newline >> return "")
|
||||||
let tags = commentTags comment
|
let tags = commentTags comment
|
||||||
@ -542,23 +544,23 @@ postingsp mdate = many (try $ postingp mdate) <?> "postings"
|
|||||||
|
|
||||||
-- linebeginningwithspaces :: Monad m => JournalParser m String
|
-- linebeginningwithspaces :: Monad m => JournalParser m String
|
||||||
-- linebeginningwithspaces = do
|
-- linebeginningwithspaces = do
|
||||||
-- sp <- many1 spacenonewline
|
-- sp <- lift (some spacenonewline)
|
||||||
-- c <- nonspace
|
-- c <- nonspace
|
||||||
-- cs <- restofline
|
-- cs <- lift restofline
|
||||||
-- return $ sp ++ (c:cs) ++ "\n"
|
-- return $ sp ++ (c:cs) ++ "\n"
|
||||||
|
|
||||||
postingp :: Maybe Day -> ErroringJournalParser Posting
|
postingp :: Maybe Day -> ErroringJournalParser Posting
|
||||||
postingp mtdate = do
|
postingp mtdate = do
|
||||||
-- pdbg 0 "postingp"
|
-- pdbg 0 "postingp"
|
||||||
many1 spacenonewline
|
lift (some spacenonewline)
|
||||||
status <- statusp
|
status <- lift statusp
|
||||||
many spacenonewline
|
lift (many spacenonewline)
|
||||||
account <- modifiedaccountnamep
|
account <- modifiedaccountnamep
|
||||||
let (ptype, account') = (accountNamePostingType account, textUnbracket account)
|
let (ptype, account') = (accountNamePostingType account, textUnbracket account)
|
||||||
amount <- spaceandamountormissingp
|
amount <- spaceandamountormissingp
|
||||||
massertion <- partialbalanceassertionp
|
massertion <- partialbalanceassertionp
|
||||||
_ <- fixedlotpricep
|
_ <- fixedlotpricep
|
||||||
many spacenonewline
|
lift (many spacenonewline)
|
||||||
(comment,tags,mdate,mdate2) <-
|
(comment,tags,mdate,mdate2) <-
|
||||||
try (followingcommentandtagsp mtdate) <|> (newline >> return ("",[],Nothing,Nothing))
|
try (followingcommentandtagsp mtdate) <|> (newline >> return ("",[],Nothing,Nothing))
|
||||||
return posting
|
return posting
|
||||||
|
|||||||
@ -51,22 +51,22 @@ module Hledger.Read.TimeclockReader (
|
|||||||
tests_Hledger_Read_TimeclockReader
|
tests_Hledger_Read_TimeclockReader
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
import Prelude ()
|
import Prelude ()
|
||||||
import Prelude.Compat
|
import Prelude.Compat
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Control.Monad.IO.Class (liftIO)
|
import Control.Monad.Except (ExceptT)
|
||||||
import Control.Monad.Except (ExceptT)
|
import Control.Monad.State.Strict
|
||||||
import Data.Maybe (fromMaybe)
|
import Data.Maybe (fromMaybe)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import Test.HUnit
|
import Test.HUnit
|
||||||
import Text.Parsec hiding (parse)
|
import Text.Megaparsec hiding (parse)
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
|
|
||||||
import Hledger.Data
|
import Hledger.Data
|
||||||
-- XXX too much reuse ?
|
-- XXX too much reuse ?
|
||||||
import Hledger.Read.Common
|
import Hledger.Read.Common
|
||||||
import Hledger.Utils
|
import Hledger.Utils
|
||||||
|
|
||||||
|
|
||||||
reader :: Reader
|
reader :: Reader
|
||||||
@ -90,7 +90,7 @@ parse _ = parseAndFinaliseJournal timeclockfilep
|
|||||||
timeclockfilep :: ErroringJournalParser ParsedJournal
|
timeclockfilep :: ErroringJournalParser ParsedJournal
|
||||||
timeclockfilep = do many timeclockitemp
|
timeclockfilep = do many timeclockitemp
|
||||||
eof
|
eof
|
||||||
j@Journal{jtxns=ts, jparsetimeclockentries=es} <- getState
|
j@Journal{jtxns=ts, jparsetimeclockentries=es} <- get
|
||||||
-- Convert timeclock entries in this journal to transactions, closing any unfinished sessions.
|
-- Convert timeclock entries in this journal to transactions, closing any unfinished sessions.
|
||||||
-- Doing this here rather than in journalFinalise means timeclock sessions can't span file boundaries,
|
-- Doing this here rather than in journalFinalise means timeclock sessions can't span file boundaries,
|
||||||
-- but it simplifies code above.
|
-- but it simplifies code above.
|
||||||
@ -103,18 +103,18 @@ timeclockfilep = do many timeclockitemp
|
|||||||
-- comment-only) lines, can use choice w/o try
|
-- comment-only) lines, can use choice w/o try
|
||||||
timeclockitemp = choice [
|
timeclockitemp = choice [
|
||||||
void emptyorcommentlinep
|
void emptyorcommentlinep
|
||||||
, timeclockentryp >>= \e -> modifyState (\j -> j{jparsetimeclockentries = e : jparsetimeclockentries j})
|
, timeclockentryp >>= \e -> modify' (\j -> j{jparsetimeclockentries = e : jparsetimeclockentries j})
|
||||||
] <?> "timeclock entry, or default year or historical price directive"
|
] <?> "timeclock entry, or default year or historical price directive"
|
||||||
|
|
||||||
-- | Parse a timeclock entry.
|
-- | Parse a timeclock entry.
|
||||||
timeclockentryp :: ErroringJournalParser TimeclockEntry
|
timeclockentryp :: ErroringJournalParser TimeclockEntry
|
||||||
timeclockentryp = do
|
timeclockentryp = do
|
||||||
sourcepos <- genericSourcePos <$> getPosition
|
sourcepos <- genericSourcePos <$> lift getPosition
|
||||||
code <- oneOf "bhioO"
|
code <- oneOf ("bhioO" :: [Char])
|
||||||
many1 spacenonewline
|
lift (some spacenonewline)
|
||||||
datetime <- datetimep
|
datetime <- datetimep
|
||||||
account <- fromMaybe "" <$> optionMaybe (many1 spacenonewline >> modifiedaccountnamep)
|
account <- fromMaybe "" <$> optional (lift (some spacenonewline) >> modifiedaccountnamep)
|
||||||
description <- T.pack . fromMaybe "" <$> optionMaybe (many1 spacenonewline >> restofline)
|
description <- T.pack . fromMaybe "" <$> lift (optional (some spacenonewline >> restofline))
|
||||||
return $ TimeclockEntry sourcepos (read [code]) datetime account description
|
return $ TimeclockEntry sourcepos (read [code]) datetime account description
|
||||||
|
|
||||||
tests_Hledger_Read_TimeclockReader = TestList [
|
tests_Hledger_Read_TimeclockReader = TestList [
|
||||||
|
|||||||
@ -36,13 +36,14 @@ import Prelude ()
|
|||||||
import Prelude.Compat
|
import Prelude.Compat
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Control.Monad.Except (ExceptT)
|
import Control.Monad.Except (ExceptT)
|
||||||
|
import Control.Monad.State.Strict
|
||||||
import Data.Char (isSpace)
|
import Data.Char (isSpace)
|
||||||
import Data.List (foldl')
|
import Data.List (foldl')
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import Test.HUnit
|
import Test.HUnit
|
||||||
import Text.Parsec hiding (parse)
|
import Text.Megaparsec hiding (parse)
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
|
|
||||||
import Hledger.Data
|
import Hledger.Data
|
||||||
@ -73,13 +74,14 @@ parse _ = parseAndFinaliseJournal timedotfilep
|
|||||||
timedotfilep :: ErroringJournalParser ParsedJournal
|
timedotfilep :: ErroringJournalParser ParsedJournal
|
||||||
timedotfilep = do many timedotfileitemp
|
timedotfilep = do many timedotfileitemp
|
||||||
eof
|
eof
|
||||||
getState
|
get
|
||||||
where
|
where
|
||||||
|
timedotfileitemp :: ErroringJournalParser ()
|
||||||
timedotfileitemp = do
|
timedotfileitemp = do
|
||||||
ptrace "timedotfileitemp"
|
ptrace "timedotfileitemp"
|
||||||
choice [
|
choice [
|
||||||
void emptyorcommentlinep
|
void emptyorcommentlinep
|
||||||
,timedotdayp >>= \ts -> modifyState (addTransactions ts)
|
,timedotdayp >>= \ts -> modify' (addTransactions ts)
|
||||||
] <?> "timedot day entry, or default year or comment line or blank line"
|
] <?> "timedot day entry, or default year or comment line or blank line"
|
||||||
|
|
||||||
addTransactions :: [Transaction] -> Journal -> Journal
|
addTransactions :: [Transaction] -> Journal -> Journal
|
||||||
@ -95,7 +97,7 @@ addTransactions ts j = foldl' (flip ($)) j (map addTransaction ts)
|
|||||||
timedotdayp :: ErroringJournalParser [Transaction]
|
timedotdayp :: ErroringJournalParser [Transaction]
|
||||||
timedotdayp = do
|
timedotdayp = do
|
||||||
ptrace " timedotdayp"
|
ptrace " timedotdayp"
|
||||||
d <- datep <* eolof
|
d <- datep <* lift eolof
|
||||||
es <- catMaybes <$> many (const Nothing <$> try emptyorcommentlinep <|>
|
es <- catMaybes <$> many (const Nothing <$> try emptyorcommentlinep <|>
|
||||||
Just <$> (notFollowedBy datep >> timedotentryp))
|
Just <$> (notFollowedBy datep >> timedotentryp))
|
||||||
return $ map (\t -> t{tdate=d}) es -- <$> many timedotentryp
|
return $ map (\t -> t{tdate=d}) es -- <$> many timedotentryp
|
||||||
@ -108,9 +110,9 @@ timedotentryp :: ErroringJournalParser Transaction
|
|||||||
timedotentryp = do
|
timedotentryp = do
|
||||||
ptrace " timedotentryp"
|
ptrace " timedotentryp"
|
||||||
pos <- genericSourcePos <$> getPosition
|
pos <- genericSourcePos <$> getPosition
|
||||||
many spacenonewline
|
lift (many spacenonewline)
|
||||||
a <- modifiedaccountnamep
|
a <- modifiedaccountnamep
|
||||||
many spacenonewline
|
lift (many spacenonewline)
|
||||||
hours <-
|
hours <-
|
||||||
try (followingcommentp >> return 0)
|
try (followingcommentp >> return 0)
|
||||||
<|> (timedotdurationp <*
|
<|> (timedotdurationp <*
|
||||||
@ -137,10 +139,10 @@ timedotdurationp = try timedotnumberp <|> timedotdotsp
|
|||||||
-- @
|
-- @
|
||||||
timedotnumberp :: ErroringJournalParser Quantity
|
timedotnumberp :: ErroringJournalParser Quantity
|
||||||
timedotnumberp = do
|
timedotnumberp = do
|
||||||
(q, _, _, _) <- numberp
|
(q, _, _, _) <- lift numberp
|
||||||
many spacenonewline
|
lift (many spacenonewline)
|
||||||
optional $ char 'h'
|
optional $ char 'h'
|
||||||
many spacenonewline
|
lift (many spacenonewline)
|
||||||
return q
|
return q
|
||||||
|
|
||||||
-- | Parse a quantity written as a line of dots, each representing 0.25.
|
-- | Parse a quantity written as a line of dots, each representing 0.25.
|
||||||
@ -149,7 +151,7 @@ timedotnumberp = do
|
|||||||
-- @
|
-- @
|
||||||
timedotdotsp :: ErroringJournalParser Quantity
|
timedotdotsp :: ErroringJournalParser Quantity
|
||||||
timedotdotsp = do
|
timedotdotsp = do
|
||||||
dots <- filter (not.isSpace) <$> many (oneOf ". ")
|
dots <- filter (not.isSpace) <$> many (oneOf (". " :: [Char]))
|
||||||
return $ (/4) $ fromIntegral $ length dots
|
return $ (/4) $ fromIntegral $ length dots
|
||||||
|
|
||||||
tests_Hledger_Read_TimedotReader = TestList [
|
tests_Hledger_Read_TimedotReader = TestList [
|
||||||
|
|||||||
@ -34,6 +34,7 @@ import Data.Data (Data)
|
|||||||
#if !MIN_VERSION_base(4,8,0)
|
#if !MIN_VERSION_base(4,8,0)
|
||||||
import Data.Functor.Compat ((<$>))
|
import Data.Functor.Compat ((<$>))
|
||||||
#endif
|
#endif
|
||||||
|
import qualified Data.Text as T
|
||||||
import Data.Typeable (Typeable)
|
import Data.Typeable (Typeable)
|
||||||
import Data.Time.Calendar
|
import Data.Time.Calendar
|
||||||
import System.Console.CmdArgs.Default -- some additional default stuff
|
import System.Console.CmdArgs.Default -- some additional default stuff
|
||||||
@ -194,7 +195,7 @@ maybesmartdateopt d name rawopts =
|
|||||||
Just s -> either
|
Just s -> either
|
||||||
(\e -> optserror $ "could not parse "++name++" date: "++show e)
|
(\e -> optserror $ "could not parse "++name++" date: "++show e)
|
||||||
Just
|
Just
|
||||||
$ fixSmartDateStrEither' d s
|
$ fixSmartDateStrEither' d (T.pack s)
|
||||||
|
|
||||||
type DisplayExp = String
|
type DisplayExp = String
|
||||||
|
|
||||||
@ -203,7 +204,7 @@ maybedisplayopt d rawopts =
|
|||||||
maybe Nothing (Just . regexReplaceBy "\\[.+?\\]" fixbracketeddatestr) $ maybestringopt "display" rawopts
|
maybe Nothing (Just . regexReplaceBy "\\[.+?\\]" fixbracketeddatestr) $ maybestringopt "display" rawopts
|
||||||
where
|
where
|
||||||
fixbracketeddatestr "" = ""
|
fixbracketeddatestr "" = ""
|
||||||
fixbracketeddatestr s = "[" ++ fixSmartDateStr d (init $ tail s) ++ "]"
|
fixbracketeddatestr s = "[" ++ fixSmartDateStr d (T.pack $ init $ tail s) ++ "]"
|
||||||
|
|
||||||
maybeperiodopt :: Day -> RawOpts -> Maybe (Interval,DateSpan)
|
maybeperiodopt :: Day -> RawOpts -> Maybe (Interval,DateSpan)
|
||||||
maybeperiodopt d rawopts =
|
maybeperiodopt d rawopts =
|
||||||
@ -212,7 +213,7 @@ maybeperiodopt d rawopts =
|
|||||||
Just s -> either
|
Just s -> either
|
||||||
(\e -> optserror $ "could not parse period option: "++show e)
|
(\e -> optserror $ "could not parse period option: "++show e)
|
||||||
Just
|
Just
|
||||||
$ parsePeriodExpr d s
|
$ parsePeriodExpr d (T.pack s)
|
||||||
|
|
||||||
-- | Legacy-compatible convenience aliases for accountlistmode_.
|
-- | Legacy-compatible convenience aliases for accountlistmode_.
|
||||||
tree_ :: ReportOpts -> Bool
|
tree_ :: ReportOpts -> Bool
|
||||||
@ -283,7 +284,7 @@ queryFromOpts d opts@ReportOpts{..} = simplifyQuery $ And $ [flagsq, argsq]
|
|||||||
++ (if empty_ then [Empty True] else []) -- ?
|
++ (if empty_ then [Empty True] else []) -- ?
|
||||||
++ (maybe [] ((:[]) . Status) (clearedValueFromOpts opts))
|
++ (maybe [] ((:[]) . Status) (clearedValueFromOpts opts))
|
||||||
++ (maybe [] ((:[]) . Depth) depth_)
|
++ (maybe [] ((:[]) . Depth) depth_)
|
||||||
argsq = fst $ parseQuery d query_
|
argsq = fst $ parseQuery d (T.pack query_)
|
||||||
|
|
||||||
-- | Convert report options to a query, ignoring any non-flag command line arguments.
|
-- | Convert report options to a query, ignoring any non-flag command line arguments.
|
||||||
queryFromOptsOnly :: Day -> ReportOpts -> Query
|
queryFromOptsOnly :: Day -> ReportOpts -> Query
|
||||||
@ -317,7 +318,7 @@ queryOptsFromOpts :: Day -> ReportOpts -> [QueryOpt]
|
|||||||
queryOptsFromOpts d ReportOpts{..} = flagsqopts ++ argsqopts
|
queryOptsFromOpts d ReportOpts{..} = flagsqopts ++ argsqopts
|
||||||
where
|
where
|
||||||
flagsqopts = []
|
flagsqopts = []
|
||||||
argsqopts = snd $ parseQuery d query_
|
argsqopts = snd $ parseQuery d (T.pack query_)
|
||||||
|
|
||||||
tests_queryOptsFromOpts :: [Test]
|
tests_queryOptsFromOpts :: [Test]
|
||||||
tests_queryOptsFromOpts = [
|
tests_queryOptsFromOpts = [
|
||||||
|
|||||||
@ -137,11 +137,11 @@ firstJust ms = case dropWhile (==Nothing) ms of
|
|||||||
(md:_) -> md
|
(md:_) -> md
|
||||||
|
|
||||||
-- | Read a file in universal newline mode, handling any of the usual line ending conventions.
|
-- | Read a file in universal newline mode, handling any of the usual line ending conventions.
|
||||||
readFile' :: FilePath -> IO String
|
readFile' :: FilePath -> IO Text
|
||||||
readFile' name = do
|
readFile' name = do
|
||||||
h <- openFile name ReadMode
|
h <- openFile name ReadMode
|
||||||
hSetNewlineMode h universalNewlineMode
|
hSetNewlineMode h universalNewlineMode
|
||||||
hGetContents h
|
T.hGetContents h
|
||||||
|
|
||||||
-- | Read a file in universal newline mode, handling any of the usual line ending conventions.
|
-- | Read a file in universal newline mode, handling any of the usual line ending conventions.
|
||||||
readFileAnyLineEnding :: FilePath -> IO Text
|
readFileAnyLineEnding :: FilePath -> IO Text
|
||||||
|
|||||||
@ -1,4 +1,4 @@
|
|||||||
{-# LANGUAGE CPP, FlexibleContexts #-}
|
{-# LANGUAGE CPP, FlexibleContexts, TypeFamilies #-}
|
||||||
-- | Debugging helpers
|
-- | Debugging helpers
|
||||||
|
|
||||||
-- more:
|
-- more:
|
||||||
@ -16,19 +16,21 @@ module Hledger.Utils.Debug (
|
|||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import Control.Monad (when)
|
import Control.Monad (when)
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
import Data.List
|
import Data.List hiding (uncons)
|
||||||
import Debug.Trace
|
import qualified Data.Text as T
|
||||||
import Safe (readDef)
|
import Debug.Trace
|
||||||
import System.Environment (getArgs)
|
import Hledger.Utils.Parse
|
||||||
import System.Exit
|
import Safe (readDef)
|
||||||
import System.IO.Unsafe (unsafePerformIO)
|
import System.Environment (getArgs)
|
||||||
import Text.Parsec
|
import System.Exit
|
||||||
import Text.Printf
|
import System.IO.Unsafe (unsafePerformIO)
|
||||||
|
import Text.Megaparsec
|
||||||
|
import Text.Printf
|
||||||
|
|
||||||
#if __GLASGOW_HASKELL__ >= 704
|
#if __GLASGOW_HASKELL__ >= 704
|
||||||
import Text.Show.Pretty (ppShow)
|
import Text.Show.Pretty (ppShow)
|
||||||
#else
|
#else
|
||||||
-- the required pretty-show version requires GHC >= 7.4
|
-- the required pretty-show version requires GHC >= 7.4
|
||||||
ppShow :: Show a => a -> String
|
ppShow :: Show a => a -> String
|
||||||
@ -58,12 +60,12 @@ traceWith f e = trace (f e) e
|
|||||||
|
|
||||||
-- | Parsec trace - show the current parsec position and next input,
|
-- | Parsec trace - show the current parsec position and next input,
|
||||||
-- and the provided label if it's non-null.
|
-- and the provided label if it's non-null.
|
||||||
ptrace :: Stream [Char] m t => String -> ParsecT [Char] st m ()
|
ptrace :: String -> TextParser m ()
|
||||||
ptrace msg = do
|
ptrace msg = do
|
||||||
pos <- getPosition
|
pos <- getPosition
|
||||||
next <- take peeklength `fmap` getInput
|
next <- (T.take peeklength) `fmap` getInput
|
||||||
let (l,c) = (sourceLine pos, sourceColumn pos)
|
let (l,c) = (sourceLine pos, sourceColumn pos)
|
||||||
s = printf "at line %2d col %2d: %s" l c (show next) :: String
|
s = printf "at line %2d col %2d: %s" (unPos l) (unPos c) (show next) :: String
|
||||||
s' = printf ("%-"++show (peeklength+30)++"s") s ++ " " ++ msg
|
s' = printf ("%-"++show (peeklength+30)++"s") s ++ " " ++ msg
|
||||||
trace s' $ return ()
|
trace s' $ return ()
|
||||||
where
|
where
|
||||||
@ -233,7 +235,7 @@ dbgExit msg = const (unsafePerformIO exitFailure) . dbg msg
|
|||||||
-- input) to the console when the debug level is at or above
|
-- input) to the console when the debug level is at or above
|
||||||
-- this level. Uses unsafePerformIO.
|
-- this level. Uses unsafePerformIO.
|
||||||
-- pdbgAt :: GenParser m => Float -> String -> m ()
|
-- pdbgAt :: GenParser m => Float -> String -> m ()
|
||||||
pdbg :: Stream [Char] m t => Int -> String -> ParsecT [Char] st m ()
|
pdbg :: Int -> String -> TextParser m ()
|
||||||
pdbg level msg = when (level <= debugLevel) $ ptrace msg
|
pdbg level msg = when (level <= debugLevel) $ ptrace msg
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
@ -1,47 +1,71 @@
|
|||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts, TypeFamilies #-}
|
||||||
module Hledger.Utils.Parse where
|
module Hledger.Utils.Parse where
|
||||||
|
|
||||||
|
import Control.Monad.Except
|
||||||
import Data.Char
|
import Data.Char
|
||||||
import Data.List
|
import Data.List
|
||||||
-- import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
-- import qualified Data.Text as T
|
import Text.Megaparsec hiding (State)
|
||||||
import Text.Parsec
|
import Data.Functor.Identity (Identity(..))
|
||||||
import Text.Printf
|
import Text.Printf
|
||||||
|
|
||||||
|
import Control.Monad.State.Strict (StateT, evalStateT)
|
||||||
|
|
||||||
|
import Hledger.Data.Types
|
||||||
import Hledger.Utils.UTF8IOCompat (error')
|
import Hledger.Utils.UTF8IOCompat (error')
|
||||||
|
|
||||||
|
-- | A parser of strict text with generic user state, monad and return type.
|
||||||
|
type TextParser m a = ParsecT Dec Text m a
|
||||||
|
|
||||||
|
type JournalStateParser m a = StateT Journal (ParsecT Dec Text m) a
|
||||||
|
|
||||||
|
type JournalParser a = StateT Journal (ParsecT Dec Text Identity) a
|
||||||
|
|
||||||
|
-- | A journal parser that runs in IO and can throw an error mid-parse.
|
||||||
|
type ErroringJournalParser a = StateT Journal (ParsecT Dec Text (ExceptT String IO)) a
|
||||||
|
|
||||||
-- | Backtracking choice, use this when alternatives share a prefix.
|
-- | Backtracking choice, use this when alternatives share a prefix.
|
||||||
-- Consumes no input if all choices fail.
|
-- Consumes no input if all choices fail.
|
||||||
choice' :: Stream s m t => [ParsecT s u m a] -> ParsecT s u m a
|
choice' :: [TextParser m a] -> TextParser m a
|
||||||
choice' = choice . map Text.Parsec.try
|
choice' = choice . map Text.Megaparsec.try
|
||||||
|
|
||||||
parsewith :: Parsec [Char] () a -> String -> Either ParseError a
|
-- | Backtracking choice, use this when alternatives share a prefix.
|
||||||
parsewith p = runParser p () ""
|
-- Consumes no input if all choices fail.
|
||||||
|
choiceInState :: [StateT s (ParsecT Dec Text m) a] -> StateT s (ParsecT Dec Text m) a
|
||||||
|
choiceInState = choice . map Text.Megaparsec.try
|
||||||
|
|
||||||
parseWithState :: Stream s m t => u -> ParsecT s u m a -> s -> m (Either ParseError a)
|
parsewith :: Parsec e Text a -> Text -> Either (ParseError Char e) a
|
||||||
parseWithState jps p = runParserT p jps ""
|
parsewith p = runParser p ""
|
||||||
|
|
||||||
fromparse :: Either ParseError a -> a
|
parsewithString :: Parsec e String a -> String -> Either (ParseError Char e) a
|
||||||
|
parsewithString p = runParser p ""
|
||||||
|
|
||||||
|
parseWithState :: Monad m => st -> StateT st (ParsecT Dec Text m) a -> Text -> m (Either (ParseError Char Dec) a)
|
||||||
|
parseWithState ctx p s = runParserT (evalStateT p ctx) "" s
|
||||||
|
|
||||||
|
parseWithState' :: (Stream s, ErrorComponent e) => st -> StateT st (ParsecT e s Identity) a -> s -> (Either (ParseError (Token s) e) a)
|
||||||
|
parseWithState' ctx p s = runParser (evalStateT p ctx) "" s
|
||||||
|
|
||||||
|
fromparse :: (Show t, Show e) => Either (ParseError t e) a -> a
|
||||||
fromparse = either parseerror id
|
fromparse = either parseerror id
|
||||||
|
|
||||||
parseerror :: ParseError -> a
|
parseerror :: (Show t, Show e) => ParseError t e -> a
|
||||||
parseerror e = error' $ showParseError e
|
parseerror e = error' $ showParseError e
|
||||||
|
|
||||||
showParseError :: ParseError -> String
|
showParseError :: (Show t, Show e) => ParseError t e -> String
|
||||||
showParseError e = "parse error at " ++ show e
|
showParseError e = "parse error at " ++ show e
|
||||||
|
|
||||||
showDateParseError :: ParseError -> String
|
showDateParseError :: (Show t, Show e) => ParseError t e -> String
|
||||||
showDateParseError e = printf "date parse error (%s)" (intercalate ", " $ tail $ lines $ show e)
|
showDateParseError e = printf "date parse error (%s)" (intercalate ", " $ tail $ lines $ show e)
|
||||||
|
|
||||||
nonspace :: (Stream s m Char) => ParsecT s st m Char
|
nonspace :: TextParser m Char
|
||||||
nonspace = satisfy (not . isSpace)
|
nonspace = satisfy (not . isSpace)
|
||||||
|
|
||||||
spacenonewline :: (Stream s m Char) => ParsecT s st m Char
|
spacenonewline :: (Stream s, Char ~ Token s) => ParsecT Dec s m Char
|
||||||
spacenonewline = satisfy (`elem` " \v\f\t")
|
spacenonewline = satisfy (`elem` " \v\f\t")
|
||||||
|
|
||||||
restofline :: (Stream s m Char) => ParsecT s st m String
|
restofline :: TextParser m String
|
||||||
restofline = anyChar `manyTill` newline
|
restofline = anyChar `manyTill` newline
|
||||||
|
|
||||||
eolof :: (Stream s m Char) => ParsecT s st m ()
|
eolof :: TextParser m ()
|
||||||
eolof = (newline >> return ()) <|> eof
|
eolof = (newline >> return ()) <|> eof
|
||||||
|
|
||||||
|
|||||||
@ -8,19 +8,13 @@ module Hledger.Utils.String (
|
|||||||
stripbrackets,
|
stripbrackets,
|
||||||
unbracket,
|
unbracket,
|
||||||
-- quoting
|
-- quoting
|
||||||
quoteIfSpaced,
|
|
||||||
quoteIfNeeded,
|
quoteIfNeeded,
|
||||||
singleQuoteIfNeeded,
|
singleQuoteIfNeeded,
|
||||||
-- quotechars,
|
-- quotechars,
|
||||||
-- whitespacechars,
|
-- whitespacechars,
|
||||||
escapeDoubleQuotes,
|
|
||||||
escapeSingleQuotes,
|
|
||||||
escapeQuotes,
|
escapeQuotes,
|
||||||
words',
|
words',
|
||||||
unwords',
|
unwords',
|
||||||
stripquotes,
|
|
||||||
isSingleQuoted,
|
|
||||||
isDoubleQuoted,
|
|
||||||
-- * single-line layout
|
-- * single-line layout
|
||||||
strip,
|
strip,
|
||||||
lstrip,
|
lstrip,
|
||||||
@ -54,7 +48,7 @@ module Hledger.Utils.String (
|
|||||||
|
|
||||||
import Data.Char
|
import Data.Char
|
||||||
import Data.List
|
import Data.List
|
||||||
import Text.Parsec
|
import Text.Megaparsec
|
||||||
import Text.Printf (printf)
|
import Text.Printf (printf)
|
||||||
|
|
||||||
import Hledger.Utils.Parse
|
import Hledger.Utils.Parse
|
||||||
@ -107,20 +101,11 @@ underline s = s' ++ replicate (length s) '-' ++ "\n"
|
|||||||
| last s == '\n' = s
|
| last s == '\n' = s
|
||||||
| otherwise = s ++ "\n"
|
| otherwise = s ++ "\n"
|
||||||
|
|
||||||
-- | Wrap a string in double quotes, and \-prefix any embedded single
|
|
||||||
-- quotes, if it contains whitespace and is not already single- or
|
|
||||||
-- double-quoted.
|
|
||||||
quoteIfSpaced :: String -> String
|
|
||||||
quoteIfSpaced s | isSingleQuoted s || isDoubleQuoted s = s
|
|
||||||
| not $ any (`elem` s) whitespacechars = s
|
|
||||||
| otherwise = "'"++escapeSingleQuotes s++"'"
|
|
||||||
|
|
||||||
-- | Double-quote this string if it contains whitespace, single quotes
|
-- | Double-quote this string if it contains whitespace, single quotes
|
||||||
-- or double-quotes, escaping the quotes as needed.
|
-- or double-quotes, escaping the quotes as needed.
|
||||||
quoteIfNeeded :: String -> String
|
quoteIfNeeded :: String -> String
|
||||||
quoteIfNeeded s | any (`elem` s) (quotechars++whitespacechars) = "\"" ++ escapeDoubleQuotes s ++ "\""
|
quoteIfNeeded s | any (`elem` s) (quotechars++whitespacechars) = "\"" ++ escapeDoubleQuotes s ++ "\""
|
||||||
| otherwise = s
|
| otherwise = s
|
||||||
|
|
||||||
-- | Single-quote this string if it contains whitespace or double-quotes.
|
-- | Single-quote this string if it contains whitespace or double-quotes.
|
||||||
-- No good for strings containing single quotes.
|
-- No good for strings containing single quotes.
|
||||||
singleQuoteIfNeeded :: String -> String
|
singleQuoteIfNeeded :: String -> String
|
||||||
@ -134,9 +119,6 @@ whitespacechars = " \t\n\r"
|
|||||||
escapeDoubleQuotes :: String -> String
|
escapeDoubleQuotes :: String -> String
|
||||||
escapeDoubleQuotes = regexReplace "\"" "\""
|
escapeDoubleQuotes = regexReplace "\"" "\""
|
||||||
|
|
||||||
escapeSingleQuotes :: String -> String
|
|
||||||
escapeSingleQuotes = regexReplace "'" "\'"
|
|
||||||
|
|
||||||
escapeQuotes :: String -> String
|
escapeQuotes :: String -> String
|
||||||
escapeQuotes = regexReplace "([\"'])" "\\1"
|
escapeQuotes = regexReplace "([\"'])" "\\1"
|
||||||
|
|
||||||
@ -144,9 +126,9 @@ escapeQuotes = regexReplace "([\"'])" "\\1"
|
|||||||
-- NB correctly handles "a'b" but not "''a''". Can raise an error if parsing fails.
|
-- NB correctly handles "a'b" but not "''a''". Can raise an error if parsing fails.
|
||||||
words' :: String -> [String]
|
words' :: String -> [String]
|
||||||
words' "" = []
|
words' "" = []
|
||||||
words' s = map stripquotes $ fromparse $ parsewith p s
|
words' s = map stripquotes $ fromparse $ parsewithString p s
|
||||||
where
|
where
|
||||||
p = do ss <- (singleQuotedPattern <|> doubleQuotedPattern <|> pattern) `sepBy` many1 spacenonewline
|
p = do ss <- (singleQuotedPattern <|> doubleQuotedPattern <|> pattern) `sepBy` some spacenonewline
|
||||||
-- eof
|
-- eof
|
||||||
return ss
|
return ss
|
||||||
pattern = many (noneOf whitespacechars)
|
pattern = many (noneOf whitespacechars)
|
||||||
|
|||||||
@ -1,7 +1,7 @@
|
|||||||
module Hledger.Utils.Test where
|
module Hledger.Utils.Test where
|
||||||
|
|
||||||
import Test.HUnit
|
import Test.HUnit
|
||||||
import Text.Parsec
|
import Text.Megaparsec
|
||||||
|
|
||||||
-- | Get a Test's label, or the empty string.
|
-- | Get a Test's label, or the empty string.
|
||||||
testName :: Test -> String
|
testName :: Test -> String
|
||||||
@ -25,15 +25,16 @@ is :: (Eq a, Show a) => a -> a -> Assertion
|
|||||||
a `is` e = assertEqual "" e a
|
a `is` e = assertEqual "" e a
|
||||||
|
|
||||||
-- | Assert a parse result is successful, printing the parse error on failure.
|
-- | Assert a parse result is successful, printing the parse error on failure.
|
||||||
assertParse :: (Either ParseError a) -> Assertion
|
assertParse :: (Show t, Show e) => (Either (ParseError t e) a) -> Assertion
|
||||||
assertParse parse = either (assertFailure.show) (const (return ())) parse
|
assertParse parse = either (assertFailure.show) (const (return ())) parse
|
||||||
|
|
||||||
|
|
||||||
-- | Assert a parse result is successful, printing the parse error on failure.
|
-- | Assert a parse result is successful, printing the parse error on failure.
|
||||||
assertParseFailure :: (Either ParseError a) -> Assertion
|
assertParseFailure :: (Either (ParseError t e) a) -> Assertion
|
||||||
assertParseFailure parse = either (const $ return ()) (const $ assertFailure "parse should not have succeeded") parse
|
assertParseFailure parse = either (const $ return ()) (const $ assertFailure "parse should not have succeeded") parse
|
||||||
|
|
||||||
-- | Assert a parse result is some expected value, printing the parse error on failure.
|
-- | Assert a parse result is some expected value, printing the parse error on failure.
|
||||||
assertParseEqual :: (Show a, Eq a) => (Either ParseError a) -> a -> Assertion
|
assertParseEqual :: (Show a, Eq a, Show t, Show e) => (Either (ParseError t e) a) -> a -> Assertion
|
||||||
assertParseEqual parse expected = either (assertFailure.show) (`is` expected) parse
|
assertParseEqual parse expected = either (assertFailure.show) (`is` expected) parse
|
||||||
|
|
||||||
printParseError :: (Show a) => a -> IO ()
|
printParseError :: (Show a) => a -> IO ()
|
||||||
|
|||||||
@ -114,6 +114,14 @@ textElideRight width t =
|
|||||||
-- | last s == '\n' = s
|
-- | last s == '\n' = s
|
||||||
-- | otherwise = s ++ "\n"
|
-- | otherwise = s ++ "\n"
|
||||||
|
|
||||||
|
-- | Wrap a string in double quotes, and \-prefix any embedded single
|
||||||
|
-- quotes, if it contains whitespace and is not already single- or
|
||||||
|
-- double-quoted.
|
||||||
|
quoteIfSpaced :: T.Text -> T.Text
|
||||||
|
quoteIfSpaced s | isSingleQuoted s || isDoubleQuoted s = s
|
||||||
|
| not $ any (`elem` (T.unpack s)) whitespacechars = s
|
||||||
|
| otherwise = "'"<>escapeSingleQuotes s<>"'"
|
||||||
|
|
||||||
-- -- | Wrap a string in double quotes, and \-prefix any embedded single
|
-- -- | Wrap a string in double quotes, and \-prefix any embedded single
|
||||||
-- -- quotes, if it contains whitespace and is not already single- or
|
-- -- quotes, if it contains whitespace and is not already single- or
|
||||||
-- -- double-quoted.
|
-- -- double-quoted.
|
||||||
@ -124,8 +132,8 @@ textElideRight width t =
|
|||||||
|
|
||||||
-- -- | Double-quote this string if it contains whitespace, single quotes
|
-- -- | Double-quote this string if it contains whitespace, single quotes
|
||||||
-- -- or double-quotes, escaping the quotes as needed.
|
-- -- or double-quotes, escaping the quotes as needed.
|
||||||
-- quoteIfNeeded :: String -> String
|
-- quoteIfNeeded :: T.Text -> T.Text
|
||||||
-- quoteIfNeeded s | any (`elem` s) (quotechars++whitespacechars) = "\"" ++ escapeDoubleQuotes s ++ "\""
|
-- quoteIfNeeded s | any (`elem` T.unpack s) (quotechars++whitespacechars) = "\"" <> escapeDoubleQuotes s <> "\""
|
||||||
-- | otherwise = s
|
-- | otherwise = s
|
||||||
|
|
||||||
-- -- | Single-quote this string if it contains whitespace or double-quotes.
|
-- -- | Single-quote this string if it contains whitespace or double-quotes.
|
||||||
@ -134,15 +142,15 @@ textElideRight width t =
|
|||||||
-- singleQuoteIfNeeded s | any (`elem` s) whitespacechars = "'"++s++"'"
|
-- singleQuoteIfNeeded s | any (`elem` s) whitespacechars = "'"++s++"'"
|
||||||
-- | otherwise = s
|
-- | otherwise = s
|
||||||
|
|
||||||
-- quotechars, whitespacechars :: [Char]
|
quotechars, whitespacechars :: [Char]
|
||||||
-- quotechars = "'\""
|
quotechars = "'\""
|
||||||
-- whitespacechars = " \t\n\r"
|
whitespacechars = " \t\n\r"
|
||||||
|
|
||||||
-- escapeDoubleQuotes :: String -> String
|
escapeDoubleQuotes :: T.Text -> T.Text
|
||||||
-- escapeDoubleQuotes = regexReplace "\"" "\""
|
escapeDoubleQuotes = T.replace "\"" "\""
|
||||||
|
|
||||||
-- escapeSingleQuotes :: String -> String
|
escapeSingleQuotes :: T.Text -> T.Text
|
||||||
-- escapeSingleQuotes = regexReplace "'" "\'"
|
escapeSingleQuotes = T.replace "'" "\'"
|
||||||
|
|
||||||
-- escapeQuotes :: String -> String
|
-- escapeQuotes :: String -> String
|
||||||
-- escapeQuotes = regexReplace "([\"'])" "\\1"
|
-- escapeQuotes = regexReplace "([\"'])" "\\1"
|
||||||
@ -161,18 +169,20 @@ textElideRight width t =
|
|||||||
-- doubleQuotedPattern = between (char '"') (char '"') (many $ noneOf "\"")
|
-- doubleQuotedPattern = between (char '"') (char '"') (many $ noneOf "\"")
|
||||||
|
|
||||||
-- -- | Quote-aware version of unwords - single-quote strings which contain whitespace
|
-- -- | Quote-aware version of unwords - single-quote strings which contain whitespace
|
||||||
-- unwords' :: [String] -> String
|
-- unwords' :: [Text] -> Text
|
||||||
-- unwords' = unwords . map quoteIfNeeded
|
-- unwords' = T.unwords . map quoteIfNeeded
|
||||||
|
|
||||||
-- -- | Strip one matching pair of single or double quotes on the ends of a string.
|
-- | Strip one matching pair of single or double quotes on the ends of a string.
|
||||||
-- stripquotes :: String -> String
|
stripquotes :: Text -> Text
|
||||||
-- stripquotes s = if isSingleQuoted s || isDoubleQuoted s then init $ tail s else s
|
stripquotes s = if isSingleQuoted s || isDoubleQuoted s then T.init $ T.tail s else s
|
||||||
|
|
||||||
-- isSingleQuoted s@(_:_:_) = head s == '\'' && last s == '\''
|
isSingleQuoted :: Text -> Bool
|
||||||
-- isSingleQuoted _ = False
|
isSingleQuoted s =
|
||||||
|
T.length (T.take 2 s) == 2 && T.head s == '\'' && T.last s == '\''
|
||||||
|
|
||||||
-- isDoubleQuoted s@(_:_:_) = head s == '"' && last s == '"'
|
isDoubleQuoted :: Text -> Bool
|
||||||
-- isDoubleQuoted _ = False
|
isDoubleQuoted s =
|
||||||
|
T.length (T.take 2 s) == 2 && T.head s == '"' && T.last s == '"'
|
||||||
|
|
||||||
textUnbracket :: Text -> Text
|
textUnbracket :: Text -> Text
|
||||||
textUnbracket s
|
textUnbracket s
|
||||||
|
|||||||
@ -4,7 +4,7 @@ module Hledger.Utils.Tree where
|
|||||||
import Data.List (foldl')
|
import Data.List (foldl')
|
||||||
import qualified Data.Map as M
|
import qualified Data.Map as M
|
||||||
import Data.Tree
|
import Data.Tree
|
||||||
-- import Text.Parsec
|
-- import Text.Megaparsec
|
||||||
-- import Text.Printf
|
-- import Text.Printf
|
||||||
|
|
||||||
import Hledger.Utils.Regex
|
import Hledger.Utils.Regex
|
||||||
|
|||||||
@ -77,7 +77,7 @@ dependencies:
|
|||||||
- mtl
|
- mtl
|
||||||
- mtl-compat
|
- mtl-compat
|
||||||
- old-time
|
- old-time
|
||||||
- parsec >= 3
|
- megaparsec >= 5
|
||||||
- regex-tdfa
|
- regex-tdfa
|
||||||
- safe >= 0.2
|
- safe >= 0.2
|
||||||
- split >= 0.1 && < 0.3
|
- split >= 0.1 && < 0.3
|
||||||
|
|||||||
@ -78,9 +78,11 @@ library
|
|||||||
, mtl
|
, mtl
|
||||||
, mtl-compat
|
, mtl-compat
|
||||||
, old-time
|
, old-time
|
||||||
, parsec >= 3
|
, megaparsec >= 5
|
||||||
|
, parsec
|
||||||
, regex-tdfa
|
, regex-tdfa
|
||||||
, safe >= 0.2
|
, safe >= 0.2
|
||||||
|
, semigroups
|
||||||
, split >= 0.1 && < 0.3
|
, split >= 0.1 && < 0.3
|
||||||
, text >= 1.2 && < 1.3
|
, text >= 1.2 && < 1.3
|
||||||
, transformers >= 0.2 && < 0.6
|
, transformers >= 0.2 && < 0.6
|
||||||
@ -159,7 +161,7 @@ test-suite hunittests
|
|||||||
, mtl
|
, mtl
|
||||||
, mtl-compat
|
, mtl-compat
|
||||||
, old-time
|
, old-time
|
||||||
, parsec >= 3
|
, megaparsec >= 5
|
||||||
, regex-tdfa
|
, regex-tdfa
|
||||||
, safe >= 0.2
|
, safe >= 0.2
|
||||||
, split >= 0.1 && < 0.3
|
, split >= 0.1 && < 0.3
|
||||||
|
|||||||
@ -17,7 +17,7 @@ import Control.Monad.IO.Class (liftIO)
|
|||||||
import Data.Monoid
|
import Data.Monoid
|
||||||
import Data.Time.Calendar (Day)
|
import Data.Time.Calendar (Day)
|
||||||
import Graphics.Vty (Event(..),Key(..))
|
import Graphics.Vty (Event(..),Key(..))
|
||||||
import Text.Parsec
|
import Text.Megaparsec
|
||||||
|
|
||||||
import Hledger.Cli hiding (progname,prognameandversion,green)
|
import Hledger.Cli hiding (progname,prognameandversion,green)
|
||||||
import Hledger.UI.UIOptions
|
import Hledger.UI.UIOptions
|
||||||
@ -88,7 +88,7 @@ esHandle ui@UIState{
|
|||||||
EvKey (KChar c) [] | c `elem` ['h','?'] -> continue $ setMode Help ui
|
EvKey (KChar c) [] | c `elem` ['h','?'] -> continue $ setMode Help ui
|
||||||
EvKey (KChar 'E') [] -> suspendAndResume $ void (runEditor pos f) >> uiReloadJournalIfChanged copts d j (popScreen ui)
|
EvKey (KChar 'E') [] -> suspendAndResume $ void (runEditor pos f) >> uiReloadJournalIfChanged copts d j (popScreen ui)
|
||||||
where
|
where
|
||||||
(pos,f) = case parsewith hledgerparseerrorpositionp esError of
|
(pos,f) = case parsewithString hledgerparseerrorpositionp esError of
|
||||||
Right (f,l,c) -> (Just (l, Just c),f)
|
Right (f,l,c) -> (Just (l, Just c),f)
|
||||||
Left _ -> (endPos, journalFilePath j)
|
Left _ -> (endPos, journalFilePath j)
|
||||||
EvKey (KChar 'g') [] -> liftIO (uiReloadJournalIfChanged copts d j (popScreen ui)) >>= continue . uiCheckBalanceAssertions d
|
EvKey (KChar 'g') [] -> liftIO (uiReloadJournalIfChanged copts d j (popScreen ui)) >>= continue . uiCheckBalanceAssertions d
|
||||||
@ -103,13 +103,14 @@ esHandle _ _ = error "event handler called with wrong screen type, should not ha
|
|||||||
|
|
||||||
-- | Parse the file name, line and column number from a hledger parse error message, if possible.
|
-- | Parse the file name, line and column number from a hledger parse error message, if possible.
|
||||||
-- Temporary, we should keep the original parse error location. XXX
|
-- Temporary, we should keep the original parse error location. XXX
|
||||||
|
hledgerparseerrorpositionp :: ParsecT Dec String t (String, Int, Int)
|
||||||
hledgerparseerrorpositionp = do
|
hledgerparseerrorpositionp = do
|
||||||
anyChar `manyTill` char '"'
|
anyChar `manyTill` char '"'
|
||||||
f <- anyChar `manyTill` (oneOf ['"','\n'])
|
f <- anyChar `manyTill` (oneOf ['"','\n'])
|
||||||
string " (line "
|
string " (line "
|
||||||
l <- read <$> many1 digit
|
l <- read <$> some digitChar
|
||||||
string ", column "
|
string ", column "
|
||||||
c <- read <$> many1 digit
|
c <- read <$> some digitChar
|
||||||
return (f, l, c)
|
return (f, l, c)
|
||||||
|
|
||||||
-- Unconditionally reload the journal, regenerating the current screen
|
-- Unconditionally reload the journal, regenerating the current screen
|
||||||
|
|||||||
@ -69,7 +69,7 @@ executable hledger-ui
|
|||||||
, HUnit
|
, HUnit
|
||||||
, microlens >= 0.4 && < 0.5
|
, microlens >= 0.4 && < 0.5
|
||||||
, microlens-platform >= 0.2.3.1 && < 0.4
|
, microlens-platform >= 0.2.3.1 && < 0.4
|
||||||
, parsec >= 3
|
, megaparsec >= 5
|
||||||
, process >= 1.2
|
, process >= 1.2
|
||||||
, safe >= 0.2
|
, safe >= 0.2
|
||||||
, split >= 0.1 && < 0.3
|
, split >= 0.1 && < 0.3
|
||||||
|
|||||||
@ -85,7 +85,7 @@ executables:
|
|||||||
- HUnit
|
- HUnit
|
||||||
- microlens >= 0.4 && < 0.5
|
- microlens >= 0.4 && < 0.5
|
||||||
- microlens-platform >= 0.2.3.1 && < 0.4
|
- microlens-platform >= 0.2.3.1 && < 0.4
|
||||||
- parsec >= 3
|
- megaparsec >= 5
|
||||||
- process >= 1.2
|
- process >= 1.2
|
||||||
- safe >= 0.2
|
- safe >= 0.2
|
||||||
- split >= 0.1 && < 0.3
|
- split >= 0.1 && < 0.3
|
||||||
|
|||||||
@ -215,8 +215,8 @@ nullviewdata = viewdataWithDateAndParams nulldate "" "" ""
|
|||||||
-- | Make a ViewData using the given date and request parameters, and defaults elsewhere.
|
-- | Make a ViewData using the given date and request parameters, and defaults elsewhere.
|
||||||
viewdataWithDateAndParams :: Day -> String -> String -> String -> ViewData
|
viewdataWithDateAndParams :: Day -> String -> String -> String -> ViewData
|
||||||
viewdataWithDateAndParams d q a p =
|
viewdataWithDateAndParams d q a p =
|
||||||
let (querymatcher,queryopts) = parseQuery d q
|
let (querymatcher,queryopts) = parseQuery d (pack q)
|
||||||
(acctsmatcher,acctsopts) = parseQuery d a
|
(acctsmatcher,acctsopts) = parseQuery d (pack a)
|
||||||
in VD {
|
in VD {
|
||||||
opts = defwebopts
|
opts = defwebopts
|
||||||
,j = nulljournal
|
,j = nulljournal
|
||||||
|
|||||||
@ -1,4 +1,4 @@
|
|||||||
{-# LANGUAGE CPP, FlexibleContexts, OverloadedStrings, QuasiQuotes, RecordWildCards #-}
|
{-# LANGUAGE CPP, FlexibleContexts, OverloadedStrings, QuasiQuotes, RecordWildCards, TypeFamilies #-}
|
||||||
-- | Add form data & handler. (The layout and js are defined in
|
-- | Add form data & handler. (The layout and js are defined in
|
||||||
-- Foundation so that the add form can be in the default layout for
|
-- Foundation so that the add form can be in the default layout for
|
||||||
-- all views.)
|
-- all views.)
|
||||||
@ -10,13 +10,14 @@ import Import
|
|||||||
#if !MIN_VERSION_base(4,8,0)
|
#if !MIN_VERSION_base(4,8,0)
|
||||||
import Control.Applicative
|
import Control.Applicative
|
||||||
#endif
|
#endif
|
||||||
|
import Control.Monad.State.Strict (evalStateT)
|
||||||
import Data.Either (lefts,rights)
|
import Data.Either (lefts,rights)
|
||||||
import Data.List (sort)
|
import Data.List (sort)
|
||||||
import qualified Data.List as L (head) -- qualified keeps dev & prod builds warning-free
|
import qualified Data.List as L (head) -- qualified keeps dev & prod builds warning-free
|
||||||
import Data.Text (append, pack, unpack)
|
import Data.Text (append, pack, unpack)
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import Data.Time.Calendar
|
import Data.Time.Calendar
|
||||||
import Text.Parsec (digit, eof, many1, string, runParser)
|
import Text.Megaparsec (digitChar, eof, some, string, runParser, runParserT, ParseError, Dec)
|
||||||
|
|
||||||
import Hledger.Utils
|
import Hledger.Utils
|
||||||
import Hledger.Data hiding (num)
|
import Hledger.Data hiding (num)
|
||||||
@ -55,7 +56,7 @@ postAddForm = do
|
|||||||
|
|
||||||
validateDate :: Text -> Handler (Either FormMessage Day)
|
validateDate :: Text -> Handler (Either FormMessage Day)
|
||||||
validateDate s = return $
|
validateDate s = return $
|
||||||
case fixSmartDateStrEither' today $ strip $ unpack s of
|
case fixSmartDateStrEither' today $ T.pack $ strip $ unpack s of
|
||||||
Right d -> Right d
|
Right d -> Right d
|
||||||
Left _ -> Left $ MsgInvalidEntry $ pack "could not parse date \"" `append` s `append` pack "\":" -- ++ show e)
|
Left _ -> Left $ MsgInvalidEntry $ pack "could not parse date \"" `append` s `append` pack "\":" -- ++ show e)
|
||||||
|
|
||||||
@ -83,11 +84,11 @@ postAddForm = do
|
|||||||
let numberedParams s =
|
let numberedParams s =
|
||||||
reverse $ dropWhile (T.null . snd) $ reverse $ sort
|
reverse $ dropWhile (T.null . snd) $ reverse $ sort
|
||||||
[ (n,v) | (k,v) <- params
|
[ (n,v) | (k,v) <- params
|
||||||
, let en = parsewith (paramnamep s) $ T.unpack k
|
, let en = parsewith (paramnamep s) k :: Either (ParseError Char Dec) Int
|
||||||
, isRight en
|
, isRight en
|
||||||
, let Right n = en
|
, let Right n = en
|
||||||
]
|
]
|
||||||
where paramnamep s = do {string s; n <- many1 digit; eof; return (read n :: Int)}
|
where paramnamep s = do {string s; n <- some digitChar; eof; return (read n :: Int)}
|
||||||
acctparams = numberedParams "account"
|
acctparams = numberedParams "account"
|
||||||
amtparams = numberedParams "amount"
|
amtparams = numberedParams "amount"
|
||||||
num = length acctparams
|
num = length acctparams
|
||||||
@ -95,8 +96,8 @@ postAddForm = do
|
|||||||
| map fst acctparams == [1..num] &&
|
| map fst acctparams == [1..num] &&
|
||||||
map fst amtparams `elem` [[1..num], [1..num-1]] = []
|
map fst amtparams `elem` [[1..num], [1..num-1]] = []
|
||||||
| otherwise = ["the posting parameters are malformed"]
|
| otherwise = ["the posting parameters are malformed"]
|
||||||
eaccts = map (runParser (accountnamep <* eof) () "" . textstrip . snd) acctparams
|
eaccts = map (runParser (accountnamep <* eof) "" . textstrip . snd) acctparams
|
||||||
eamts = map (runParser (amountp <* eof) mempty "" . textstrip . snd) amtparams
|
eamts = map (runParser (evalStateT (amountp <* eof) mempty) "" . textstrip . snd) amtparams
|
||||||
(accts, acctErrs) = (rights eaccts, map show $ lefts eaccts)
|
(accts, acctErrs) = (rights eaccts, map show $ lefts eaccts)
|
||||||
(amts', amtErrs) = (rights eamts, map show $ lefts eamts)
|
(amts', amtErrs) = (rights eamts, map show $ lefts eamts)
|
||||||
amts | length amts' == num = amts'
|
amts | length amts' == num = amts'
|
||||||
|
|||||||
@ -226,10 +226,10 @@ balanceReportAsHtml _ vd@VD{..} (items',total) =
|
|||||||
acctonlyquery = (RegisterR, [("q", T.pack $ accountOnlyQuery acct)])
|
acctonlyquery = (RegisterR, [("q", T.pack $ accountOnlyQuery acct)])
|
||||||
|
|
||||||
accountQuery :: AccountName -> String
|
accountQuery :: AccountName -> String
|
||||||
accountQuery a = "inacct:" ++ quoteIfSpaced (T.unpack a) -- (accountNameToAccountRegex a)
|
accountQuery a = "inacct:" ++ T.unpack (quoteIfSpaced a) -- (accountNameToAccountRegex a)
|
||||||
|
|
||||||
accountOnlyQuery :: AccountName -> String
|
accountOnlyQuery :: AccountName -> String
|
||||||
accountOnlyQuery a = "inacctonly:" ++ quoteIfSpaced (T.unpack a) -- (accountNameToAccountRegex a)
|
accountOnlyQuery a = "inacctonly:" ++ T.unpack (quoteIfSpaced a ) -- (accountNameToAccountRegex a)
|
||||||
|
|
||||||
accountUrl :: AppRoute -> AccountName -> (AppRoute, [(Text, Text)])
|
accountUrl :: AppRoute -> AccountName -> (AppRoute, [(Text, Text)])
|
||||||
accountUrl r a = (r, [("q", T.pack $ accountQuery a)])
|
accountUrl r a = (r, [("q", T.pack $ accountQuery a)])
|
||||||
|
|||||||
@ -101,7 +101,8 @@ library
|
|||||||
, http-client
|
, http-client
|
||||||
, HUnit
|
, HUnit
|
||||||
, conduit-extra >= 1.1
|
, conduit-extra >= 1.1
|
||||||
, parsec >= 3
|
, megaparsec >= 5
|
||||||
|
, mtl
|
||||||
, safe >= 0.2
|
, safe >= 0.2
|
||||||
, shakespeare >= 2.0
|
, shakespeare >= 2.0
|
||||||
, template-haskell
|
, template-haskell
|
||||||
|
|||||||
@ -12,6 +12,8 @@ import Prelude ()
|
|||||||
import Prelude.Compat
|
import Prelude.Compat
|
||||||
import Control.Exception as E
|
import Control.Exception as E
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
|
import Control.Monad.Trans.Class
|
||||||
|
import Control.Monad.State.Strict (evalState, evalStateT)
|
||||||
import Control.Monad.Trans (liftIO)
|
import Control.Monad.Trans (liftIO)
|
||||||
import Data.Char (toUpper, toLower)
|
import Data.Char (toUpper, toLower)
|
||||||
import Data.List.Compat
|
import Data.List.Compat
|
||||||
@ -28,7 +30,8 @@ import System.Console.Haskeline.Completion
|
|||||||
import System.Console.Wizard
|
import System.Console.Wizard
|
||||||
import System.Console.Wizard.Haskeline
|
import System.Console.Wizard.Haskeline
|
||||||
import System.IO ( stderr, hPutStr, hPutStrLn )
|
import System.IO ( stderr, hPutStr, hPutStrLn )
|
||||||
import Text.Parsec
|
import Text.Megaparsec
|
||||||
|
import Text.Megaparsec.Text
|
||||||
import Text.Printf
|
import Text.Printf
|
||||||
|
|
||||||
import Hledger
|
import Hledger
|
||||||
@ -86,7 +89,7 @@ add opts j
|
|||||||
showHelp
|
showHelp
|
||||||
today <- getCurrentDay
|
today <- getCurrentDay
|
||||||
let es = defEntryState{esOpts=opts
|
let es = defEntryState{esOpts=opts
|
||||||
,esArgs=map stripquotes $ listofstringopt "args" $ rawopts_ opts
|
,esArgs=map (T.unpack . stripquotes . T.pack) $ listofstringopt "args" $ rawopts_ opts
|
||||||
,esToday=today
|
,esToday=today
|
||||||
,esDefDate=today
|
,esDefDate=today
|
||||||
,esJournal=j
|
,esJournal=j
|
||||||
@ -183,11 +186,11 @@ dateAndCodeWizard EntryState{..} = do
|
|||||||
where
|
where
|
||||||
parseSmartDateAndCode refdate s = either (const Nothing) (\(d,c) -> return (fixSmartDate refdate d, c)) edc
|
parseSmartDateAndCode refdate s = either (const Nothing) (\(d,c) -> return (fixSmartDate refdate d, c)) edc
|
||||||
where
|
where
|
||||||
edc = runParser (dateandcodep <* eof) mempty "" $ T.pack $ lowercase s
|
edc = runParser (dateandcodep <* eof) "" $ T.pack $ lowercase s
|
||||||
dateandcodep :: Monad m => JournalParser m (SmartDate, Text)
|
dateandcodep :: Parser (SmartDate, Text)
|
||||||
dateandcodep = do
|
dateandcodep = do
|
||||||
d <- smartdate
|
d <- smartdate
|
||||||
c <- optionMaybe codep
|
c <- optional codep
|
||||||
many spacenonewline
|
many spacenonewline
|
||||||
eof
|
eof
|
||||||
return (d, T.pack $ fromMaybe "" c)
|
return (d, T.pack $ fromMaybe "" c)
|
||||||
@ -250,7 +253,7 @@ accountWizard EntryState{..} = do
|
|||||||
parseAccountOrDotOrNull def@(_:_) _ "" = dbg1 $ Just def -- when there's a default, "" means use that
|
parseAccountOrDotOrNull def@(_:_) _ "" = dbg1 $ Just def -- when there's a default, "" means use that
|
||||||
parseAccountOrDotOrNull _ _ s = dbg1 $ fmap T.unpack $
|
parseAccountOrDotOrNull _ _ s = dbg1 $ fmap T.unpack $
|
||||||
either (const Nothing) validateAccount $
|
either (const Nothing) validateAccount $
|
||||||
runParser (accountnamep <* eof) esJournal "" (T.pack s) -- otherwise, try to parse the input as an accountname
|
flip evalState esJournal $ runParserT (accountnamep <* eof) "" (T.pack s) -- otherwise, try to parse the input as an accountname
|
||||||
where
|
where
|
||||||
validateAccount :: Text -> Maybe Text
|
validateAccount :: Text -> Maybe Text
|
||||||
validateAccount t | no_new_accounts_ esOpts && not (t `elem` journalAccountNames esJournal) = Nothing
|
validateAccount t | no_new_accounts_ esOpts && not (t `elem` journalAccountNames esJournal) = Nothing
|
||||||
@ -276,13 +279,17 @@ amountAndCommentWizard EntryState{..} = do
|
|||||||
maybeRestartTransaction $
|
maybeRestartTransaction $
|
||||||
line $ green $ printf "Amount %d%s: " pnum (showDefault def)
|
line $ green $ printf "Amount %d%s: " pnum (showDefault def)
|
||||||
where
|
where
|
||||||
parseAmountAndComment = either (const Nothing) Just . runParser (amountandcommentp <* eof) nodefcommodityj "" . T.pack
|
parseAmountAndComment s = either (const Nothing) Just $
|
||||||
|
runParser
|
||||||
|
(evalStateT (amountandcommentp <* eof) nodefcommodityj)
|
||||||
|
""
|
||||||
|
(T.pack s)
|
||||||
nodefcommodityj = esJournal{jparsedefaultcommodity=Nothing}
|
nodefcommodityj = esJournal{jparsedefaultcommodity=Nothing}
|
||||||
amountandcommentp :: Monad m => JournalParser m (Amount, Text)
|
amountandcommentp :: JournalParser (Amount, Text)
|
||||||
amountandcommentp = do
|
amountandcommentp = do
|
||||||
a <- amountp
|
a <- amountp
|
||||||
many spacenonewline
|
lift (many spacenonewline)
|
||||||
c <- T.pack <$> fromMaybe "" `fmap` optionMaybe (char ';' >> many anyChar)
|
c <- T.pack <$> fromMaybe "" `fmap` optional (char ';' >> many anyChar)
|
||||||
-- eof
|
-- eof
|
||||||
return (a,c)
|
return (a,c)
|
||||||
balancingamt = negate $ sum $ map pamount realps where realps = filter isReal esPostings
|
balancingamt = negate $ sum $ map pamount realps where realps = filter isReal esPostings
|
||||||
|
|||||||
@ -5,7 +5,7 @@ related utilities used by hledger commands.
|
|||||||
|
|
||||||
-}
|
-}
|
||||||
|
|
||||||
{-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable, FlexibleContexts #-}
|
{-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable, FlexibleContexts, TypeFamilies #-}
|
||||||
|
|
||||||
module Hledger.Cli.CliOptions (
|
module Hledger.Cli.CliOptions (
|
||||||
|
|
||||||
@ -69,6 +69,7 @@ import Control.Monad (when)
|
|||||||
#if !MIN_VERSION_base(4,8,0)
|
#if !MIN_VERSION_base(4,8,0)
|
||||||
import Data.Functor.Compat ((<$>))
|
import Data.Functor.Compat ((<$>))
|
||||||
#endif
|
#endif
|
||||||
|
import Data.Functor.Identity (Identity)
|
||||||
import Data.List.Compat
|
import Data.List.Compat
|
||||||
import Data.List.Split (splitOneOf)
|
import Data.List.Split (splitOneOf)
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
@ -86,7 +87,7 @@ import System.Environment
|
|||||||
import System.Exit (exitSuccess)
|
import System.Exit (exitSuccess)
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
import Test.HUnit
|
import Test.HUnit
|
||||||
import Text.Parsec
|
import Text.Megaparsec
|
||||||
|
|
||||||
import Hledger
|
import Hledger
|
||||||
import Hledger.Cli.DocFiles
|
import Hledger.Cli.DocFiles
|
||||||
@ -334,11 +335,11 @@ rawOptsToCliOpts rawopts = checkCliOpts <$> do
|
|||||||
return defcliopts {
|
return defcliopts {
|
||||||
rawopts_ = rawopts
|
rawopts_ = rawopts
|
||||||
,command_ = stringopt "command" rawopts
|
,command_ = stringopt "command" rawopts
|
||||||
,file_ = map stripquotes $ listofstringopt "file" rawopts
|
,file_ = map (T.unpack . stripquotes . T.pack) $ listofstringopt "file" rawopts
|
||||||
,rules_file_ = maybestringopt "rules-file" rawopts
|
,rules_file_ = maybestringopt "rules-file" rawopts
|
||||||
,output_file_ = maybestringopt "output-file" rawopts
|
,output_file_ = maybestringopt "output-file" rawopts
|
||||||
,output_format_ = maybestringopt "output-format" rawopts
|
,output_format_ = maybestringopt "output-format" rawopts
|
||||||
,alias_ = map stripquotes $ listofstringopt "alias" rawopts
|
,alias_ = map (T.unpack . stripquotes . T.pack) $ listofstringopt "alias" rawopts
|
||||||
,debug_ = intopt "debug" rawopts
|
,debug_ = intopt "debug" rawopts
|
||||||
,ignore_assertions_ = boolopt "ignore-assertions" rawopts
|
,ignore_assertions_ = boolopt "ignore-assertions" rawopts
|
||||||
,no_new_accounts_ = boolopt "no-new-accounts" rawopts -- add
|
,no_new_accounts_ = boolopt "no-new-accounts" rawopts -- add
|
||||||
@ -387,7 +388,7 @@ getCliOpts mode' = do
|
|||||||
|
|
||||||
-- | Get the account name aliases from options, if any.
|
-- | Get the account name aliases from options, if any.
|
||||||
aliasesFromOpts :: CliOpts -> [AccountAlias]
|
aliasesFromOpts :: CliOpts -> [AccountAlias]
|
||||||
aliasesFromOpts = map (\a -> fromparse $ runParser accountaliasp () ("--alias "++quoteIfNeeded a) $ T.pack a)
|
aliasesFromOpts = map (\a -> fromparse $ runParser accountaliasp ("--alias "++quoteIfNeeded a) $ T.pack a)
|
||||||
. alias_
|
. alias_
|
||||||
|
|
||||||
-- | Get the (tilde-expanded, absolute) journal file path from
|
-- | Get the (tilde-expanded, absolute) journal file path from
|
||||||
@ -453,7 +454,7 @@ rulesFilePathFromOpts opts = do
|
|||||||
widthFromOpts :: CliOpts -> Int
|
widthFromOpts :: CliOpts -> Int
|
||||||
widthFromOpts CliOpts{width_=Nothing, available_width_=w} = w
|
widthFromOpts CliOpts{width_=Nothing, available_width_=w} = w
|
||||||
widthFromOpts CliOpts{width_=Just s} =
|
widthFromOpts CliOpts{width_=Just s} =
|
||||||
case runParser (read `fmap` many1 digit <* eof) () "(unknown)" s of
|
case runParser (read `fmap` some digitChar <* eof :: ParsecT Dec String Identity Int) "(unknown)" s of
|
||||||
Left e -> optserror $ "could not parse width option: "++show e
|
Left e -> optserror $ "could not parse width option: "++show e
|
||||||
Right w -> w
|
Right w -> w
|
||||||
|
|
||||||
@ -471,14 +472,14 @@ widthFromOpts CliOpts{width_=Just s} =
|
|||||||
registerWidthsFromOpts :: CliOpts -> (Int, Maybe Int)
|
registerWidthsFromOpts :: CliOpts -> (Int, Maybe Int)
|
||||||
registerWidthsFromOpts CliOpts{width_=Nothing, available_width_=w} = (w, Nothing)
|
registerWidthsFromOpts CliOpts{width_=Nothing, available_width_=w} = (w, Nothing)
|
||||||
registerWidthsFromOpts CliOpts{width_=Just s} =
|
registerWidthsFromOpts CliOpts{width_=Just s} =
|
||||||
case runParser registerwidthp () "(unknown)" s of
|
case runParser registerwidthp "(unknown)" s of
|
||||||
Left e -> optserror $ "could not parse width option: "++show e
|
Left e -> optserror $ "could not parse width option: "++show e
|
||||||
Right ws -> ws
|
Right ws -> ws
|
||||||
where
|
where
|
||||||
registerwidthp :: Stream [Char] m t => ParsecT [Char] st m (Int, Maybe Int)
|
registerwidthp :: (Stream s, Char ~ Token s) => ParsecT Dec s m (Int, Maybe Int)
|
||||||
registerwidthp = do
|
registerwidthp = do
|
||||||
totalwidth <- read `fmap` many1 digit
|
totalwidth <- read `fmap` some digitChar
|
||||||
descwidth <- optionMaybe (char ',' >> read `fmap` many1 digit)
|
descwidth <- optional (char ',' >> read `fmap` some digitChar)
|
||||||
eof
|
eof
|
||||||
return (totalwidth, descwidth)
|
return (totalwidth, descwidth)
|
||||||
|
|
||||||
@ -556,12 +557,12 @@ hledgerExecutablesInPath = do
|
|||||||
-- isExecutable f = getPermissions f >>= (return . executable)
|
-- isExecutable f = getPermissions f >>= (return . executable)
|
||||||
|
|
||||||
isHledgerExeName :: String -> Bool
|
isHledgerExeName :: String -> Bool
|
||||||
isHledgerExeName = isRight . parsewith hledgerexenamep
|
isHledgerExeName = isRight . parsewith hledgerexenamep . T.pack
|
||||||
where
|
where
|
||||||
hledgerexenamep = do
|
hledgerexenamep = do
|
||||||
_ <- string progname
|
_ <- string progname
|
||||||
_ <- char '-'
|
_ <- char '-'
|
||||||
_ <- many1 (noneOf ".")
|
_ <- some (noneOf ".")
|
||||||
optional (string "." >> choice' (map string addonExtensions))
|
optional (string "." >> choice' (map string addonExtensions))
|
||||||
eof
|
eof
|
||||||
|
|
||||||
|
|||||||
@ -27,6 +27,7 @@ import Data.List
|
|||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
|
import qualified Data.Text.IO as T
|
||||||
import Data.Time (Day)
|
import Data.Time (Day)
|
||||||
import Safe (readMay)
|
import Safe (readMay)
|
||||||
import System.Console.CmdArgs
|
import System.Console.CmdArgs
|
||||||
@ -186,19 +187,19 @@ openBrowserOn u = trybrowsers browsers u
|
|||||||
-- overwrite it with this new text, or give an error, but only if the text
|
-- overwrite it with this new text, or give an error, but only if the text
|
||||||
-- is different from the current file contents, and return a flag
|
-- is different from the current file contents, and return a flag
|
||||||
-- indicating whether we did anything.
|
-- indicating whether we did anything.
|
||||||
writeFileWithBackupIfChanged :: FilePath -> String -> IO Bool
|
writeFileWithBackupIfChanged :: FilePath -> T.Text -> IO Bool
|
||||||
writeFileWithBackupIfChanged f t = do
|
writeFileWithBackupIfChanged f t = do
|
||||||
s <- readFile' f
|
s <- readFile' f
|
||||||
if t == s then return False
|
if t == s then return False
|
||||||
else backUpFile f >> writeFile f t >> return True
|
else backUpFile f >> T.writeFile f t >> return True
|
||||||
|
|
||||||
-- | Back up this file with a (incrementing) numbered suffix, then
|
-- | Back up this file with a (incrementing) numbered suffix, then
|
||||||
-- overwrite it with this new text, or give an error.
|
-- overwrite it with this new text, or give an error.
|
||||||
writeFileWithBackup :: FilePath -> String -> IO ()
|
writeFileWithBackup :: FilePath -> String -> IO ()
|
||||||
writeFileWithBackup f t = backUpFile f >> writeFile f t
|
writeFileWithBackup f t = backUpFile f >> writeFile f t
|
||||||
|
|
||||||
readFileStrictly :: FilePath -> IO String
|
readFileStrictly :: FilePath -> IO T.Text
|
||||||
readFileStrictly f = readFile' f >>= \s -> C.evaluate (length s) >> return s
|
readFileStrictly f = readFile' f >>= \s -> C.evaluate (T.length s) >> return s
|
||||||
|
|
||||||
-- | Back up this file with a (incrementing) numbered suffix, or give an error.
|
-- | Back up this file with a (incrementing) numbered suffix, or give an error.
|
||||||
backUpFile :: FilePath -> IO ()
|
backUpFile :: FilePath -> IO ()
|
||||||
|
|||||||
@ -100,11 +100,12 @@ library
|
|||||||
, mtl
|
, mtl
|
||||||
, mtl-compat
|
, mtl-compat
|
||||||
, old-time
|
, old-time
|
||||||
, parsec >= 3
|
, megaparsec >= 5
|
||||||
, process
|
, process
|
||||||
, regex-tdfa
|
, regex-tdfa
|
||||||
, safe >= 0.2
|
, safe >= 0.2
|
||||||
, split >= 0.1 && < 0.3
|
, split >= 0.1 && < 0.3
|
||||||
|
, transformers
|
||||||
, temporary
|
, temporary
|
||||||
, text >= 0.11
|
, text >= 0.11
|
||||||
, tabular >= 0.2 && < 0.3
|
, tabular >= 0.2 && < 0.3
|
||||||
|
|||||||
@ -12,5 +12,6 @@ packages:
|
|||||||
|
|
||||||
extra-deps:
|
extra-deps:
|
||||||
- brick-0.8
|
- brick-0.8
|
||||||
|
- megaparsec-5.0.1
|
||||||
|
|
||||||
# https://docs.haskellstack.org/en/stable/yaml_configuration/
|
# https://docs.haskellstack.org/en/stable/yaml_configuration/
|
||||||
|
|||||||
@ -40,5 +40,5 @@ hledger -f- print
|
|||||||
<<<
|
<<<
|
||||||
2015/9/6*
|
2015/9/6*
|
||||||
a 0
|
a 0
|
||||||
>>>2 /unexpected "*"/
|
>>>2 /unexpected '*'/
|
||||||
>>>= 1
|
>>>= 1
|
||||||
|
|||||||
@ -23,7 +23,7 @@ end comment
|
|||||||
b 0
|
b 0
|
||||||
; date: 3.32
|
; date: 3.32
|
||||||
|
|
||||||
>>>2 /line 10, column 19/
|
>>>2 /10:19/
|
||||||
>>>=1
|
>>>=1
|
||||||
|
|
||||||
# 3. Ledger's bracketed date syntax is also supported: `[DATE]`,
|
# 3. Ledger's bracketed date syntax is also supported: `[DATE]`,
|
||||||
@ -50,5 +50,5 @@ end comment
|
|||||||
2000/1/2
|
2000/1/2
|
||||||
b 0 ; [1/1=1/2/3/4] bad second date, should error
|
b 0 ; [1/1=1/2/3/4] bad second date, should error
|
||||||
|
|
||||||
>>>2 /line 9, column 25/
|
>>>2 /9:25/
|
||||||
>>>=1
|
>>>=1
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user