Replace Parsec with Megaparsec (see #289) (#366)

* 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:
Moritz Kiefer 2016-07-29 17:57:10 +02:00 committed by Simon Michael
parent 90c0d40777
commit 4141067428
33 changed files with 730 additions and 649 deletions

View File

@ -1,6 +1,8 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE NoMonoLocalBinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
{-|
Date parsing and utilities for hledger.
@ -68,6 +70,8 @@ import Prelude.Compat
import Control.Monad
import Data.List.Compat
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
#if MIN_VERSION_time(1,5,0)
import Data.Time.Format hiding (months)
#else
@ -80,7 +84,8 @@ import Data.Time.Calendar.WeekDate
import Data.Time.Clock
import Data.Time.LocalTime
import Safe (headMay, lastMay, readMay)
import Text.Parsec
import Text.Megaparsec
import Text.Megaparsec.Text
import Text.Printf
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
-- 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)
maybePeriod :: Day -> String -> Maybe (Interval,DateSpan)
maybePeriod :: Day -> Text -> Maybe (Interval,DateSpan)
maybePeriod refdate = either (const Nothing) Just . parsePeriodExpr refdate
-- | 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
-- the provided reference date, or raise an error.
fixSmartDateStr :: Day -> String -> String
fixSmartDateStr :: Day -> Text -> String
fixSmartDateStr d s = either
(\e->error' $ printf "could not parse date %s %s" (show s) (show e))
id
$ fixSmartDateStrEither d s
$ (fixSmartDateStrEither d s :: Either (ParseError Char Dec) String)
-- | 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' :: Day -> String -> Either ParseError Day
fixSmartDateStrEither' d s = case parsewith smartdateonly (lowercase s) of
fixSmartDateStrEither' :: Day -> Text -> Either (ParseError Char Dec) Day
fixSmartDateStrEither' d s = case parsewith smartdateonly (T.toLower s) of
Right sd -> Right $ fixSmartDate d sd
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).
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
-- XXX maybe obscures date errors ? see ledgerdate
(y,m,d) <- choice' [yyyymmdd, ymd, ym, md, y, d, month, mon, today, yesterday, tomorrow, lastthisnextthing]
return (y,m,d)
-- | 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
d <- smartdate
many spacenonewline
eof
return d
datesepchars :: [Char]
datesepchars = "/-."
datesepchar :: Stream s m Char => ParsecT s st m Char
datesepchar :: TextParser m Char
datesepchar = oneOf datesepchars
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
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
y <- count 4 digit
m <- count 2 digit
y <- count 4 digitChar
m <- count 2 digitChar
failIfInvalidMonth m
d <- count 2 digit
d <- count 2 digitChar
failIfInvalidDay d
return (y,m,d)
ymd :: Stream s m Char => ParsecT s st m SmartDate
ymd :: Parser SmartDate
ymd = do
y <- many1 digit
y <- some digitChar
failIfInvalidYear y
sep <- datesepchar
m <- many1 digit
m <- some digitChar
failIfInvalidMonth m
char sep
d <- many1 digit
d <- some digitChar
failIfInvalidDay d
return $ (y,m,d)
ym :: Stream s m Char => ParsecT s st m SmartDate
ym :: Parser SmartDate
ym = do
y <- many1 digit
y <- some digitChar
failIfInvalidYear y
datesepchar
m <- many1 digit
m <- some digitChar
failIfInvalidMonth m
return (y,m,"")
y :: Stream s m Char => ParsecT s st m SmartDate
y :: Parser SmartDate
y = do
y <- many1 digit
y <- some digitChar
failIfInvalidYear y
return (y,"","")
d :: Stream s m Char => ParsecT s st m SmartDate
d :: Parser SmartDate
d = do
d <- many1 digit
d <- some digitChar
failIfInvalidDay d
return ("","",d)
md :: Stream s m Char => ParsecT s st m SmartDate
md :: Parser SmartDate
md = do
m <- many1 digit
m <- some digitChar
failIfInvalidMonth m
datesepchar
d <- many1 digit
d <- some digitChar
failIfInvalidDay 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
monIndex s = maybe 0 (+1) $ lowercase s `elemIndex` monthabbrevs
month :: Stream s m Char => ParsecT s st m SmartDate
month :: Parser SmartDate
month = do
m <- choice $ map (try . string) months
let i = monthIndex m
return ("",show i,"")
mon :: Stream s m Char => ParsecT s st m SmartDate
mon :: Parser SmartDate
mon = do
m <- choice $ map (try . string) monthabbrevs
let i = monIndex m
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")
yesterday = string "yesterday" >> return ("","","yesterday")
tomorrow = string "tomorrow" >> return ("","","tomorrow")
lastthisnextthing :: Stream s m Char => ParsecT s st m SmartDate
lastthisnextthing :: Parser SmartDate
lastthisnextthing = do
r <- choice [
string "last"
@ -717,7 +723,7 @@ lastthisnextthing = do
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"
-- Right (NoInterval,DateSpan 2008/08/01-2008/09/30)
-- >>> p "aug to oct"
@ -728,7 +734,7 @@ lastthisnextthing = do
-- Right (Days 1,DateSpan 2008/08/01-)
-- >>> p "every week to 2009"
-- 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 [
intervalanddateperiodexpr rdate,
intervalperiodexpr,
@ -736,7 +742,7 @@ periodexpr rdate = choice $ map try [
(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
many spacenonewline
i <- reportinginterval
@ -744,20 +750,20 @@ intervalanddateperiodexpr rdate = do
s <- periodexprdatespan rdate
return (i,s)
intervalperiodexpr :: Stream s m Char => ParsecT s st m (Interval, DateSpan)
intervalperiodexpr :: Parser (Interval, DateSpan)
intervalperiodexpr = do
many spacenonewline
i <- reportinginterval
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
many spacenonewline
s <- periodexprdatespan rdate
return (NoInterval, s)
-- Parse a reporting interval.
reportinginterval :: Stream s m Char => ParsecT s st m Interval
reportinginterval :: Parser Interval
reportinginterval = choice' [
tryinterval "day" "daily" Days,
tryinterval "week" "weekly" Weeks,
@ -770,7 +776,7 @@ reportinginterval = choice' [
return $ Months 2,
do string "every"
many spacenonewline
n <- fmap read $ many1 digit
n <- fmap read $ some digitChar
thsuffix
many spacenonewline
string "day"
@ -781,7 +787,7 @@ reportinginterval = choice' [
return $ DayOfWeek n,
do string "every"
many spacenonewline
n <- fmap read $ many1 digit
n <- fmap read $ some digitChar
thsuffix
many spacenonewline
string "day"
@ -797,7 +803,7 @@ reportinginterval = choice' [
thsuffix = choice' $ map string ["st","nd","rd","th"]
-- 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 =
choice' [
do string compact
@ -808,14 +814,14 @@ reportinginterval = choice' [
return $ intcons 1,
do string "every"
many spacenonewline
n <- fmap read $ many1 digit
n <- fmap read $ some digitChar
many spacenonewline
string plural
return $ intcons n
]
where plural = singular ++ "s"
periodexprdatespan :: Stream s m Char => Day -> ParsecT s st m DateSpan
periodexprdatespan :: Day -> Parser DateSpan
periodexprdatespan rdate = choice $ map try [
doubledatespan rdate,
fromdatespan rdate,
@ -823,7 +829,7 @@ periodexprdatespan rdate = choice $ map try [
justdatespan rdate
]
doubledatespan :: Stream s m Char => Day -> ParsecT s st m DateSpan
doubledatespan :: Day -> Parser DateSpan
doubledatespan rdate = do
optional (string "from" >> many spacenonewline)
b <- smartdate
@ -832,7 +838,7 @@ doubledatespan rdate = do
e <- smartdate
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
b <- choice [
do
@ -846,13 +852,13 @@ fromdatespan rdate = do
]
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
choice [string "to", string "-"] >> many spacenonewline
e <- smartdate
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
optional (string "in" >> many spacenonewline)
d <- smartdate

View File

@ -23,6 +23,7 @@ module Hledger.Data.RawOptions (
where
import Data.Maybe
import qualified Data.Text as T
import Safe
import Hledger.Utils
@ -32,7 +33,7 @@ import Hledger.Utils
type RawOpts = [(String,String)]
setopt :: String -> String -> RawOpts -> RawOpts
setopt name val = (++ [(name, quoteIfNeeded val)])
setopt name val = (++ [(name, quoteIfNeeded $ val)])
setboolopt :: String -> RawOpts -> RawOpts
setboolopt name = (++ [(name,"")])
@ -45,7 +46,7 @@ boolopt :: String -> RawOpts -> Bool
boolopt = inRawOpts
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 name = fromMaybe "" . maybestringopt name

View File

@ -2,7 +2,7 @@
-- hledger's report item fields. The formats are used by
-- report-specific renderers like renderBalanceReportItem.
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleContexts, TypeFamilies #-}
module Hledger.Data.StringFormat (
parseStringFormat
@ -19,7 +19,8 @@ import Numeric
import Data.Char (isPrint)
import Data.Maybe
import Test.HUnit
import Text.Parsec
import Text.Megaparsec
import Text.Megaparsec.String
import Hledger.Utils.String (formatString)
@ -79,15 +80,15 @@ data ReportItemField =
-- | Parse a string format specification, or return a parse error.
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
Right x -> Right x
defaultStringFormatStyle = BottomAligned
stringformatp :: Stream [Char] m Char => ParsecT [Char] st m StringFormat
stringformatp :: Parser StringFormat
stringformatp = do
alignspec <- optionMaybe (try $ char '%' >> oneOf "^_,")
alignspec <- optional (try $ char '%' >> oneOf "^_,")
let constructor =
case alignspec of
Just '^' -> TopAligned
@ -96,24 +97,24 @@ stringformatp = do
_ -> defaultStringFormatStyle
constructor <$> many componentp
componentp :: Stream [Char] m Char => ParsecT [Char] st m StringFormatComponent
componentp :: Parser StringFormatComponent
componentp = formatliteralp <|> formatfieldp
formatliteralp :: Stream [Char] m Char => ParsecT [Char] st m StringFormatComponent
formatliteralp :: Parser StringFormatComponent
formatliteralp = do
s <- many1 c
s <- some c
return $ FormatLiteral s
where
isPrintableButNotPercentage x = isPrint x && (not $ x == '%')
c = (satisfy isPrintableButNotPercentage <?> "printable character")
<|> try (string "%%" >> return '%')
formatfieldp :: Stream [Char] m Char => ParsecT [Char] st m StringFormatComponent
formatfieldp :: Parser StringFormatComponent
formatfieldp = do
char '%'
leftJustified <- optionMaybe (char '-')
minWidth <- optionMaybe (many1 $ digit)
maxWidth <- optionMaybe (do char '.'; many1 $ digit) -- TODO: Can this be (char '1') *> (many1 digit)
leftJustified <- optional (char '-')
minWidth <- optional (some $ digitChar)
maxWidth <- optional (do char '.'; some $ digitChar) -- TODO: Can this be (char '1') *> (some digitChar)
char '('
f <- fieldp
char ')'
@ -123,14 +124,14 @@ formatfieldp = do
Just text -> Just m where ((m,_):_) = readDec text
_ -> Nothing
fieldp :: Stream [Char] m Char => ParsecT [Char] st m ReportItemField
fieldp :: Parser ReportItemField
fieldp = do
try (string "account" >> return AccountField)
<|> try (string "depth_spacer" >> return DepthSpacerField)
<|> try (string "date" >> return DescriptionField)
<|> try (string "description" >> return DescriptionField)
<|> try (string "total" >> return TotalField)
<|> try (many1 digit >>= (\s -> return $ FieldNo $ read s))
<|> try (some digitChar >>= (\s -> return $ FieldNo $ read s))
----------------------------------------------------------------------

View File

@ -5,7 +5,7 @@ transactions..) by various criteria, and a parser for query expressions.
-}
{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}
{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, ViewPatterns #-}
module Hledger.Query (
-- * Query and QueryOpt
@ -48,15 +48,16 @@ import Data.Data
import Data.Either
import Data.List
import Data.Maybe
import Data.Monoid ((<>))
-- import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Calendar
import Safe (readDef, headDef)
import Test.HUnit
-- import Text.ParserCombinators.Parsec
import Text.Parsec hiding (Empty)
import Text.Megaparsec
import Text.Megaparsec.Text
import Hledger.Utils
import Hledger.Utils hiding (words')
import Hledger.Data.Types
import Hledger.Data.AccountName
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
-- 2. multiple description patterns are OR'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)
where
terms = words'' prefixes s
@ -178,21 +179,27 @@ tests_parseQuery = [
-- | 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
-- 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
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
not' <- fromMaybe "" `fmap` (optionMaybe $ string "not:")
not' <- fromMaybe "" `fmap` (optional $ string "not:")
let allowednexts | null not' = prefixes
| otherwise = prefixes ++ [""]
next <- choice' $ map string allowednexts
let prefix = not' ++ next
next <- fmap T.pack $ choice' $ map (string . T.unpack) allowednexts
let prefix :: T.Text
prefix = T.pack not' <> next
p <- singleQuotedPattern <|> doubleQuotedPattern
return $ prefix ++ stripquotes p
singleQuotedPattern = between (char '\'') (char '\'') (many $ noneOf "'") >>= return . stripquotes
doubleQuotedPattern = between (char '"') (char '"') (many $ noneOf "\"") >>= return . stripquotes
pattern = many (noneOf " \n\r")
return $ prefix <> stripquotes p
singleQuotedPattern :: Parser T.Text
singleQuotedPattern = between (char '\'') (char '\'') (many $ noneOf ("'" :: [Char])) >>= return . stripquotes . T.pack
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'' = [
"words''" ~: do
@ -209,7 +216,8 @@ tests_words'' = [
-- XXX
-- keep synced with patterns below, excluding "not"
prefixes = map (++":") [
prefixes :: [T.Text]
prefixes = map (<>":") [
"inacctonly"
,"inacct"
,"amt"
@ -226,6 +234,7 @@ prefixes = map (++":") [
,"tag"
]
defaultprefix :: T.Text
defaultprefix = "acct"
-- -- | 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,
-- or raise an error if it has invalid syntax.
parseQueryTerm :: Day -> String -> Either Query QueryOpt
parseQueryTerm _ ('i':'n':'a':'c':'c':'t':'o':'n':'l':'y':':':s) = Right $ QueryOptInAcctOnly $ T.pack s
parseQueryTerm _ ('i':'n':'a':'c':'c':'t':':':s) = Right $ QueryOptInAcct $ T.pack s
parseQueryTerm d ('n':'o':'t':':':s) = case parseQueryTerm d s of
Left m -> Left $ Not m
Right _ -> Left Any -- not:somequeryoption will be ignored
parseQueryTerm _ ('c':'o':'d':'e':':':s) = Left $ Code s
parseQueryTerm _ ('d':'e':'s':'c':':':s) = Left $ Desc s
parseQueryTerm _ ('a':'c':'c':'t':':':s) = Left $ Acct s
parseQueryTerm d ('d':'a':'t':'e':'2':':':s) =
case parsePeriodExpr d s of Left e -> error' $ "\"date2:"++s++"\" gave a "++showDateParseError e
parseQueryTerm :: Day -> T.Text -> Either Query QueryOpt
parseQueryTerm _ (T.stripPrefix "inacctonly:" -> Just s) = Right $ QueryOptInAcctOnly s
parseQueryTerm _ (T.stripPrefix "inacct:" -> Just s) = Right $ QueryOptInAcct s
parseQueryTerm d (T.stripPrefix "not:" -> Just s) =
case parseQueryTerm d s of
Left m -> Left $ Not m
Right _ -> Left Any -- not:somequeryoption will be ignored
parseQueryTerm _ (T.stripPrefix "code:" -> Just s) = Left $ Code $ T.unpack s
parseQueryTerm _ (T.stripPrefix "desc:" -> Just s) = Left $ Desc $ T.unpack s
parseQueryTerm _ (T.stripPrefix "acct:" -> Just s) = Left $ Acct $ T.unpack s
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
parseQueryTerm d ('d':'a':'t':'e':':':s) =
case parsePeriodExpr d s of Left e -> error' $ "\"date:"++s++"\" gave a "++showDateParseError e
parseQueryTerm d (T.stripPrefix "date:" -> Just s) =
case parsePeriodExpr d s of Left e -> error' $ "\"date:"++T.unpack s++"\" gave a "++showDateParseError e
Right (_,span) -> Left $ Date span
parseQueryTerm _ ('s':'t':'a':'t':'u':'s':':':s) =
case parseStatus s of Left e -> error' $ "\"status:"++s++"\" gave a parse error: " ++ e
parseQueryTerm _ (T.stripPrefix "status:" -> Just s) =
case parseStatus s of Left e -> error' $ "\"status:"++T.unpack s++"\" gave a parse error: " ++ e
Right st -> Left $ Status st
parseQueryTerm _ ('r':'e':'a':'l':':':s) = Left $ Real $ parseBool s || null s
parseQueryTerm _ ('a':'m':'t':':':s) = Left $ Amt ord q where (ord, q) = parseAmountQueryTerm s
parseQueryTerm _ ('e':'m':'p':'t':'y':':':s) = Left $ Empty $ parseBool s
parseQueryTerm _ ('d':'e':'p':'t':'h':':':s)
parseQueryTerm _ (T.stripPrefix "real:" -> Just s) = Left $ Real $ parseBool s || T.null s
parseQueryTerm _ (T.stripPrefix "amt:" -> Just s) = Left $ Amt ord q where (ord, q) = parseAmountQueryTerm s
parseQueryTerm _ (T.stripPrefix "empty:" -> Just s) = Left $ Empty $ parseBool s
parseQueryTerm _ (T.stripPrefix "depth:" -> Just s)
| n >= 0 = Left $ Depth n
| 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':'a':'g':':':s) = Left $ Tag n v where (n,v) = parseTag s
parseQueryTerm _ (T.stripPrefix "cur:" -> Just s) = Left $ Sym (T.unpack s) -- support cur: as an alias
parseQueryTerm _ (T.stripPrefix "tag:" -> Just s) = Left $ Tag n v where (n,v) = parseTag s
parseQueryTerm _ "" = Left $ Any
parseQueryTerm d s = parseQueryTerm d $ defaultprefix++":"++s
parseQueryTerm d s = parseQueryTerm d $ defaultprefix<>":"<>s
tests_parseQueryTerm = [
"parseQueryTerm" ~: do
@ -298,35 +308,40 @@ data OrdPlus = Lt | LtEq | Gt | GtEq | Eq | AbsLt | AbsLtEq | AbsGt | AbsGtEq |
deriving (Show,Eq,Data,Typeable)
-- can fail
parseAmountQueryTerm :: String -> (OrdPlus, Quantity)
parseAmountQueryTerm :: T.Text -> (OrdPlus, Quantity)
parseAmountQueryTerm s' =
case s' of
-- feel free to do this a smarter way
"" -> err
'<':'+':s -> (Lt, readDef err s)
'<':'=':'+':s -> (LtEq, readDef err s)
'>':'+':s -> (Gt, readDef err s)
'>':'=':'+':s -> (GtEq, readDef err s)
'=':'+':s -> (Eq, readDef err s)
'+':s -> (Eq, readDef err s)
'<':'-':s -> (Lt, negate $ readDef err s)
'<':'=':'-':s -> (LtEq, negate $ readDef err s)
'>':'-':s -> (Gt, negate $ readDef err s)
'>':'=':'-':s -> (GtEq, negate $ readDef err s)
'=':'-':s -> (Eq, negate $ readDef err s)
'-':s -> (Eq, negate $ readDef err s)
'<':'=':s -> let n = readDef err s in case n of 0 -> (LtEq, 0)
_ -> (AbsLtEq, n)
'<':s -> let n = readDef err s in case n of 0 -> (Lt, 0)
_ -> (AbsLt, n)
'>':'=':s -> let n = readDef err s in case n of 0 -> (GtEq, 0)
_ -> (AbsGtEq, n)
'>':s -> let n = readDef err s in case n of 0 -> (Gt, 0)
_ -> (AbsGt, n)
'=':s -> (AbsEq, readDef err s)
s -> (AbsEq, readDef err s)
(T.stripPrefix "<+" -> Just s) -> (Lt, readDef err (T.unpack s))
(T.stripPrefix "<=+" -> Just s) -> (LtEq, readDef err (T.unpack s))
(T.stripPrefix ">+" -> Just s) -> (Gt, readDef err (T.unpack s))
(T.stripPrefix ">=+" -> Just s) -> (GtEq, readDef err (T.unpack s))
(T.stripPrefix "=+" -> Just s) -> (Eq, readDef err (T.unpack s))
(T.stripPrefix "+" -> Just s) -> (Eq, readDef err (T.unpack s))
(T.stripPrefix "<-" -> Just s) -> (Lt, negate $ readDef err (T.unpack s))
(T.stripPrefix "<=-" -> Just s) -> (LtEq, negate $ readDef err (T.unpack s))
(T.stripPrefix ">-" -> Just s) -> (Gt, negate $ readDef err (T.unpack s))
(T.stripPrefix ">=-" -> Just s) -> (GtEq, negate $ readDef err (T.unpack s))
(T.stripPrefix "=-" -> Just s) -> (Eq, negate $ readDef err (T.unpack s))
(T.stripPrefix "-" -> Just s) -> (Eq, negate $ readDef err (T.unpack s))
(T.stripPrefix "<=" -> Just s) -> let n = readDef err (T.unpack s) in
case n of
0 -> (LtEq, 0)
_ -> (AbsLtEq, n)
(T.stripPrefix "<" -> Just s) -> let n = readDef err (T.unpack s) in
case n of 0 -> (Lt, 0)
_ -> (AbsLt, n)
(T.stripPrefix ">=" -> Just s) -> let n = readDef err (T.unpack s) in
case n of 0 -> (GtEq, 0)
_ -> (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
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 = [
"parseAmountQueryTerm" ~: do
@ -340,13 +355,13 @@ tests_parseAmountQueryTerm = [
"-0.23" `gives` (Eq,(-0.23))
]
parseTag :: String -> (Regexp, Maybe Regexp)
parseTag s | '=' `elem` s = (n, Just $ tail v)
| otherwise = (s, Nothing)
where (n,v) = break (=='=') s
parseTag :: T.Text -> (Regexp, Maybe Regexp)
parseTag s | "=" `T.isInfixOf` s = (T.unpack n, Just $ tail $ T.unpack v)
| otherwise = (T.unpack s, Nothing)
where (n,v) = T.break (=='=') s
-- | 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
| s `elem` ["!"] = Right Pending
| 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,
-- anything else will be parsed as false without error.
parseBool :: String -> Bool
parseBool :: T.Text -> Bool
parseBool s = s `elem` truestrings
truestrings :: [String]
truestrings :: [T.Text]
truestrings = ["1"]
simplifyQuery :: Query -> Query

View File

@ -21,10 +21,12 @@ where
import Prelude ()
import Prelude.Compat hiding (readFile)
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.Functor.Identity
import Data.List.Compat
import Data.List.NonEmpty (NonEmpty(..))
import Data.List.Split (wordsBy)
import Data.Maybe
import Data.Monoid
@ -34,7 +36,8 @@ import Data.Time.Calendar
import Data.Time.LocalTime
import Safe
import System.Time (getClockTime)
import Text.Parsec hiding (parse)
import Text.Megaparsec hiding (parse,State)
import Text.Megaparsec.Text
import Hledger.Data
import Hledger.Utils
@ -43,40 +46,27 @@ import Hledger.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.
runStringParser, rsp :: StringParser () Identity a -> String -> Either ParseError a
runStringParser p s = runIdentity $ runParserT p () "" s
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
runTextParser, rtp :: TextParser Identity a -> Text -> Either (ParseError Char Dec) a
runTextParser p t = runParser p "" t
rtp = runTextParser
-- | Run a journal parser with a null journal-parsing state.
runJournalParser, rjp :: Monad m => JournalParser m a -> Text -> m (Either ParseError a)
runJournalParser p t = runParserT p mempty "" t
runJournalParser, rjp :: Monad m => TextParser m a -> Text -> m (Either (ParseError Char Dec) a)
runJournalParser p t = runParserT p "" t
rjp = runJournalParser
-- | Run an error-raising journal parser with a null journal-parsing state.
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
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,
-- 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
t <- liftIO getClockTime
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
Right pj -> case journalFinalise t f txt assrt pj of
Right j -> return j
Left e -> throwError e
Left e -> throwError $ show e
Left e -> throwError $ parseErrorPretty e
setYear :: Monad m => Integer -> JournalParser m ()
setYear y = modifyState (\j -> j{jparsedefaultyear=Just y})
parseAndFinaliseJournal' :: JournalParser ParsedJournal -> Bool -> FilePath -> Text -> ExceptT String IO Journal
parseAndFinaliseJournal' parser assrt f txt = do
t <- liftIO getClockTime
y <- liftIO getCurrentYear
let ep = runParser (evalStateT parser nulljournal {jparsedefaultyear=Just y}) f txt
case ep of
Right pj -> case journalFinalise t f txt assrt pj of
Right j -> return j
Left e -> throwError e
Left e -> throwError $ parseErrorPretty e
getYear :: Monad m => JournalParser m (Maybe Integer)
getYear = fmap jparsedefaultyear getState
setYear :: Monad m => Year -> JournalStateParser m ()
setYear y = modify' (\j -> j{jparsedefaultyear=Just y})
setDefaultCommodityAndStyle :: Monad m => (CommoditySymbol,AmountStyle) -> JournalParser m ()
setDefaultCommodityAndStyle cs = modifyState (\j -> j{jparsedefaultcommodity=Just cs})
getYear :: Monad m => JournalStateParser m (Maybe Year)
getYear = fmap jparsedefaultyear get
getDefaultCommodityAndStyle :: Monad m => JournalParser m (Maybe (CommoditySymbol,AmountStyle))
getDefaultCommodityAndStyle = jparsedefaultcommodity `fmap` getState
setDefaultCommodityAndStyle :: (CommoditySymbol,AmountStyle) -> ErroringJournalParser ()
setDefaultCommodityAndStyle cs = modify' (\j -> j{jparsedefaultcommodity=Just cs})
pushAccount :: Monad m => AccountName -> JournalParser m ()
pushAccount acct = modifyState (\j -> j{jaccounts = acct : jaccounts j})
getDefaultCommodityAndStyle :: Monad m => JournalStateParser m (Maybe (CommoditySymbol,AmountStyle))
getDefaultCommodityAndStyle = jparsedefaultcommodity `fmap` get
pushParentAccount :: Monad m => AccountName -> JournalParser m ()
pushParentAccount acct = modifyState (\j -> j{jparseparentaccounts = acct : jparseparentaccounts j})
pushAccount :: AccountName -> ErroringJournalParser ()
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
j <- getState
j <- get
case jparseparentaccounts j of
[] -> unexpected "End of apply account block with no beginning"
(_:rest) -> setState j{jparseparentaccounts=rest}
[] -> unexpected (Tokens ('E' :| "nd of apply account block with no beginning"))
(_:rest) -> put j{jparseparentaccounts=rest}
getParentAccount :: Monad m => JournalParser m AccountName
getParentAccount = fmap (concatAccountNames . reverse . jparseparentaccounts) getState
getParentAccount :: ErroringJournalParser AccountName
getParentAccount = fmap (concatAccountNames . reverse . jparseparentaccounts) get
addAccountAlias :: Monad m => AccountAlias -> JournalParser m ()
addAccountAlias a = modifyState (\(j@Journal{..}) -> j{jparsealiases=a:jparsealiases})
addAccountAlias :: MonadState Journal m => AccountAlias -> m ()
addAccountAlias a = modify' (\(j@Journal{..}) -> j{jparsealiases=a:jparsealiases})
getAccountAliases :: Monad m => JournalParser m [AccountAlias]
getAccountAliases = fmap jparsealiases getState
getAccountAliases :: MonadState Journal m => m [AccountAlias]
getAccountAliases = fmap jparsealiases get
clearAccountAliases :: Monad m => JournalParser m ()
clearAccountAliases = modifyState (\(j@Journal{..}) -> j{jparsealiases=[]})
clearAccountAliases :: MonadState Journal m => m ()
clearAccountAliases = modify' (\(j@Journal{..}) -> j{jparsealiases=[]})
getTransactionCount :: Monad m => JournalParser m Integer
getTransactionCount = fmap jparsetransactioncount getState
getTransactionCount :: MonadState Journal m => m Integer
getTransactionCount = fmap jparsetransactioncount get
setTransactionCount :: Monad m => Integer -> JournalParser m ()
setTransactionCount i = modifyState (\j -> j{jparsetransactioncount=i})
setTransactionCount :: MonadState Journal m => Integer -> m ()
setTransactionCount i = modify' (\j -> j{jparsetransactioncount=i})
-- | 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
modifyState (\j -> j{jparsetransactioncount=jparsetransactioncount j + 1})
modify' (\j -> j{jparsetransactioncount=jparsetransactioncount j + 1})
getTransactionCount
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
-- with the given parse position prepended.
parserErrorAt :: SourcePos -> String -> ErroringJournalParser a
parserErrorAt pos s = throwError $ show pos ++ ":\n" ++ s
parserErrorAt pos s = throwError $ sourcePosPretty pos ++ ":\n" ++ s
--- * parsers
--- ** transaction bits
statusp :: Monad m => JournalParser m ClearedStatus
statusp :: TextParser m ClearedStatus
statusp =
choice'
[ many spacenonewline >> char '*' >> return Cleared
@ -169,11 +170,11 @@ statusp =
]
<?> "cleared status"
codep :: Monad m => JournalParser m String
codep = try (do { many1 spacenonewline; char '(' <?> "codep"; anyChar `manyTill` char ')' } ) <|> return ""
codep :: TextParser m String
codep = try (do { some spacenonewline; char '(' <?> "codep"; anyChar `manyTill` char ')' } ) <|> return ""
descriptionp :: Monad m => JournalParser m String
descriptionp = many (noneOf ";\n")
descriptionp :: ErroringJournalParser String
descriptionp = many (noneOf (";\n" :: [Char]))
--- ** dates
@ -181,14 +182,14 @@ descriptionp = many (noneOf ";\n")
-- Hyphen (-) and period (.) are also allowed as separators.
-- The year may be omitted if a default year has been set.
-- Leading zeroes may be omitted.
datep :: Monad m => JournalParser m Day
datep :: Monad m => JournalStateParser m Day
datep = do
-- hacky: try to ensure precise errors for invalid dates
-- XXX reported error position is not too good
-- pos <- genericSourcePos <$> getPosition
datestr <- do
c <- digit
cs <- many $ choice' [digit, datesepchar]
c <- digitChar
cs <- lift $ many $ choice' [digitChar, datesepchar]
return $ c:cs
let sepchars = nub $ sort $ filter (`elem` datesepchars) datestr
when (length sepchars /= 1) $ fail $ "bad date, different separators used: " ++ datestr
@ -211,35 +212,35 @@ datep = do
-- Seconds are optional.
-- The timezone is optional and ignored (the time is always interpreted as a local time).
-- Leading zeroes may be omitted (except in a timezone).
datetimep :: Monad m => JournalParser m LocalTime
datetimep :: ErroringJournalParser LocalTime
datetimep = do
day <- datep
many1 spacenonewline
h <- many1 digit
lift $ some spacenonewline
h <- some digitChar
let h' = read h
guard $ h' >= 0 && h' <= 23
char ':'
m <- many1 digit
m <- some digitChar
let m' = read m
guard $ m' >= 0 && m' <= 59
s <- optionMaybe $ char ':' >> many1 digit
s <- optional $ char ':' >> some digitChar
let s' = case s of Just sstr -> read sstr
Nothing -> 0
guard $ s' >= 0 && s' <= 59
{- tz <- -}
optionMaybe $ do
plusminus <- oneOf "-+"
d1 <- digit
d2 <- digit
d3 <- digit
d4 <- digit
optional $ do
plusminus <- oneOf ("-+" :: [Char])
d1 <- digitChar
d2 <- digitChar
d3 <- digitChar
d4 <- digitChar
return $ plusminus:d1:d2:d3:d4:""
-- ltz <- liftIO $ getCurrentTimeZone
-- let tz' = maybe ltz (fromMaybe ltz . parseTime defaultTimeLocale "%z") tz
-- return $ localTimeToUTC tz' $ LocalTime day $ TimeOfDay h' m' (fromIntegral s')
return $ LocalTime day $ TimeOfDay h' m' (fromIntegral s')
secondarydatep :: Monad m => Day -> JournalParser m Day
secondarydatep :: Day -> ErroringJournalParser Day
secondarydatep primarydate = do
char '='
-- kludgy way to use primary date for default year
@ -256,20 +257,20 @@ secondarydatep primarydate = do
-- >> parsewith twoorthreepartdatestringp "2016/01/2"
-- Right "2016/01/2"
-- twoorthreepartdatestringp = do
-- n1 <- many1 digit
-- n1 <- some digitChar
-- c <- datesepchar
-- n2 <- many1 digit
-- mn3 <- optionMaybe $ char c >> many1 digit
-- n2 <- some digitChar
-- mn3 <- optional $ char c >> some digitChar
-- return $ n1 ++ c:n2 ++ maybe "" (c:) mn3
--- ** account names
-- | 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
parent <- getParentAccount
aliases <- getAccountAliases
a <- accountnamep
a <- lift accountnamep
return $
accountNameApplyAliases aliases $
-- 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
-- at least one character, separated by the account separator char.
-- (This parser will also consume one following space, if present.)
accountnamep :: Monad m => TextParser u m AccountName
accountnamep :: TextParser m AccountName
accountnamep = do
astr <- do
c <- nonspace
@ -304,10 +305,10 @@ accountnamep = do
-- | Parse whitespace then an amount, with an optional left or right
-- currency symbol and optional price, or return the special
-- "missing" marker amount.
spaceandamountormissingp :: Monad m => JournalParser m MixedAmount
spaceandamountormissingp :: ErroringJournalParser MixedAmount
spaceandamountormissingp =
try (do
many1 spacenonewline
lift $ some spacenonewline
(Mixed . (:[])) `fmap` amountp <|> return missingmixedamt
) <|> return missingmixedamt
@ -328,7 +329,7 @@ test_spaceandamountormissingp = do
-- | Parse a single-commodity amount, with optional symbol on the left or
-- right, optional unit or total price, and optional (ignored)
-- 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
#ifdef TESTS
@ -348,7 +349,7 @@ test_amountp = do
-- | Parse an amount from a string, or get an error.
amountp' :: String -> Amount
amountp' s =
case runParser (amountp <* eof) mempty "" (T.pack s) of
case runParser (evalStateT (amountp <* eof) mempty) "" (T.pack s) of
Right amt -> amt
Left err -> error' $ show err -- XXX should throwError
@ -356,37 +357,37 @@ amountp' s =
mamountp' :: String -> MixedAmount
mamountp' = Mixed . (:[]) . amountp'
signp :: Monad m => JournalParser m String
signp :: TextParser m String
signp = do
sign <- optionMaybe $ oneOf "+-"
sign <- optional $ oneOf ("+-" :: [Char])
return $ case sign of Just '-' -> "-"
_ -> ""
leftsymbolamountp :: Monad m => JournalParser m Amount
leftsymbolamountp :: Monad m => JournalStateParser m Amount
leftsymbolamountp = do
sign <- signp
c <- commoditysymbolp
sp <- many spacenonewline
(q,prec,mdec,mgrps) <- numberp
sign <- lift signp
c <- lift commoditysymbolp
sp <- lift $ many spacenonewline
(q,prec,mdec,mgrps) <- lift numberp
let s = amountstyle{ascommodityside=L, ascommodityspaced=not $ null sp, asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps}
p <- priceamountp
let applysign = if sign=="-" then negate else id
return $ applysign $ Amount c q p s
<?> "left-symbol amount"
rightsymbolamountp :: Monad m => JournalParser m Amount
rightsymbolamountp :: Monad m => JournalStateParser m Amount
rightsymbolamountp = do
(q,prec,mdec,mgrps) <- numberp
sp <- many spacenonewline
c <- commoditysymbolp
(q,prec,mdec,mgrps) <- lift numberp
sp <- lift $ many spacenonewline
c <- lift commoditysymbolp
p <- priceamountp
let s = amountstyle{ascommodityside=R, ascommodityspaced=not $ null sp, asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps}
return $ Amount c q p s
<?> "right-symbol amount"
nosymbolamountp :: Monad m => JournalParser m Amount
nosymbolamountp :: Monad m => JournalStateParser m Amount
nosymbolamountp = do
(q,prec,mdec,mgrps) <- numberp
(q,prec,mdec,mgrps) <- lift numberp
p <- priceamountp
-- apply the most recently seen default commodity and style to this commodityless amount
defcs <- getDefaultCommodityAndStyle
@ -396,66 +397,66 @@ nosymbolamountp = do
return $ Amount c q p s
<?> "no-symbol amount"
commoditysymbolp :: Monad m => JournalParser m CommoditySymbol
commoditysymbolp :: TextParser m CommoditySymbol
commoditysymbolp = (quotedcommoditysymbolp <|> simplecommoditysymbolp) <?> "commodity symbol"
quotedcommoditysymbolp :: Monad m => JournalParser m CommoditySymbol
quotedcommoditysymbolp :: TextParser m CommoditySymbol
quotedcommoditysymbolp = do
char '"'
s <- many1 $ noneOf ";\n\""
s <- some $ noneOf (";\n\"" :: [Char])
char '"'
return $ T.pack s
simplecommoditysymbolp :: Monad m => JournalParser m CommoditySymbol
simplecommoditysymbolp = T.pack <$> many1 (noneOf nonsimplecommoditychars)
simplecommoditysymbolp :: TextParser m CommoditySymbol
simplecommoditysymbolp = T.pack <$> some (noneOf nonsimplecommoditychars)
priceamountp :: Monad m => JournalParser m Price
priceamountp :: Monad m => JournalStateParser m Price
priceamountp =
try (do
many spacenonewline
lift (many spacenonewline)
char '@'
try (do
char '@'
many spacenonewline
lift (many spacenonewline)
a <- amountp -- XXX can parse more prices ad infinitum, shouldn't
return $ TotalPrice a)
<|> (do
many spacenonewline
lift (many spacenonewline)
a <- amountp -- XXX can parse more prices ad infinitum, shouldn't
return $ UnitPrice a))
<|> return NoPrice
partialbalanceassertionp :: Monad m => JournalParser m (Maybe MixedAmount)
partialbalanceassertionp :: ErroringJournalParser (Maybe MixedAmount)
partialbalanceassertionp =
try (do
many spacenonewline
lift (many spacenonewline)
char '='
many spacenonewline
lift (many spacenonewline)
a <- amountp -- XXX should restrict to a simple amount
return $ Just $ Mixed [a])
<|> return Nothing
-- balanceassertion :: Monad m => JournalParser m (Maybe MixedAmount)
-- balanceassertion :: Monad m => TextParser m (Maybe MixedAmount)
-- balanceassertion =
-- try (do
-- many spacenonewline
-- lift (many spacenonewline)
-- string "=="
-- many spacenonewline
-- lift (many spacenonewline)
-- a <- amountp -- XXX should restrict to a simple amount
-- return $ Just $ Mixed [a])
-- <|> return Nothing
-- http://ledger-cli.org/3.0/doc/ledger3.html#Fixing-Lot-Prices
fixedlotpricep :: Monad m => JournalParser m (Maybe Amount)
fixedlotpricep :: ErroringJournalParser (Maybe Amount)
fixedlotpricep =
try (do
many spacenonewline
lift (many spacenonewline)
char '{'
many spacenonewline
lift (many spacenonewline)
char '='
many spacenonewline
lift (many spacenonewline)
a <- amountp -- XXX should restrict to a simple amount
many spacenonewline
lift (many spacenonewline)
char '}'
return $ Just a)
<|> return Nothing
@ -472,13 +473,13 @@ fixedlotpricep =
-- seen following the decimal point), the decimal point character used 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
-- a number is an optional sign followed by a sequence of digits possibly
-- interspersed with periods, commas, or both
-- ptrace "numberp"
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 ()
-- check the number is well-formed and identify the decimal point and digit
@ -546,26 +547,26 @@ numberp = do
--- ** comments
multilinecommentp :: Monad m => JournalParser m ()
multilinecommentp :: ErroringJournalParser ()
multilinecommentp = do
string "comment" >> many spacenonewline >> newline
string "comment" >> lift (many spacenonewline) >> newline
go
where
go = try (eof <|> (string "end comment" >> newline >> return ()))
<|> (anyLine >> go)
anyLine = anyChar `manyTill` newline
emptyorcommentlinep :: Monad m => JournalParser m ()
emptyorcommentlinep :: ErroringJournalParser ()
emptyorcommentlinep = do
many spacenonewline >> (commentp <|> (many spacenonewline >> newline >> return ""))
lift (many spacenonewline) >> (commentp <|> (lift (many spacenonewline) >> newline >> return ""))
return ()
-- | Parse a possibly multi-line comment following a semicolon.
followingcommentp :: Monad m => JournalParser m Text
followingcommentp :: ErroringJournalParser Text
followingcommentp =
-- ptrace "followingcommentp"
do samelinecomment <- many spacenonewline >> (try semicoloncommentp <|> (newline >> return ""))
newlinecomments <- many (try (many1 spacenonewline >> semicoloncommentp))
do samelinecomment <- lift (many spacenonewline) >> (try semicoloncommentp <|> (newline >> return ""))
newlinecomments <- many (try (lift (some spacenonewline) >> semicoloncommentp))
return $ T.unlines $ samelinecomment:newlinecomments
-- | 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:
-- >>> 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:
-- the syntaxes ? We'll accept the leading date anyway
@ -597,9 +598,9 @@ followingcommentandtagsp mdefdate = do
startpos <- getPosition
commentandwhitespace :: String <- do
let semicoloncommentp' = (:) <$> char ';' <*> anyChar `manyTill` eolof
sp1 <- many spacenonewline
l1 <- try semicoloncommentp' <|> (newline >> return "")
ls <- many $ try ((++) <$> many1 spacenonewline <*> semicoloncommentp')
sp1 <- lift (many spacenonewline)
l1 <- try (lift semicoloncommentp') <|> (newline >> return "")
ls <- lift . many $ try ((++) <$> some spacenonewline <*> semicoloncommentp')
return $ unlines $ (sp1 ++ l1) : ls
let comment = T.pack $ unlines $ map (lstrip . dropWhile (==';') . strip) $ lines commentandwhitespace
-- pdbg 0 $ "commentws:"++show commentandwhitespace
@ -608,7 +609,7 @@ followingcommentandtagsp mdefdate = do
-- Reparse the comment for any tags.
tags <- case runTextParser (setPosition startpos >> tagsp) $ T.pack commentandwhitespace of
Right ts -> return ts
Left e -> throwError $ show e
Left e -> throwError $ parseErrorPretty e
-- pdbg 0 $ "tags: "++show tags
-- 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)
commentp :: Monad m => JournalParser m Text
commentp :: ErroringJournalParser Text
commentp = commentStartingWithp commentchars
commentchars :: [Char]
commentchars = "#;*"
semicoloncommentp :: Monad m => JournalParser m Text
semicoloncommentp :: ErroringJournalParser Text
semicoloncommentp = commentStartingWithp ";"
commentStartingWithp :: Monad m => [Char] -> JournalParser m Text
commentStartingWithp :: [Char] -> ErroringJournalParser Text
commentStartingWithp cs = do
-- ptrace "commentStartingWith"
oneOf cs
many spacenonewline
l <- anyChar `manyTill` eolof
lift (many spacenonewline)
l <- anyChar `manyTill` (lift eolof)
optional newline
return $ T.pack l
@ -662,7 +663,7 @@ commentTags s =
Left _ -> [] -- shouldn't happen
-- | Parse all tags found in a string.
tagsp :: TextParser u Identity [Tag]
tagsp :: Parser [Tag]
tagsp = -- do
-- pdbg 0 $ "tagsp"
many (try (nontagp >> tagp))
@ -671,7 +672,7 @@ tagsp = -- do
--
-- >>> rtp nontagp "\na b:, \nd:e, f"
-- Right "\na "
nontagp :: TextParser u Identity String
nontagp :: Parser String
nontagp = -- do
-- pdbg 0 "nontagp"
-- anyChar `manyTill` (lookAhead (try (tagorbracketeddatetagsp Nothing >> return ()) <|> eof))
@ -685,7 +686,7 @@ nontagp = -- do
-- >>> rtp tagp "a:b b , c AuxDate: 4/2"
-- Right ("a","b b")
--
tagp :: Monad m => TextParser u m Tag
tagp :: Parser Tag
tagp = do
-- pdbg 0 "tagp"
n <- tagnamep
@ -695,12 +696,12 @@ tagp = do
-- |
-- >>> rtp tagnamep "a:"
-- Right "a"
tagnamep :: Monad m => TextParser u m Text
tagnamep :: Parser Text
tagnamep = -- do
-- 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
-- ptrace "tagvalue"
v <- anyChar `manyTill` (void (try (char ',')) <|> eolof)
@ -736,29 +737,30 @@ postingdatesp mdefdate = do
-- Right ("date2",2001-03-04)
--
-- >>> 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 mdefdate = do
-- pdbg 0 "datetagp"
string "date"
n <- T.pack . fromMaybe "" <$> optionMaybe (string "2")
n <- T.pack . fromMaybe "" <$> optional (string "2")
char ':'
startpos <- getPosition
v <- tagvaluep
v <- lift tagvaluep
-- re-parse value as a date.
j <- getState
ep <- parseWithState
j{jparsedefaultyear=first3.toGregorian <$> mdefdate}
-- The value extends to a comma, newline, or end of file.
-- It seems like ignoring any extra stuff following a date
-- gives better errors here.
(do
setPosition startpos
datep) -- <* eof)
v
j <- get
let ep :: Either (ParseError Char Dec) Day
ep = parseWithState'
j{jparsedefaultyear=first3.toGregorian <$> mdefdate}
-- The value extends to a comma, newline, or end of file.
-- It seems like ignoring any extra stuff following a date
-- gives better errors here.
(do
setPosition startpos
datep) -- <* eof)
v
case ep
of Left e -> throwError $ show e
of Left e -> throwError $ parseErrorPretty e
Right d -> return ("date"<>n, d)
--- ** bracketed dates
@ -785,13 +787,13 @@ datetagp mdefdate = do
-- Left ...not a bracketed date...
--
-- >>> 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]"
-- 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/-.=/-.=]"
-- Left ...line 1, column 15...bad date, different separators...
-- Left ...1:15:...bad date, different separators...
--
bracketeddatetagsp :: Maybe Day -> ErroringJournalParser [(TagName, Day)]
bracketeddatetagsp mdefdate = do
@ -799,27 +801,28 @@ bracketeddatetagsp mdefdate = do
char '['
startpos <- getPosition
let digits = "0123456789"
s <- many1 (oneOf $ '=':digits++datesepchars)
s <- some (oneOf $ '=':digits++datesepchars)
char ']'
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
-- re-parse as dates and throw any errors
j <- getState
ep <- parseWithState
j{jparsedefaultyear=first3.toGregorian <$> mdefdate}
(do
setPosition startpos
md1 <- optionMaybe datep
maybe (return ()) (setYear.first3.toGregorian) md1
md2 <- optionMaybe $ char '=' >> datep
eof
return (md1,md2)
)
(T.pack s)
j <- get
let ep :: Either (ParseError Char Dec) (Maybe Day, Maybe Day)
ep = parseWithState'
j{jparsedefaultyear=first3.toGregorian <$> mdefdate}
(do
setPosition startpos
md1 <- optional datep
maybe (return ()) (setYear.first3.toGregorian) md1
md2 <- optional $ char '=' >> datep
eof
return (md1,md2)
)
(T.pack s)
case ep
of Left e -> throwError $ show e
of Left e -> throwError $ parseErrorPretty e
Right (md1,md2) -> return $ catMaybes
[("date",) <$> md1, ("date2",) <$> md2]

View File

@ -6,6 +6,9 @@ A reader for CSV data, using an extra rules file to help interpret the data.
-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module Hledger.Read.CsvReader (
-- * Reader
@ -25,11 +28,13 @@ import Prelude.Compat hiding (getContents)
import Control.Exception hiding (try)
import Control.Monad
import Control.Monad.Except
import Control.Monad.State.Strict (StateT, State, get, modify', evalStateT)
-- import Test.HUnit
import Data.Char (toLower, isDigit, isSpace)
import Data.List.Compat
import Data.Maybe
import Data.Ord
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Calendar (Day)
@ -43,11 +48,11 @@ import Safe
import System.Directory (doesFileExist)
import System.FilePath
import System.IO (stderr)
import Test.HUnit
import Test.HUnit hiding (State)
import Text.CSV (parseCSV, CSV)
import Text.Parsec hiding (parse)
import Text.Parsec.Pos
import Text.Parsec.Error
import Text.Megaparsec hiding (parse, State)
import Text.Megaparsec.Text
import qualified Text.Parsec as Parsec
import Text.Printf (hPrintf,printf)
import Hledger.Data
@ -126,7 +131,12 @@ readJournalFromCsv mrulesfile csvfile csvdata =
-- convert to transactions and return as a journal
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
-- heuristic: if the records appear to have been in reverse date order,
@ -136,14 +146,14 @@ readJournalFromCsv mrulesfile csvfile csvdata =
| otherwise = 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 =
case path of
"-" -> liftM (parseCSV "(stdin)") getContents
_ -> return $ parseCSV path csvdata
-- | 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 numhdrlines (Right rs) = validate $ drop numhdrlines $ filternulls rs
where
@ -298,6 +308,8 @@ data CsvRules = CsvRules {
rconditionalblocks :: [ConditionalBlock]
} deriving (Show, Eq)
type CsvRulesParser a = StateT CsvRules Parser a
type DirectiveName = String
type CsvFieldName = String
type CsvFieldIndex = Int
@ -354,26 +366,27 @@ parseRulesFile f = do
Left e -> return $ Left $ show $ toParseError e
Right r -> return $ Right r
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.
-- 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
let (ls,rest) = break (isPrefixOf "include") $ lines content
let (ls,rest) = break (T.isPrefixOf "include") $ T.lines content
case rest of
[] -> return $ unlines ls
(('i':'n':'c':'l':'u':'d':'e':f):ls') -> do
let f' = basedir </> dropWhile isSpace f
[] -> return $ T.unlines ls
((T.stripPrefix "include" -> Just f):ls') -> do
let f' = basedir </> dropWhile isSpace (T.unpack f)
basedir' = takeDirectory f'
included <- readFile f' >>= expandIncludes basedir'
return $ unlines [unlines ls, included, unlines ls']
ls' -> return $ unlines $ ls ++ ls' -- should never get here
included <- readFile' f' >>= expandIncludes basedir'
return $ T.unlines [T.unlines ls, included, T.unlines ls']
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 rulesp rules rulesfile s
runParser (evalStateT rulesp rules) rulesfile s
-- | Return the validated rules, or an error.
validateRules :: CsvRules -> ExceptT String IO CsvRules
@ -391,40 +404,40 @@ validateRules rules = do
-- parsers
rulesp :: Stream [Char] m t => ParsecT [Char] CsvRules m CsvRules
rulesp :: CsvRulesParser CsvRules
rulesp = do
many $ choice'
[blankorcommentlinep <?> "blank or comment line"
,(directivep >>= modifyState . addDirective) <?> "directive"
,(fieldnamelistp >>= modifyState . setIndexesAndAssignmentsFromList) <?> "field name list"
,(fieldassignmentp >>= modifyState . addAssignment) <?> "field assignment"
,(conditionalblockp >>= modifyState . addConditionalBlock) <?> "conditional block"
many $ choiceInState
[blankorcommentlinep <?> "blank or comment line"
,(directivep >>= modify' . addDirective) <?> "directive"
,(fieldnamelistp >>= modify' . setIndexesAndAssignmentsFromList) <?> "field name list"
,(fieldassignmentp >>= modify' . addAssignment) <?> "field assignment"
,(conditionalblockp >>= modify' . addConditionalBlock) <?> "conditional block"
]
eof
r <- getState
r <- get
return r{rdirectives=reverse $ rdirectives r
,rassignments=reverse $ rassignments r
,rconditionalblocks=reverse $ rconditionalblocks r
}
blankorcommentlinep :: Stream [Char] m t => ParsecT [Char] CsvRules m ()
blankorcommentlinep = pdbg 3 "trying blankorcommentlinep" >> choice' [blanklinep, commentlinep]
blankorcommentlinep :: CsvRulesParser ()
blankorcommentlinep = lift (pdbg 3 "trying blankorcommentlinep") >> choiceInState [blanklinep, commentlinep]
blanklinep :: Stream [Char] m t => ParsecT [Char] CsvRules m ()
blanklinep = many spacenonewline >> newline >> return () <?> "blank line"
blanklinep :: CsvRulesParser ()
blanklinep = lift (many spacenonewline) >> newline >> return () <?> "blank line"
commentlinep :: Stream [Char] m t => ParsecT [Char] CsvRules m ()
commentlinep = many spacenonewline >> commentcharp >> restofline >> return () <?> "comment line"
commentlinep :: CsvRulesParser ()
commentlinep = lift (many spacenonewline) >> commentcharp >> lift restofline >> return () <?> "comment line"
commentcharp :: Stream [Char] m t => ParsecT [Char] CsvRules m Char
commentcharp = oneOf ";#*"
commentcharp :: CsvRulesParser Char
commentcharp = oneOf (";#*" :: [Char])
directivep :: Stream [Char] m t => ParsecT [Char] CsvRules m (DirectiveName, String)
directivep :: CsvRulesParser (DirectiveName, String)
directivep = (do
pdbg 3 "trying directive"
d <- choice' $ map string directives
v <- (((char ':' >> many spacenonewline) <|> many1 spacenonewline) >> directivevalp)
<|> (optional (char ':') >> many spacenonewline >> eolof >> return "")
lift $ pdbg 3 "trying directive"
d <- choiceInState $ map string directives
v <- (((char ':' >> lift (many spacenonewline)) <|> lift (some spacenonewline)) >> directivevalp)
<|> (optional (char ':') >> lift (many spacenonewline) >> lift eolof >> return "")
return (d,v)
) <?> "directive"
@ -438,46 +451,46 @@ directives =
-- ,"base-currency"
]
directivevalp :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]
directivevalp = anyChar `manyTill` eolof
directivevalp :: CsvRulesParser String
directivevalp = anyChar `manyTill` lift eolof
fieldnamelistp :: Stream [Char] m t => ParsecT [Char] CsvRules m [CsvFieldName]
fieldnamelistp :: CsvRulesParser [CsvFieldName]
fieldnamelistp = (do
pdbg 3 "trying fieldnamelist"
lift $ pdbg 3 "trying fieldnamelist"
string "fields"
optional $ char ':'
many1 spacenonewline
let separator = many spacenonewline >> char ',' >> many spacenonewline
f <- fromMaybe "" <$> optionMaybe fieldnamep
fs <- many1 $ (separator >> fromMaybe "" <$> optionMaybe fieldnamep)
restofline
lift (some spacenonewline)
let separator = lift (many spacenonewline) >> char ',' >> lift (many spacenonewline)
f <- fromMaybe "" <$> optional fieldnamep
fs <- some $ (separator >> fromMaybe "" <$> optional fieldnamep)
lift restofline
return $ map (map toLower) $ f:fs
) <?> "field name list"
fieldnamep :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]
fieldnamep :: CsvRulesParser String
fieldnamep = quotedfieldnamep <|> barefieldnamep
quotedfieldnamep :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]
quotedfieldnamep :: CsvRulesParser String
quotedfieldnamep = do
char '"'
f <- many1 $ noneOf "\"\n:;#~"
f <- some $ noneOf ("\"\n:;#~" :: [Char])
char '"'
return f
barefieldnamep :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]
barefieldnamep = many1 $ noneOf " \t\n,;#~"
barefieldnamep :: CsvRulesParser String
barefieldnamep = some $ noneOf (" \t\n,;#~" :: [Char])
fieldassignmentp :: Stream [Char] m t => ParsecT [Char] CsvRules m (JournalFieldName, FieldTemplate)
fieldassignmentp :: CsvRulesParser (JournalFieldName, FieldTemplate)
fieldassignmentp = do
pdbg 3 "trying fieldassignment"
lift $ pdbg 3 "trying fieldassignmentp"
f <- journalfieldnamep
assignmentseparatorp
v <- fieldvalp
return (f,v)
<?> "field assignment"
journalfieldnamep :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]
journalfieldnamep = pdbg 2 "trying journalfieldnamep" >> choice' (map string journalfieldnames)
journalfieldnamep :: CsvRulesParser String
journalfieldnamep = lift (pdbg 2 "trying journalfieldnamep") >> choiceInState (map string journalfieldnames)
journalfieldnames =
[-- pseudo fields:
@ -496,74 +509,74 @@ journalfieldnames =
,"comment"
]
assignmentseparatorp :: Stream [Char] m t => ParsecT [Char] CsvRules m ()
assignmentseparatorp :: CsvRulesParser ()
assignmentseparatorp = do
pdbg 3 "trying assignmentseparatorp"
lift $ pdbg 3 "trying assignmentseparatorp"
choice [
-- try (many spacenonewline >> oneOf ":="),
try (many spacenonewline >> char ':'),
-- try (lift (many spacenonewline) >> oneOf ":="),
try (void $ lift (many spacenonewline) >> char ':'),
space
]
_ <- many spacenonewline
_ <- lift (many spacenonewline)
return ()
fieldvalp :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]
fieldvalp :: CsvRulesParser String
fieldvalp = do
pdbg 2 "trying fieldval"
anyChar `manyTill` eolof
lift $ pdbg 2 "trying fieldvalp"
anyChar `manyTill` lift eolof
conditionalblockp :: Stream [Char] m t => ParsecT [Char] CsvRules m ConditionalBlock
conditionalblockp :: CsvRulesParser ConditionalBlock
conditionalblockp = do
pdbg 3 "trying conditionalblockp"
string "if" >> many spacenonewline >> optional newline
ms <- many1 recordmatcherp
as <- many (many1 spacenonewline >> fieldassignmentp)
lift $ pdbg 3 "trying conditionalblockp"
string "if" >> lift (many spacenonewline) >> optional newline
ms <- some recordmatcherp
as <- many (lift (some spacenonewline) >> fieldassignmentp)
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"
return (ms, as)
<?> "conditional block"
recordmatcherp :: Stream [Char] m t => ParsecT [Char] CsvRules m [[Char]]
recordmatcherp :: CsvRulesParser [String]
recordmatcherp = do
pdbg 2 "trying recordmatcherp"
lift $ pdbg 2 "trying recordmatcherp"
-- pos <- currentPos
_ <- optional (matchoperatorp >> many spacenonewline >> optional newline)
_ <- optional (matchoperatorp >> lift (many spacenonewline) >> optional newline)
ps <- patternsp
when (null ps) $
fail "start of record matcher found, but no patterns afterward\n(patterns should not be indented)\n"
return ps
<?> "record matcher"
matchoperatorp :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]
matchoperatorp = choice' $ map string
matchoperatorp :: CsvRulesParser String
matchoperatorp = choiceInState $ map string
["~"
-- ,"!~"
-- ,"="
-- ,"!="
]
patternsp :: Stream [Char] m t => ParsecT [Char] CsvRules m [[Char]]
patternsp :: CsvRulesParser [String]
patternsp = do
pdbg 3 "trying patternsp"
lift $ pdbg 3 "trying patternsp"
ps <- many regexp
return ps
regexp :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char]
regexp :: CsvRulesParser String
regexp = do
pdbg 3 "trying regexp"
lift $ pdbg 3 "trying regexp"
notFollowedBy matchoperatorp
c <- nonspace
cs <- anyChar `manyTill` eolof
c <- lift nonspace
cs <- anyChar `manyTill` lift eolof
return $ strip $ c:cs
-- fieldmatcher = do
-- pdbg 2 "trying fieldmatcher"
-- f <- fromMaybe "all" `fmap` (optionMaybe $ do
-- f <- fromMaybe "all" `fmap` (optional $ do
-- f' <- fieldname
-- many spacenonewline
-- lift (many spacenonewline)
-- return f')
-- char '~'
-- many spacenonewline
-- lift (many spacenonewline)
-- ps <- patterns
-- let r = "(" ++ intercalate "|" ps ++ ")"
-- return (f,r)
@ -607,7 +620,9 @@ transactionFromCsvRecord sourcepos rules record = t
status =
case mfieldtemplate "status" of
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
statuserror err = error' $ unlines
["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"
currency = maybe (fromMaybe "" mdefaultcurrency) render $ mfieldtemplate "currency"
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
["error: could not parse \""++amountstr++"\" as an amount"
,showRecord record
@ -786,10 +801,10 @@ test_parser = [
-- ([("A",Nothing)], "a")
,"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
assertParse (parseWithState rules rulesp "skip\n\n \n")
assertParse (parseWithState' rules rulesp "skip\n\n \n")
-- not supported
-- ,"convert rules parsing: no final newline" ~: do

View File

@ -40,8 +40,6 @@ module Hledger.Read.JournalReader (
-- * Parsing utils
genericSourcePos,
parseAndFinaliseJournal,
runStringParser,
rsp,
runJournalParser,
rjp,
runErroringJournalParser,
@ -78,7 +76,8 @@ import Prelude ()
import Prelude.Compat hiding (readFile)
import qualified Control.Exception as C
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 Data.Monoid
import Data.Text (Text)
@ -89,9 +88,9 @@ import Safe
import Test.HUnit
#ifdef TESTS
import Test.Framework
import Text.Parsec.Error
import Text.Megaparsec.Error
#endif
import Text.Parsec hiding (parse)
import Text.Megaparsec hiding (parse)
import Text.Printf
import System.FilePath
@ -137,7 +136,7 @@ journalp :: ErroringJournalParser ParsedJournal
journalp = do
many addJournalItemP
eof
getState
get
-- | A side-effecting parser; parses any kind of journal item
-- and updates the parse state accordingly.
@ -147,10 +146,10 @@ addJournalItemP =
-- character, can use choice without backtracking
choice [
directivep
, transactionp >>= modifyState . addTransaction
, modifiertransactionp >>= modifyState . addModifierTransaction
, periodictransactionp >>= modifyState . addPeriodicTransaction
, marketpricedirectivep >>= modifyState . addMarketPrice
, transactionp >>= modify' . addTransaction
, modifiertransactionp >>= modify' . addModifierTransaction
, periodictransactionp >>= modify' . addPeriodicTransaction
, marketpricedirectivep >>= modify' . addMarketPrice
, void emptyorcommentlinep
, void multilinecommentp
] <?> "transaction or directive"
@ -163,7 +162,7 @@ addJournalItemP =
directivep :: ErroringJournalParser ()
directivep = (do
optional $ char '!'
choice' [
choiceInState [
includedirectivep
,aliasdirectivep
,endaliasesdirectivep
@ -183,24 +182,27 @@ directivep = (do
includedirectivep :: ErroringJournalParser ()
includedirectivep = do
string "include"
many1 spacenonewline
filename <- restofline
lift (some spacenonewline)
filename <- lift restofline
parentpos <- getPosition
parentj <- getState
parentj <- get
let childj = newJournalWithParseStateFrom parentj
(ej :: Either String ParsedJournal) <-
liftIO $ runExceptT $ do
let curdir = takeDirectory (sourceName parentpos)
filepath <- expandPath curdir filename `orRethrowIOError` (show parentpos ++ " locating " ++ filename)
txt <- readFileAnyLineEnding filepath `orRethrowIOError` (show parentpos ++ " reading " ++ filepath)
(ej1::Either ParseError ParsedJournal) <-
runParserT
(choice' [journalp
,timeclockfilep
,timedotfilep
-- can't include a csv file yet, that reader is special
])
childj filepath txt
(ej1::Either (ParseError Char Dec) ParsedJournal) <-
runParserT
(evalStateT
(choiceInState
[journalp
,timeclockfilep
,timedotfilep
-- can't include a csv file yet, that reader is special
])
childj)
filepath txt
either
(throwError
. ((show parentpos ++ " in included file " ++ show filename ++ ":\n") ++)
@ -209,7 +211,7 @@ includedirectivep = do
ej1
case ej of
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
newJournalWithParseStateFrom :: Journal -> Journal
@ -233,13 +235,13 @@ orRethrowIOError io msg =
accountdirectivep :: ErroringJournalParser ()
accountdirectivep = do
string "account"
many1 spacenonewline
acct <- accountnamep
lift (some spacenonewline)
acct <- lift accountnamep
newline
_ <- 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.
--
@ -257,12 +259,12 @@ commoditydirectivep = try commoditydirectiveonelinep <|> commoditydirectivemulti
commoditydirectiveonelinep :: ErroringJournalParser ()
commoditydirectiveonelinep = do
string "commodity"
many1 spacenonewline
lift (some spacenonewline)
Amount{acommodity,astyle} <- amountp
many spacenonewline
_ <- followingcommentp <|> (eolof >> return "")
lift (many spacenonewline)
_ <- followingcommentp <|> (lift eolof >> return "")
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.
--
@ -270,24 +272,24 @@ commoditydirectiveonelinep = do
commoditydirectivemultilinep :: ErroringJournalParser ()
commoditydirectivemultilinep = do
string "commodity"
many1 spacenonewline
sym <- commoditysymbolp
_ <- followingcommentp <|> (eolof >> return "")
lift (some spacenonewline)
sym <- lift commoditysymbolp
_ <- followingcommentp <|> (lift eolof >> return "")
mformat <- lastMay <$> many (indented $ formatdirectivep sym)
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
indented = (many1 spacenonewline >>)
indented = (lift (some spacenonewline) >>)
-- | Parse a format (sub)directive, throwing a parse error if its
-- symbol does not match the one given.
formatdirectivep :: CommoditySymbol -> ErroringJournalParser AmountStyle
formatdirectivep expectedsym = do
string "format"
many1 spacenonewline
lift (some spacenonewline)
pos <- getPosition
Amount{acommodity,astyle} <- amountp
_ <- followingcommentp <|> (eolof >> return "")
_ <- followingcommentp <|> (lift eolof >> return "")
if acommodity==expectedsym
then return astyle
else parserErrorAt pos $
@ -295,41 +297,41 @@ formatdirectivep expectedsym = do
applyaccountdirectivep :: ErroringJournalParser ()
applyaccountdirectivep = do
string "apply" >> many1 spacenonewline >> string "account"
many1 spacenonewline
parent <- accountnamep
string "apply" >> lift (some spacenonewline) >> string "account"
lift (some spacenonewline)
parent <- lift accountnamep
newline
pushParentAccount parent
endapplyaccountdirectivep :: ErroringJournalParser ()
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
aliasdirectivep :: ErroringJournalParser ()
aliasdirectivep = do
string "alias"
many1 spacenonewline
alias <- accountaliasp
lift (some spacenonewline)
alias <- lift accountaliasp
addAccountAlias alias
accountaliasp :: Monad m => TextParser u m AccountAlias
accountaliasp :: TextParser m AccountAlias
accountaliasp = regexaliasp <|> basicaliasp
basicaliasp :: Monad m => TextParser u m AccountAlias
basicaliasp :: TextParser m AccountAlias
basicaliasp = do
-- pdbg 0 "basicaliasp"
old <- rstrip <$> many1 (noneOf "=")
old <- rstrip <$> (some $ noneOf ("=" :: [Char]))
char '='
many spacenonewline
new <- rstrip <$> anyChar `manyTill` eolof -- don't require a final newline, good for cli options
return $ BasicAlias (T.pack old) (T.pack new)
regexaliasp :: Monad m => TextParser u m AccountAlias
regexaliasp :: TextParser m AccountAlias
regexaliasp = do
-- pdbg 0 "regexaliasp"
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 '/'
many spacenonewline
char '='
@ -345,22 +347,22 @@ endaliasesdirectivep = do
tagdirectivep :: ErroringJournalParser ()
tagdirectivep = do
string "tag" <?> "tag directive"
many1 spacenonewline
_ <- many1 nonspace
restofline
lift (some spacenonewline)
_ <- lift $ some nonspace
lift restofline
return ()
endtagdirectivep :: ErroringJournalParser ()
endtagdirectivep = do
(string "end tag" <|> string "pop") <?> "end tag or pop directive"
restofline
lift restofline
return ()
defaultyeardirectivep :: ErroringJournalParser ()
defaultyeardirectivep = do
char 'Y' <?> "default year"
many spacenonewline
y <- many1 digit
lift (many spacenonewline)
y <- some digitChar
let y' = read y
failIfInvalidYear y
setYear y'
@ -368,41 +370,41 @@ defaultyeardirectivep = do
defaultcommoditydirectivep :: ErroringJournalParser ()
defaultcommoditydirectivep = do
char 'D' <?> "default commodity"
many1 spacenonewline
lift (some spacenonewline)
Amount{..} <- amountp
restofline
lift restofline
setDefaultCommodityAndStyle (acommodity, astyle)
marketpricedirectivep :: ErroringJournalParser MarketPrice
marketpricedirectivep = do
char 'P' <?> "market price"
many spacenonewline
lift (many spacenonewline)
date <- try (do {LocalTime d _ <- datetimep; return d}) <|> datep -- a time is ignored
many1 spacenonewline
symbol <- commoditysymbolp
many spacenonewline
lift (some spacenonewline)
symbol <- lift commoditysymbolp
lift (many spacenonewline)
price <- amountp
restofline
lift restofline
return $ MarketPrice date symbol price
ignoredpricecommoditydirectivep :: ErroringJournalParser ()
ignoredpricecommoditydirectivep = do
char 'N' <?> "ignored-price commodity"
many1 spacenonewline
commoditysymbolp
restofline
lift (some spacenonewline)
lift commoditysymbolp
lift restofline
return ()
commodityconversiondirectivep :: ErroringJournalParser ()
commodityconversiondirectivep = do
char 'C' <?> "commodity conversion"
many1 spacenonewline
lift (some spacenonewline)
amountp
many spacenonewline
lift (many spacenonewline)
char '='
many spacenonewline
lift (many spacenonewline)
amountp
restofline
lift restofline
return ()
--- ** transactions
@ -410,16 +412,16 @@ commodityconversiondirectivep = do
modifiertransactionp :: ErroringJournalParser ModifierTransaction
modifiertransactionp = do
char '=' <?> "modifier transaction"
many spacenonewline
valueexpr <- T.pack <$> restofline
lift (many spacenonewline)
valueexpr <- T.pack <$> lift restofline
postings <- postingsp Nothing
return $ ModifierTransaction valueexpr postings
periodictransactionp :: ErroringJournalParser PeriodicTransaction
periodictransactionp = do
char '~' <?> "periodic transaction"
many spacenonewline
periodexpr <- T.pack <$> restofline
lift (many spacenonewline)
periodexpr <- T.pack <$> lift restofline
postings <- postingsp Nothing
return $ PeriodicTransaction periodexpr postings
@ -429,10 +431,10 @@ transactionp = do
-- ptrace "transactionp"
sourcepos <- genericSourcePos <$> getPosition
date <- datep <?> "transaction"
edate <- optionMaybe (secondarydatep date) <?> "secondary date"
lookAhead (spacenonewline <|> newline) <?> "whitespace or newline"
status <- statusp <?> "cleared status"
code <- T.pack <$> codep <?> "transaction code"
edate <- optional (secondarydatep date) <?> "secondary date"
lookAhead (lift spacenonewline <|> newline) <?> "whitespace or newline"
status <- lift statusp <?> "cleared status"
code <- T.pack <$> lift codep <?> "transaction code"
description <- T.pack . strip <$> descriptionp
comment <- try followingcommentp <|> (newline >> return "")
let tags = commentTags comment
@ -542,23 +544,23 @@ postingsp mdate = many (try $ postingp mdate) <?> "postings"
-- linebeginningwithspaces :: Monad m => JournalParser m String
-- linebeginningwithspaces = do
-- sp <- many1 spacenonewline
-- sp <- lift (some spacenonewline)
-- c <- nonspace
-- cs <- restofline
-- cs <- lift restofline
-- return $ sp ++ (c:cs) ++ "\n"
postingp :: Maybe Day -> ErroringJournalParser Posting
postingp mtdate = do
-- pdbg 0 "postingp"
many1 spacenonewline
status <- statusp
many spacenonewline
lift (some spacenonewline)
status <- lift statusp
lift (many spacenonewline)
account <- modifiedaccountnamep
let (ptype, account') = (accountNamePostingType account, textUnbracket account)
amount <- spaceandamountormissingp
massertion <- partialbalanceassertionp
_ <- fixedlotpricep
many spacenonewline
lift (many spacenonewline)
(comment,tags,mdate,mdate2) <-
try (followingcommentandtagsp mtdate) <|> (newline >> return ("",[],Nothing,Nothing))
return posting

View File

@ -51,22 +51,22 @@ module Hledger.Read.TimeclockReader (
tests_Hledger_Read_TimeclockReader
)
where
import Prelude ()
import Prelude.Compat
import Control.Monad
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Except (ExceptT)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Prelude ()
import Prelude.Compat
import Control.Monad
import Control.Monad.Except (ExceptT)
import Control.Monad.State.Strict
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Test.HUnit
import Text.Parsec hiding (parse)
import System.FilePath
import Test.HUnit
import Text.Megaparsec hiding (parse)
import System.FilePath
import Hledger.Data
import Hledger.Data
-- XXX too much reuse ?
import Hledger.Read.Common
import Hledger.Utils
import Hledger.Read.Common
import Hledger.Utils
reader :: Reader
@ -90,7 +90,7 @@ parse _ = parseAndFinaliseJournal timeclockfilep
timeclockfilep :: ErroringJournalParser ParsedJournal
timeclockfilep = do many timeclockitemp
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.
-- Doing this here rather than in journalFinalise means timeclock sessions can't span file boundaries,
-- but it simplifies code above.
@ -103,18 +103,18 @@ timeclockfilep = do many timeclockitemp
-- comment-only) lines, can use choice w/o try
timeclockitemp = choice [
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"
-- | Parse a timeclock entry.
timeclockentryp :: ErroringJournalParser TimeclockEntry
timeclockentryp = do
sourcepos <- genericSourcePos <$> getPosition
code <- oneOf "bhioO"
many1 spacenonewline
sourcepos <- genericSourcePos <$> lift getPosition
code <- oneOf ("bhioO" :: [Char])
lift (some spacenonewline)
datetime <- datetimep
account <- fromMaybe "" <$> optionMaybe (many1 spacenonewline >> modifiedaccountnamep)
description <- T.pack . fromMaybe "" <$> optionMaybe (many1 spacenonewline >> restofline)
account <- fromMaybe "" <$> optional (lift (some spacenonewline) >> modifiedaccountnamep)
description <- T.pack . fromMaybe "" <$> lift (optional (some spacenonewline >> restofline))
return $ TimeclockEntry sourcepos (read [code]) datetime account description
tests_Hledger_Read_TimeclockReader = TestList [

View File

@ -36,13 +36,14 @@ import Prelude ()
import Prelude.Compat
import Control.Monad
import Control.Monad.Except (ExceptT)
import Control.Monad.State.Strict
import Data.Char (isSpace)
import Data.List (foldl')
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import Test.HUnit
import Text.Parsec hiding (parse)
import Text.Megaparsec hiding (parse)
import System.FilePath
import Hledger.Data
@ -73,13 +74,14 @@ parse _ = parseAndFinaliseJournal timedotfilep
timedotfilep :: ErroringJournalParser ParsedJournal
timedotfilep = do many timedotfileitemp
eof
getState
get
where
timedotfileitemp :: ErroringJournalParser ()
timedotfileitemp = do
ptrace "timedotfileitemp"
choice [
void emptyorcommentlinep
,timedotdayp >>= \ts -> modifyState (addTransactions ts)
,timedotdayp >>= \ts -> modify' (addTransactions ts)
] <?> "timedot day entry, or default year or comment line or blank line"
addTransactions :: [Transaction] -> Journal -> Journal
@ -95,7 +97,7 @@ addTransactions ts j = foldl' (flip ($)) j (map addTransaction ts)
timedotdayp :: ErroringJournalParser [Transaction]
timedotdayp = do
ptrace " timedotdayp"
d <- datep <* eolof
d <- datep <* lift eolof
es <- catMaybes <$> many (const Nothing <$> try emptyorcommentlinep <|>
Just <$> (notFollowedBy datep >> timedotentryp))
return $ map (\t -> t{tdate=d}) es -- <$> many timedotentryp
@ -108,9 +110,9 @@ timedotentryp :: ErroringJournalParser Transaction
timedotentryp = do
ptrace " timedotentryp"
pos <- genericSourcePos <$> getPosition
many spacenonewline
lift (many spacenonewline)
a <- modifiedaccountnamep
many spacenonewline
lift (many spacenonewline)
hours <-
try (followingcommentp >> return 0)
<|> (timedotdurationp <*
@ -137,10 +139,10 @@ timedotdurationp = try timedotnumberp <|> timedotdotsp
-- @
timedotnumberp :: ErroringJournalParser Quantity
timedotnumberp = do
(q, _, _, _) <- numberp
many spacenonewline
(q, _, _, _) <- lift numberp
lift (many spacenonewline)
optional $ char 'h'
many spacenonewline
lift (many spacenonewline)
return q
-- | Parse a quantity written as a line of dots, each representing 0.25.
@ -149,7 +151,7 @@ timedotnumberp = do
-- @
timedotdotsp :: ErroringJournalParser Quantity
timedotdotsp = do
dots <- filter (not.isSpace) <$> many (oneOf ". ")
dots <- filter (not.isSpace) <$> many (oneOf (". " :: [Char]))
return $ (/4) $ fromIntegral $ length dots
tests_Hledger_Read_TimedotReader = TestList [

View File

@ -34,6 +34,7 @@ import Data.Data (Data)
#if !MIN_VERSION_base(4,8,0)
import Data.Functor.Compat ((<$>))
#endif
import qualified Data.Text as T
import Data.Typeable (Typeable)
import Data.Time.Calendar
import System.Console.CmdArgs.Default -- some additional default stuff
@ -194,7 +195,7 @@ maybesmartdateopt d name rawopts =
Just s -> either
(\e -> optserror $ "could not parse "++name++" date: "++show e)
Just
$ fixSmartDateStrEither' d s
$ fixSmartDateStrEither' d (T.pack s)
type DisplayExp = String
@ -203,7 +204,7 @@ maybedisplayopt d rawopts =
maybe Nothing (Just . regexReplaceBy "\\[.+?\\]" fixbracketeddatestr) $ maybestringopt "display" rawopts
where
fixbracketeddatestr "" = ""
fixbracketeddatestr s = "[" ++ fixSmartDateStr d (init $ tail s) ++ "]"
fixbracketeddatestr s = "[" ++ fixSmartDateStr d (T.pack $ init $ tail s) ++ "]"
maybeperiodopt :: Day -> RawOpts -> Maybe (Interval,DateSpan)
maybeperiodopt d rawopts =
@ -212,7 +213,7 @@ maybeperiodopt d rawopts =
Just s -> either
(\e -> optserror $ "could not parse period option: "++show e)
Just
$ parsePeriodExpr d s
$ parsePeriodExpr d (T.pack s)
-- | Legacy-compatible convenience aliases for accountlistmode_.
tree_ :: ReportOpts -> Bool
@ -283,7 +284,7 @@ queryFromOpts d opts@ReportOpts{..} = simplifyQuery $ And $ [flagsq, argsq]
++ (if empty_ then [Empty True] else []) -- ?
++ (maybe [] ((:[]) . Status) (clearedValueFromOpts opts))
++ (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.
queryFromOptsOnly :: Day -> ReportOpts -> Query
@ -317,7 +318,7 @@ queryOptsFromOpts :: Day -> ReportOpts -> [QueryOpt]
queryOptsFromOpts d ReportOpts{..} = flagsqopts ++ argsqopts
where
flagsqopts = []
argsqopts = snd $ parseQuery d query_
argsqopts = snd $ parseQuery d (T.pack query_)
tests_queryOptsFromOpts :: [Test]
tests_queryOptsFromOpts = [

View File

@ -137,11 +137,11 @@ firstJust ms = case dropWhile (==Nothing) ms of
(md:_) -> md
-- | 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
h <- openFile name ReadMode
hSetNewlineMode h universalNewlineMode
hGetContents h
T.hGetContents h
-- | Read a file in universal newline mode, handling any of the usual line ending conventions.
readFileAnyLineEnding :: FilePath -> IO Text

View File

@ -1,4 +1,4 @@
{-# LANGUAGE CPP, FlexibleContexts #-}
{-# LANGUAGE CPP, FlexibleContexts, TypeFamilies #-}
-- | Debugging helpers
-- more:
@ -16,19 +16,21 @@ module Hledger.Utils.Debug (
)
where
import Control.Monad (when)
import Control.Monad.IO.Class
import Data.List
import Debug.Trace
import Safe (readDef)
import System.Environment (getArgs)
import System.Exit
import System.IO.Unsafe (unsafePerformIO)
import Text.Parsec
import Text.Printf
import Control.Monad (when)
import Control.Monad.IO.Class
import Data.List hiding (uncons)
import qualified Data.Text as T
import Debug.Trace
import Hledger.Utils.Parse
import Safe (readDef)
import System.Environment (getArgs)
import System.Exit
import System.IO.Unsafe (unsafePerformIO)
import Text.Megaparsec
import Text.Printf
#if __GLASGOW_HASKELL__ >= 704
import Text.Show.Pretty (ppShow)
import Text.Show.Pretty (ppShow)
#else
-- the required pretty-show version requires GHC >= 7.4
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,
-- 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
pos <- getPosition
next <- take peeklength `fmap` getInput
next <- (T.take peeklength) `fmap` getInput
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
trace s' $ return ()
where
@ -233,7 +235,7 @@ dbgExit msg = const (unsafePerformIO exitFailure) . dbg msg
-- input) to the console when the debug level is at or above
-- this level. Uses unsafePerformIO.
-- 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

View File

@ -1,47 +1,71 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleContexts, TypeFamilies #-}
module Hledger.Utils.Parse where
import Control.Monad.Except
import Data.Char
import Data.List
-- import Data.Text (Text)
-- import qualified Data.Text as T
import Text.Parsec
import Data.Text (Text)
import Text.Megaparsec hiding (State)
import Data.Functor.Identity (Identity(..))
import Text.Printf
import Control.Monad.State.Strict (StateT, evalStateT)
import Hledger.Data.Types
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.
-- Consumes no input if all choices fail.
choice' :: Stream s m t => [ParsecT s u m a] -> ParsecT s u m a
choice' = choice . map Text.Parsec.try
choice' :: [TextParser m a] -> TextParser m a
choice' = choice . map Text.Megaparsec.try
parsewith :: Parsec [Char] () a -> String -> Either ParseError a
parsewith p = runParser p () ""
-- | Backtracking choice, use this when alternatives share a prefix.
-- 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)
parseWithState jps p = runParserT p jps ""
parsewith :: Parsec e Text a -> Text -> Either (ParseError Char e) a
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
parseerror :: ParseError -> a
parseerror :: (Show t, Show e) => ParseError t e -> a
parseerror e = error' $ showParseError e
showParseError :: ParseError -> String
showParseError :: (Show t, Show e) => ParseError t e -> String
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)
nonspace :: (Stream s m Char) => ParsecT s st m Char
nonspace :: TextParser m Char
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")
restofline :: (Stream s m Char) => ParsecT s st m String
restofline :: TextParser m String
restofline = anyChar `manyTill` newline
eolof :: (Stream s m Char) => ParsecT s st m ()
eolof :: TextParser m ()
eolof = (newline >> return ()) <|> eof

View File

@ -8,19 +8,13 @@ module Hledger.Utils.String (
stripbrackets,
unbracket,
-- quoting
quoteIfSpaced,
quoteIfNeeded,
singleQuoteIfNeeded,
-- quotechars,
-- whitespacechars,
escapeDoubleQuotes,
escapeSingleQuotes,
escapeQuotes,
words',
unwords',
stripquotes,
isSingleQuoted,
isDoubleQuoted,
-- * single-line layout
strip,
lstrip,
@ -54,7 +48,7 @@ module Hledger.Utils.String (
import Data.Char
import Data.List
import Text.Parsec
import Text.Megaparsec
import Text.Printf (printf)
import Hledger.Utils.Parse
@ -107,20 +101,11 @@ underline s = s' ++ replicate (length s) '-' ++ "\n"
| last s == '\n' = s
| 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
-- or double-quotes, escaping the quotes as needed.
quoteIfNeeded :: String -> String
quoteIfNeeded s | any (`elem` s) (quotechars++whitespacechars) = "\"" ++ escapeDoubleQuotes s ++ "\""
| otherwise = s
-- | Single-quote this string if it contains whitespace or double-quotes.
-- No good for strings containing single quotes.
singleQuoteIfNeeded :: String -> String
@ -134,9 +119,6 @@ whitespacechars = " \t\n\r"
escapeDoubleQuotes :: String -> String
escapeDoubleQuotes = regexReplace "\"" "\""
escapeSingleQuotes :: String -> String
escapeSingleQuotes = regexReplace "'" "\'"
escapeQuotes :: String -> String
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.
words' :: String -> [String]
words' "" = []
words' s = map stripquotes $ fromparse $ parsewith p s
words' s = map stripquotes $ fromparse $ parsewithString p s
where
p = do ss <- (singleQuotedPattern <|> doubleQuotedPattern <|> pattern) `sepBy` many1 spacenonewline
p = do ss <- (singleQuotedPattern <|> doubleQuotedPattern <|> pattern) `sepBy` some spacenonewline
-- eof
return ss
pattern = many (noneOf whitespacechars)

View File

@ -1,7 +1,7 @@
module Hledger.Utils.Test where
import Test.HUnit
import Text.Parsec
import Text.Megaparsec
-- | Get a Test's label, or the empty string.
testName :: Test -> String
@ -25,15 +25,16 @@ is :: (Eq a, Show a) => a -> a -> Assertion
a `is` e = assertEqual "" e a
-- | 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
-- | 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
-- | 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
printParseError :: (Show a) => a -> IO ()

View File

@ -114,6 +114,14 @@ textElideRight width t =
-- | last s == '\n' = s
-- | 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
-- -- quotes, if it contains whitespace and is not already single- or
-- -- double-quoted.
@ -124,8 +132,8 @@ textElideRight width t =
-- -- | Double-quote this string if it contains whitespace, single quotes
-- -- or double-quotes, escaping the quotes as needed.
-- quoteIfNeeded :: String -> String
-- quoteIfNeeded s | any (`elem` s) (quotechars++whitespacechars) = "\"" ++ escapeDoubleQuotes s ++ "\""
-- quoteIfNeeded :: T.Text -> T.Text
-- quoteIfNeeded s | any (`elem` T.unpack s) (quotechars++whitespacechars) = "\"" <> escapeDoubleQuotes s <> "\""
-- | otherwise = s
-- -- | 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++"'"
-- | otherwise = s
-- quotechars, whitespacechars :: [Char]
-- quotechars = "'\""
-- whitespacechars = " \t\n\r"
quotechars, whitespacechars :: [Char]
quotechars = "'\""
whitespacechars = " \t\n\r"
-- escapeDoubleQuotes :: String -> String
-- escapeDoubleQuotes = regexReplace "\"" "\""
escapeDoubleQuotes :: T.Text -> T.Text
escapeDoubleQuotes = T.replace "\"" "\""
-- escapeSingleQuotes :: String -> String
-- escapeSingleQuotes = regexReplace "'" "\'"
escapeSingleQuotes :: T.Text -> T.Text
escapeSingleQuotes = T.replace "'" "\'"
-- escapeQuotes :: String -> String
-- escapeQuotes = regexReplace "([\"'])" "\\1"
@ -161,18 +169,20 @@ textElideRight width t =
-- doubleQuotedPattern = between (char '"') (char '"') (many $ noneOf "\"")
-- -- | Quote-aware version of unwords - single-quote strings which contain whitespace
-- unwords' :: [String] -> String
-- unwords' = unwords . map quoteIfNeeded
-- unwords' :: [Text] -> Text
-- unwords' = T.unwords . map quoteIfNeeded
-- -- | Strip one matching pair of single or double quotes on the ends of a string.
-- stripquotes :: String -> String
-- stripquotes s = if isSingleQuoted s || isDoubleQuoted s then init $ tail s else s
-- | Strip one matching pair of single or double quotes on the ends of a string.
stripquotes :: Text -> Text
stripquotes s = if isSingleQuoted s || isDoubleQuoted s then T.init $ T.tail s else s
-- isSingleQuoted s@(_:_:_) = head s == '\'' && last s == '\''
-- isSingleQuoted _ = False
isSingleQuoted :: Text -> Bool
isSingleQuoted s =
T.length (T.take 2 s) == 2 && T.head s == '\'' && T.last s == '\''
-- isDoubleQuoted s@(_:_:_) = head s == '"' && last s == '"'
-- isDoubleQuoted _ = False
isDoubleQuoted :: Text -> Bool
isDoubleQuoted s =
T.length (T.take 2 s) == 2 && T.head s == '"' && T.last s == '"'
textUnbracket :: Text -> Text
textUnbracket s

View File

@ -4,7 +4,7 @@ module Hledger.Utils.Tree where
import Data.List (foldl')
import qualified Data.Map as M
import Data.Tree
-- import Text.Parsec
-- import Text.Megaparsec
-- import Text.Printf
import Hledger.Utils.Regex

View File

@ -77,7 +77,7 @@ dependencies:
- mtl
- mtl-compat
- old-time
- parsec >= 3
- megaparsec >= 5
- regex-tdfa
- safe >= 0.2
- split >= 0.1 && < 0.3

View File

@ -78,9 +78,11 @@ library
, mtl
, mtl-compat
, old-time
, parsec >= 3
, megaparsec >= 5
, parsec
, regex-tdfa
, safe >= 0.2
, semigroups
, split >= 0.1 && < 0.3
, text >= 1.2 && < 1.3
, transformers >= 0.2 && < 0.6
@ -159,7 +161,7 @@ test-suite hunittests
, mtl
, mtl-compat
, old-time
, parsec >= 3
, megaparsec >= 5
, regex-tdfa
, safe >= 0.2
, split >= 0.1 && < 0.3

View File

@ -17,7 +17,7 @@ import Control.Monad.IO.Class (liftIO)
import Data.Monoid
import Data.Time.Calendar (Day)
import Graphics.Vty (Event(..),Key(..))
import Text.Parsec
import Text.Megaparsec
import Hledger.Cli hiding (progname,prognameandversion,green)
import Hledger.UI.UIOptions
@ -88,7 +88,7 @@ esHandle ui@UIState{
EvKey (KChar c) [] | c `elem` ['h','?'] -> continue $ setMode Help ui
EvKey (KChar 'E') [] -> suspendAndResume $ void (runEditor pos f) >> uiReloadJournalIfChanged copts d j (popScreen ui)
where
(pos,f) = case parsewith hledgerparseerrorpositionp esError of
(pos,f) = case parsewithString hledgerparseerrorpositionp esError of
Right (f,l,c) -> (Just (l, Just c),f)
Left _ -> (endPos, journalFilePath j)
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.
-- Temporary, we should keep the original parse error location. XXX
hledgerparseerrorpositionp :: ParsecT Dec String t (String, Int, Int)
hledgerparseerrorpositionp = do
anyChar `manyTill` char '"'
f <- anyChar `manyTill` (oneOf ['"','\n'])
string " (line "
l <- read <$> many1 digit
l <- read <$> some digitChar
string ", column "
c <- read <$> many1 digit
c <- read <$> some digitChar
return (f, l, c)
-- Unconditionally reload the journal, regenerating the current screen

View File

@ -69,7 +69,7 @@ executable hledger-ui
, HUnit
, microlens >= 0.4 && < 0.5
, microlens-platform >= 0.2.3.1 && < 0.4
, parsec >= 3
, megaparsec >= 5
, process >= 1.2
, safe >= 0.2
, split >= 0.1 && < 0.3

View File

@ -85,7 +85,7 @@ executables:
- HUnit
- microlens >= 0.4 && < 0.5
- microlens-platform >= 0.2.3.1 && < 0.4
- parsec >= 3
- megaparsec >= 5
- process >= 1.2
- safe >= 0.2
- split >= 0.1 && < 0.3

View File

@ -215,8 +215,8 @@ nullviewdata = viewdataWithDateAndParams nulldate "" "" ""
-- | Make a ViewData using the given date and request parameters, and defaults elsewhere.
viewdataWithDateAndParams :: Day -> String -> String -> String -> ViewData
viewdataWithDateAndParams d q a p =
let (querymatcher,queryopts) = parseQuery d q
(acctsmatcher,acctsopts) = parseQuery d a
let (querymatcher,queryopts) = parseQuery d (pack q)
(acctsmatcher,acctsopts) = parseQuery d (pack a)
in VD {
opts = defwebopts
,j = nulljournal

View File

@ -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
-- Foundation so that the add form can be in the default layout for
-- all views.)
@ -10,13 +10,14 @@ import Import
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
import Control.Monad.State.Strict (evalStateT)
import Data.Either (lefts,rights)
import Data.List (sort)
import qualified Data.List as L (head) -- qualified keeps dev & prod builds warning-free
import Data.Text (append, pack, unpack)
import qualified Data.Text as T
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.Data hiding (num)
@ -55,7 +56,7 @@ postAddForm = do
validateDate :: Text -> Handler (Either FormMessage Day)
validateDate s = return $
case fixSmartDateStrEither' today $ strip $ unpack s of
case fixSmartDateStrEither' today $ T.pack $ strip $ unpack s of
Right d -> Right d
Left _ -> Left $ MsgInvalidEntry $ pack "could not parse date \"" `append` s `append` pack "\":" -- ++ show e)
@ -83,11 +84,11 @@ postAddForm = do
let numberedParams s =
reverse $ dropWhile (T.null . snd) $ reverse $ sort
[ (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
, 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"
amtparams = numberedParams "amount"
num = length acctparams
@ -95,8 +96,8 @@ postAddForm = do
| map fst acctparams == [1..num] &&
map fst amtparams `elem` [[1..num], [1..num-1]] = []
| otherwise = ["the posting parameters are malformed"]
eaccts = map (runParser (accountnamep <* eof) () "" . textstrip . snd) acctparams
eamts = map (runParser (amountp <* eof) mempty "" . textstrip . snd) amtparams
eaccts = map (runParser (accountnamep <* eof) "" . textstrip . snd) acctparams
eamts = map (runParser (evalStateT (amountp <* eof) mempty) "" . textstrip . snd) amtparams
(accts, acctErrs) = (rights eaccts, map show $ lefts eaccts)
(amts', amtErrs) = (rights eamts, map show $ lefts eamts)
amts | length amts' == num = amts'

View File

@ -226,10 +226,10 @@ balanceReportAsHtml _ vd@VD{..} (items',total) =
acctonlyquery = (RegisterR, [("q", T.pack $ accountOnlyQuery acct)])
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 a = "inacctonly:" ++ quoteIfSpaced (T.unpack a) -- (accountNameToAccountRegex a)
accountOnlyQuery a = "inacctonly:" ++ T.unpack (quoteIfSpaced a ) -- (accountNameToAccountRegex a)
accountUrl :: AppRoute -> AccountName -> (AppRoute, [(Text, Text)])
accountUrl r a = (r, [("q", T.pack $ accountQuery a)])

View File

@ -101,7 +101,8 @@ library
, http-client
, HUnit
, conduit-extra >= 1.1
, parsec >= 3
, megaparsec >= 5
, mtl
, safe >= 0.2
, shakespeare >= 2.0
, template-haskell

View File

@ -12,6 +12,8 @@ import Prelude ()
import Prelude.Compat
import Control.Exception as E
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.State.Strict (evalState, evalStateT)
import Control.Monad.Trans (liftIO)
import Data.Char (toUpper, toLower)
import Data.List.Compat
@ -28,7 +30,8 @@ import System.Console.Haskeline.Completion
import System.Console.Wizard
import System.Console.Wizard.Haskeline
import System.IO ( stderr, hPutStr, hPutStrLn )
import Text.Parsec
import Text.Megaparsec
import Text.Megaparsec.Text
import Text.Printf
import Hledger
@ -86,7 +89,7 @@ add opts j
showHelp
today <- getCurrentDay
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
,esDefDate=today
,esJournal=j
@ -183,11 +186,11 @@ dateAndCodeWizard EntryState{..} = do
where
parseSmartDateAndCode refdate s = either (const Nothing) (\(d,c) -> return (fixSmartDate refdate d, c)) edc
where
edc = runParser (dateandcodep <* eof) mempty "" $ T.pack $ lowercase s
dateandcodep :: Monad m => JournalParser m (SmartDate, Text)
edc = runParser (dateandcodep <* eof) "" $ T.pack $ lowercase s
dateandcodep :: Parser (SmartDate, Text)
dateandcodep = do
d <- smartdate
c <- optionMaybe codep
c <- optional codep
many spacenonewline
eof
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 _ _ s = dbg1 $ fmap T.unpack $
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
validateAccount :: Text -> Maybe Text
validateAccount t | no_new_accounts_ esOpts && not (t `elem` journalAccountNames esJournal) = Nothing
@ -276,13 +279,17 @@ amountAndCommentWizard EntryState{..} = do
maybeRestartTransaction $
line $ green $ printf "Amount %d%s: " pnum (showDefault def)
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}
amountandcommentp :: Monad m => JournalParser m (Amount, Text)
amountandcommentp :: JournalParser (Amount, Text)
amountandcommentp = do
a <- amountp
many spacenonewline
c <- T.pack <$> fromMaybe "" `fmap` optionMaybe (char ';' >> many anyChar)
lift (many spacenonewline)
c <- T.pack <$> fromMaybe "" `fmap` optional (char ';' >> many anyChar)
-- eof
return (a,c)
balancingamt = negate $ sum $ map pamount realps where realps = filter isReal esPostings

View File

@ -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 (
@ -69,6 +69,7 @@ import Control.Monad (when)
#if !MIN_VERSION_base(4,8,0)
import Data.Functor.Compat ((<$>))
#endif
import Data.Functor.Identity (Identity)
import Data.List.Compat
import Data.List.Split (splitOneOf)
import Data.Maybe
@ -86,7 +87,7 @@ import System.Environment
import System.Exit (exitSuccess)
import System.FilePath
import Test.HUnit
import Text.Parsec
import Text.Megaparsec
import Hledger
import Hledger.Cli.DocFiles
@ -334,11 +335,11 @@ rawOptsToCliOpts rawopts = checkCliOpts <$> do
return defcliopts {
rawopts_ = 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
,output_file_ = maybestringopt "output-file" 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
,ignore_assertions_ = boolopt "ignore-assertions" rawopts
,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.
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_
-- | Get the (tilde-expanded, absolute) journal file path from
@ -453,7 +454,7 @@ rulesFilePathFromOpts opts = do
widthFromOpts :: CliOpts -> Int
widthFromOpts CliOpts{width_=Nothing, available_width_=w} = w
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
Right w -> w
@ -471,14 +472,14 @@ widthFromOpts CliOpts{width_=Just s} =
registerWidthsFromOpts :: CliOpts -> (Int, Maybe Int)
registerWidthsFromOpts CliOpts{width_=Nothing, available_width_=w} = (w, Nothing)
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
Right ws -> ws
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
totalwidth <- read `fmap` many1 digit
descwidth <- optionMaybe (char ',' >> read `fmap` many1 digit)
totalwidth <- read `fmap` some digitChar
descwidth <- optional (char ',' >> read `fmap` some digitChar)
eof
return (totalwidth, descwidth)
@ -556,12 +557,12 @@ hledgerExecutablesInPath = do
-- isExecutable f = getPermissions f >>= (return . executable)
isHledgerExeName :: String -> Bool
isHledgerExeName = isRight . parsewith hledgerexenamep
isHledgerExeName = isRight . parsewith hledgerexenamep . T.pack
where
hledgerexenamep = do
_ <- string progname
_ <- char '-'
_ <- many1 (noneOf ".")
_ <- some (noneOf ".")
optional (string "." >> choice' (map string addonExtensions))
eof

View File

@ -27,6 +27,7 @@ import Data.List
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Time (Day)
import Safe (readMay)
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
-- is different from the current file contents, and return a flag
-- indicating whether we did anything.
writeFileWithBackupIfChanged :: FilePath -> String -> IO Bool
writeFileWithBackupIfChanged :: FilePath -> T.Text -> IO Bool
writeFileWithBackupIfChanged f t = do
s <- readFile' f
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
-- overwrite it with this new text, or give an error.
writeFileWithBackup :: FilePath -> String -> IO ()
writeFileWithBackup f t = backUpFile f >> writeFile f t
readFileStrictly :: FilePath -> IO String
readFileStrictly f = readFile' f >>= \s -> C.evaluate (length s) >> return s
readFileStrictly :: FilePath -> IO T.Text
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.
backUpFile :: FilePath -> IO ()

View File

@ -100,11 +100,12 @@ library
, mtl
, mtl-compat
, old-time
, parsec >= 3
, megaparsec >= 5
, process
, regex-tdfa
, safe >= 0.2
, split >= 0.1 && < 0.3
, transformers
, temporary
, text >= 0.11
, tabular >= 0.2 && < 0.3

View File

@ -12,5 +12,6 @@ packages:
extra-deps:
- brick-0.8
- megaparsec-5.0.1
# https://docs.haskellstack.org/en/stable/yaml_configuration/

View File

@ -40,5 +40,5 @@ hledger -f- print
<<<
2015/9/6*
a 0
>>>2 /unexpected "*"/
>>>2 /unexpected '*'/
>>>= 1

View File

@ -23,7 +23,7 @@ end comment
b 0
; date: 3.32
>>>2 /line 10, column 19/
>>>2 /10:19/
>>>=1
# 3. Ledger's bracketed date syntax is also supported: `[DATE]`,
@ -50,5 +50,5 @@ end comment
2000/1/2
b 0 ; [1/1=1/2/3/4] bad second date, should error
>>>2 /line 9, column 25/
>>>2 /9:25/
>>>=1